C      ALGORITHM 814, COLLECTED ALGORITHMS FROM ACM.
C      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C      VOL. 27,NO. 4,  December, 2001, P.  377--387.
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#	Doc/
#	Doc/ReadMe
#	Fortran90/
#	Fortran90/Sp/
#	Fortran90/Sp/Drivers/
#	Fortran90/Sp/Drivers/SAMPLE.CHK
#	Fortran90/Sp/Drivers/SampleFM.f90
#	Fortran90/Sp/Drivers/TestFM.f90
#	Fortran90/Sp/Src/
#	Fortran90/Sp/Src/FM.f90
#	Fortran90/Sp/Src/FMSAVE.f90
#	Fortran90/Sp/Src/FMZM90.f90
# This archive created: Thu Mar  7 18:00:52 2002
export PATH; PATH=/bin:$PATH
if test ! -d 'Doc'
then
	mkdir 'Doc'
fi
cd 'Doc'
if test -f 'ReadMe'
then
	echo shar: will not over-write existing file "'ReadMe'"
else
cat << "SHAR_EOF" > 'ReadMe'

This is a list of the files for version 1.2 of FMLIB.

1.  FMSAVE.f90        Module for FM internal global variables

2.  FMZM90.f90        Modules for interfaces and definitions of derived-types

3.  FM.f90            Subroutine library for multiple-precision operations

4.  TestFM.f90        Test program for most of the FM routines

5.  SampleFM.f90      Small sample program using FM

6.  SAMPLE.CHK        Expected output file SAMPLE.LOG from SampleFM.f90


Here is an example set of compiler/linker commands for building
the programs.  For lines on which there is no *.f90 file listed,
the f90 script skips the compiler and calls the linker.
Options:
      -c       compile to object code -- don't make executable
      -O       optimization on
      -f free  Fortran-90 free source form
      -o       output file name


f90   FMSAVE.f90  -c  -f free   -o FMSAVE.o


f90   FMZM90.f90  -c  -f free   -o FMZM90.o


f90   FM.f90  -O  -c  -f free   -o FM.o


f90   TestFM.f90  -c  -f free   -o TestFM.o

f90   TestFM.o    FMSAVE.o    FMZM90.o     FM.o      -o TestFM


f90   SampleFM.f90  -c    -f free   -o  SampleFM.o

f90   SampleFM.o    FMSAVE.o     FMZM90.o      FM.o     -o SampleFM


Basically the first three files are compiled as object code libraries, and
then a program using FM is compiled and linked to those three libraries.

Most compilers also produce files FMVALS.mod, FMZM.mod, etc., containing
module information from the first two files.


Troubleshooting

1.  After downloading the files, if the compiler gives many error messages or
    it appears to see no code in the file at all, check that the lines in the
    file have the proper end-of-line characters for your system.

    For a PC, this means each line should end with both a carriage return <cr>
    character (ascii 13) and a line feed <lf> character (ascii 10).  If the
    file appears to be one huge line when viewed in an editor, one of these
    two characters is probably missing and should be added to each line.

    To use FM on a Unix system, lines end with <lf>, and for a Mac system they
    end with <cr>.  On these systems, failing to fix the end-of-line characters
    might mean the file seems to have twice the expected number of lines, with
    a blank line between each line of code when viewed in an editor.

    Many good editors will recognize a foreign end-of-line format and
    automatically fix each file the first time it is opened.

2.  Compiler gives an "out of memory" error message or crashes during compile
    of FM.f90 or FMZM90.f90.

    It might be necessary to break the file into smaller pieces or split it
    into separate files for each routine or module.  This could be caused by
    lack of system memory, lack of virtual memory, or a bug (memory leak) in
    the compiler.

    Some compilers have an option (-split) to do this automatically.

3.  Most of the routines compile, but a few fail with error messages like
    "symbol 120 is not the label of a branch target statement".
    However, looking at the code shows there is a label 120 in that routine.

    This might happen in the larger routines.  Some compilers may require
    additional options be enabled (e.g., to force 32-bit branches or addresses
    to be used).  Check in the compiler manual and try turning on any options
    that mention "long branches", "32-bit addresses", etc.

4.  All files compile, but the TestFM program reports a few errors when it runs.
    There are other possibilities, but one thing to check is whether the
    compiler has any options controlling arithmetic precision of intermediate
    results.

    Because the FM numbers are stored as integer values in double precision
    arrays, any sloppy rounding can cause problems.  In one case, a compiler
    optimized an expression by leaving the result of a division in an 80-bit
    register and then used that result later in the calculation.  Rounding
    the division back to double precision would have fixed the error, but
    using the inaccurate extended precision value caused the final result to
    be off by one when it was returned to an integer value.

    This compiler had an option (-ap) to force intermediate results to not be
    left in registers, and that fixed the problem.

    Another way to check to see if this is the problem is to create a version
    of FM that uses integer arrays instead of double precision.  See the section
    titled "EFFICIENCY" below to see how to make this change.  On most machines,
    there is little if any speed penalty for using integer arrays as long as the
    precision is under 100 significant digits (i.e., NDIG < 15 or so with MBASE
    = 10**7).

5.  Several messages like this appear:
    C:\t\FMZM90.f90(6563) : Info: This variable has not been used. [MA]
      FUNCTION FMTINY_ZM(MA)

    This and the other messages of the same type are not errors.  The argument
    for functions like TINY is not used for anything except telling the
    compiler which routine to call by checking the argument's type.  The same
    is true of the Fortran intrinsic function TINY.  If we say TINY(1.0) or
    TINY(2.0), the input argument is not used, other than to indicate that we
    want the single precision value of TINY.



================================================================================
================================================================================


                    USER'S GUIDE FOR THE FM PACKAGE


The various lists of available multiple precision operations and
routines have been collected here, along with some general advice
on using the package.

See the program SampleFM.f90 for some examples of initializing and
using the package.


INITIALIZATION:    The default precision for the multiple-precision numbers
                   is about 50 significant digits.

                   To set precision to a different value, put
      CALL FMSET(N)
                   in the main program before any multiple precision
                   operations are done, with N replaced by the number
                   of decimal digits of accuracy to be used.

ROUTINE NAMES:     For each multiple precision operation there are
                   several routines with related names that perform
                   variations of that operation.  For example, the
                   addition operation has these forms:

                   Using the Fortran-90 interface module, to perform
                   real (floating-point) multiple precision addition,
                   declare the variables as FM derived types with

      USE FMZM
      TYPE ( FM ) A,B,C

                   and then add using

      C = A + B

                   Normally, using the interface module avoids the need
                   to know the name of the FM routine being called.  For
                   some operations, usually those that are not Fortran-90
                   functions (such as formatting a number), a direct call
                   may be needed.  The addition above can be done as

      CALL FM_ADD(A,B,C)

                   It is rare for a program to bypass the derived types
                   and work directly with the arrays that define the
                   multiple-precision numbers.  The only real drawback
                   to using the derived types is a small performance
                   penalty (that varies from one compiler to another).
                   If FM.f90 is used without the interface module, then
                   the multiple precision numbers are declared as arrays

      DOUBLE PRECISION A(-1:LUNPCK),B(-1:LUNPCK),C(-1:LUNPCK)

                   where LUNPCK is defined in FMSAVE.f90.  The numbers are
                   then added by calling the FM routine where the arguments
                   are assumed to be arrays, not TYPE (FM) derived types:

      CALL FMADD(A,B,C)

                   For each of the routines listed below (like FMADD),
                   there is a version that assumes the arguments have
                   the appropriate derived type.  These have the same
                   names, except "_" has been inserted after the first
                   two letters of the name (like FM_ADD).

                   If direct calls are done instead of using the
                   interface module, there is another form for these
                   routine names that is used when the arrays have been
                   declared in a packed format that takes roughly half
                   as much space:

      DOUBLE PRECISION A(-1:LPACK),B(-1:LPACK),C(-1:LPACK)

                   The routines that work with packed arrays have names
                   where the second letter has been changed from M to P:

      CALL FPADD(A,B,C)

                   The packed versions are slower.

                   For multiple precision integer (IM) or complex (ZM)
                   operations there are similar Fortran-90 derived types
                   and the various routines:

      USE FMZM
      ...
      TYPE ( IM ) A,B,C
      TYPE ( ZM ) X,Y,Z
      ...
      C = A + B
      ...
      Z = X + Y

                   with explicit calls of the form

      CALL IM_ADD(A,B,C)
      CALL ZM_ADD(X,Y,Z)

                   Without using the interface module:

      DOUBLE PRECISION A(-1:LUNPCK),B(-1:LUNPCK),C(-1:LUNPCK)
      DOUBLE PRECISION X(-1:LUNPKZ),Y(-1:LUNPKZ),Z(-1:LUNPKZ)
      ...
      CALL IMADD(A,B,C)
      ...
      CALL ZMADD(X,Y,Z)

                   Packed format without the interface module:

      DOUBLE PRECISION A(-1:LPACK),B(-1:LPACK),C(-1:LPACK)
      DOUBLE PRECISION X(-1:LPACKZ),Y(-1:LPACKZ),Z(-1:LPACKZ)
      ...
      CALL IPADD(A,B,C)
      ...
      CALL ZPADD(X,Y,Z)



--------------------------------------------------------------------------------
-----------------------   Fortran-90 Interface Notes   -------------------------




There are three multiple precision data types:
   FM  (multiple precision real)
   IM  (multiple precision integer)
   ZM  (multiple precision complex)

Some of the interface routines assume that the precision chosen in the
calling program (using FMSET) represents more significant digits than does
the machine's double precision.

Most of the functions defined in this module are multiple precision versions
of standard Fortran-90 functions.  In addition, there are functions for
direct conversion, formatting, and some mathematical special functions.

TO_FM is a function for converting other types of numbers to type FM.  Note
that TO_FM(3.12) converts the REAL constant to FM, but it is accurate only
to single precision.  TO_FM(3.12D0) agrees with 3.12 to double precision
accuracy, and TO_FM('3.12') or TO_FM(312)/TO_FM(100) agrees to full FM
accuracy.

TO_IM converts to type IM, and TO_ZM converts to type ZM.

Functions are also supplied for converting the three multiple precision types
to the other numeric data types:
   TO_INT   converts to machine precision integer
   TO_SP    converts to single precision
   TO_DP    converts to double precision
   TO_SPZ   converts to single precision complex
   TO_DPZ   converts to double precision complex

WARNING:   When multiple precision type declarations are inserted in an
           existing program, take care in converting functions like DBLE(X),
           where X has been declared as a multiple precision type.  If X
           was single precision in the original program, then replacing
           the DBLE(X) by TO_DP(X) in the new version could lose accuracy.
           For this reason, the Fortran type-conversion functions defined
           in this module assume that results should be multiple precision
           whenever inputs are.  Examples:
           DBLE(TO_FM('1.23E+123456')) is type FM
           REAL(TO_FM('1.23E+123456')) is type FM
           REAL(TO_ZM('3.12+4.56i'))   is type FM   = TO_FM('3.12')
           INT(TO_FM('1.23'))          is type IM   = TO_IM(1)
           INT(TO_IM('1E+23'))         is type IM
           CMPLX(TO_FM('1.23'),TO_FM('4.56')) is type ZM

Programs using this module may sometimes need to call FM, IM, or ZM routines
directly.  This is normally the case when routines are needed that are not
Fortran-90 intrinsics, such as the formatting subroutine FMFORM.  In a
program using this module, suppose MAFM has been declared with
TYPE ( FM ) MAFM.  To use the routine FMFORM, which expects the second
argument to be an array and not a derived type, the call would have to be
CALL FMFORM('F65.60',MAFM%MFM,ST1) so that the array contained in MAFM is
passed.

As an alternative so the user can refer directly to the FM-, IM-, and ZM-type
variables and avoid the cumbersome "%MFM" suffixes, the FM package provides a
collection of interface routines to supply any needed argument conversions.
For each FM, IM, and ZM routine that is designed to be called by the user,
there is also a version that assumes any multiple-precision arguments are
derived types instead of arrays.  Each interface routine has the same name as
the original with an underscore after the first two letters of the routine
name.  To convert the number to a character string with F65.60 format, use
CALL FM_FORM('F65.60',MAFM,ST1) if MAFM is of TYPE ( FM ), or use
CALL FMFORM('F65.60',MA,ST1) if MA is declared as an array.  All the routines
shown below may be used this way.

For each of the operations =,  == ,  /= ,  < ,  <= ,  > ,  >= , +, -, *, /,
and **, the interface module defines all mixed mode variations involving one
of the three multiple precision derived types and another argument having one
of the types: { integer, real, double, complex, complex double, FM, IM, ZM }.
So mixed mode expressions such as
      MAFM = 12
      MAFM = MAFM + 1
      IF (ABS(MAFM) > 1.0D-23) THEN
are handled correctly.

Not all the named functions are defined for all three multiple precision
derived types, so the list below shows which can be used.  The labels "real",
"integer", and "complex" refer to types FM, IM, and ZM respectively, "string"
means the function accepts character strings (e.g., TO_FM('3.45')), and
"other" means the function can accept any of the machine precision data types
integer, real, double, complex, or complex double.  For functions that accept
two or more arguments, like ATAN2 or MAX, all the arguments must be of the
same type.


AVAILABLE OPERATIONS:

   =
   +
   -
   *
   /
   **
   ==
   /=
   <
   <=
   >
   >=
   ABS          real    integer    complex
   ACOS         real               complex
   AIMAG                           complex
   AINT         real               complex
   ANINT        real               complex
   ASIN         real               complex
   ATAN         real               complex
   ATAN2        real
   BTEST                integer
   CEILING      real               complex
   CMPLX        real    integer
   CONJ                            complex
   COS          real               complex
   COSH         real               complex
   DBLE         real    integer    complex
   DIGITS       real    integer    complex
   DIM          real    integer
   DINT         real               complex
   DOTPRODUCT   real    integer    complex
   EPSILON      real
   EXP          real               complex
   EXPONENT     real
   FLOOR        real    integer    complex
   FRACTION     real               complex
   HUGE         real    integer    complex
   INT          real    integer    complex
   LOG          real               complex
   LOG10        real               complex
   MATMUL       real    integer    complex
   MAX          real    integer
   MAXEXPONENT  real
   MIN          real    integer
   MINEXPONENT  real
   MOD          real    integer
   MODULO       real    integer
   NEAREST      real
   NINT         real    integer    complex
   PRECISION    real               complex
   RADIX        real    integer    complex
   RANGE        real    integer    complex
   REAL         real    integer    complex
   RRSPACING    real
   SCALE        real               complex
   SETEXPONENT  real
   SIGN         real    integer
   SIN          real               complex
   SINH         real               complex
   SPACING      real
   SQRT         real               complex
   TAN          real               complex
   TANH         real               complex
   TINY         real    integer    complex
   TO_FM        real    integer    complex    string    other
   TO_IM        real    integer    complex    string    other
   TO_ZM        real    integer    complex    string    other
   TO_INT       real    integer    complex
   TO_SP        real    integer    complex
   TO_DP        real    integer    complex
   TO_SPZ       real    integer    complex
   TO_DPZ       real    integer    complex

Some other functions are defined that do not correspond to machine precision
intrinsic functions.  These include formatting functions, integer modular
functions and GCD, and the Gamma function and its related functions.
N below is a machine precision integer, J1, J2, J3 are TYPE (IM), FMT, FMTR,
FMTI are character strings, A,B,X are TYPE (FM), and Z is TYPE (ZM).
The three formatting functions return a character string containing the
formatted number, the three TYPE (IM) functions return a TYPE (IM) result,
and the 12 special functions return TYPE (FM) results.

Formatting functions:

   FM_FORMAT(FMT,A)        Put A into FMT (real) format
   IM_FORMAT(FMT,J1)       Put J1 into FMT (integer) format
   ZM_FORMAT(FMTR,FMTI,Z)  Put Z into (complex) format, FMTR for the real
                           part and FMTI for the imaginary part

   Examples:
      ST = FM_FORMAT('F65.60',A)
      WRITE (*,*) ' A = ',TRIM(ST)
      ST = FM_FORMAT('E75.60',B)
      WRITE (*,*) ' B = ',ST(1:75)
      ST = IM_FORMAT('I50',J1)
      WRITE (*,*) ' J1 = ',ST(1:50)
      ST = ZM_FORMAT('F35.30','F30.25',Z)
      WRITE (*,*) ' Z = ',ST(1:70)

   These functions are used for one-line output.  The returned character
   strings are of length 200.  Avoid using the formatting function in the
   write list, as in
      WRITE (*,*) ' J1 = ',IM_FORMAT('I50',J1)(1:50)
   since the formatting functions may themselves execute an internal WRITE
   and that would cause a recursive write reference.

   For higher precision numbers, the output can be broken onto multiple
   lines automatically by calling subroutines FM_PRNT, IM_PRNT, ZM_PRNT,
   or the line breaks can be done by hand after calling one of the
   subroutines FM_FORM, IM_FORM, ZM_FORM.

   For ZM_FORMAT the length of the output is 5 more than the sum of the
   two field widths.

Integer functions:

   GCD(J1,J2)              Greatest Common Divisor of J1 and J2.
   MULTIPLY_MOD(J1,J2,J3)  J1 * J2 mod J3
   POWER_MOD(J1,J2,J3)     J1 ** J2 mod J3

Special functions:

   BERNOULLI(N)            Nth Bernoulli number
   BETA(A,B)               Integral (0 to 1)  t**(A-1) * (1-t)**(B-1)  dt
   BINOMIAL(A,B)           Binomial Coefficient  A! / ( B! (A-B)! )
   FACTORIAL(A)            A!
   GAMMA(A)                Integral (0 to infinity)  t**(A-1) * exp(-t)  dt
   INCOMPLETE_BETA(X,A,B)  Integral (0 to X)  t**(A-1) * (1-t)**(B-1)  dt
   INCOMPLETE_GAMMA1(A,X)  Integral (0 to X)  t**(A-1) * exp(-t)  dt
   INCOMPLETE_GAMMA2(A,X)  Integral (X to infinity)  t**(A-1) * exp(-t)  dt
   LOG_GAMMA(A)            Ln( GAMMA(A) )
   POLYGAMMA(N,A)          Nth derivative of Psi(x), evaluated at A
   POCHHAMMER(A,N)         A*(A+1)*(A+2)*...*(A+N-1)
   PSI(A)                  Derivative of Ln(Gamma(x)), evaluated at A



--------------------------------------------------------------------------------
------------------------------   FM.f90 Notes   --------------------------------



The routines in this package perform multiple precision arithmetic and
functions on three kinds of numbers.
FM routines handle floating-point real multiple precision numbers,
IM routines handle integer multiple precision numbers, and
ZM routines handle floating-point complex multiple precision numbers.


1. INITIALIZING THE PACKAGE

The variables that contain values to be shared among the different routines
are located in module FMVALS in file FMSAVE.f90.  Variables that are described
below for controlling various features of the FM package are found in this
module.  They are initialized to default values assuming 32-bit integers and
64-bit double precision representation of the arrays holding multiple
precision numbers.  The base and number of digits to be used are initialized
to give slightly more than 50 decimal digits.  Subroutine FMVARS can be used
to get a list of these variables and their values.

The intent of module FMVALS is to hide the FM internal variables from the
user's program, so that no name conflicts can occur.  Subroutine FMSETVAR can
be used to change the variables listed below to new values.  It is not always
safe to try to change these variables directly by putting USE FMVALS into the
calling program and then changing them by hand.  Some of the saved constants
depend upon others, so that changing one variable may cause errors if others
depending on that one are not also changed.  FMSETVAR automatically updates
any others that depend upon the one being changed.

Subroutine FMSET also initializes these variables.  It tries to compute the
best value for each, and it checks several of the values set in FMVALS to see
that they are reasonable for a given machine.  FMSET can also be called to
set or change the current precision level for the multiple precision numbers.

Calling FMSET is optional in version 1.2 of the FM package.  In previous
versions one call was required before any other routine in the package could
be used.

The routine ZMSET from version 1.1 is no longer needed, and the complex
operations are automatically initialized in FMVALS.  It has been left in the
package for compatibility with version 1.1.


2.  REPRESENTATION OF FM NUMBERS

MBASE is the base in which the arithmetic is done.  MBASE must be
      bigger than one, and less than or equal to the square root of
      the largest representable integer.  For best efficiency MBASE
      should be large, but no more than about 1/4 of the square root
      of the largest representable integer.  Input and output
      conversions are much faster when MBASE is a power of ten.

NDIG  is the number of base MBASE digits that are carried in the
      multiple precision numbers.  NDIG must be at least two.  The
      upper limit for NDIG is defined in FMVALS and is restricted
      only by the amount of memory available.

Sometimes it is useful to dynamically vary NDIG during the program.  Routine
FMEQU should be used to round numbers to lower precision or zero-pad them to
higher precision when changing NDIG.

The default value of MBASE is a large power of ten.  FMSET also sets MBASE to
a large power of ten.  For an application where another base is used, such as
simulating a given machine's base two arithmetic, use subroutine FMSETVAR to
change MBASE, so that the other internal values depending on MBASE will be
changed accordingly.

There are two representations for a floating point multiple precision number.
The unpacked representation used by the routines while doing the computations
is base MBASE and is stored in NDIG+2 words.  A packed representation is
available to store the numbers in the user's program in compressed form.  In
this format, the NDIG (base MBASE) digits of the mantissa are packed two per
word to conserve storage.  Thus the external, packed form of a number
requires (NDIG+1)/2+2 words.

This version uses double precision arrays to hold the numbers.  Version 1.0
of FM used integer arrays, which are faster on some machines.  The package
can be changed to use integer arrays --- see section 11 on EFFICIENCY below.

The unpacked format of a floating multiple precision number is as follows.
A number MA is kept in an array with MA(1) containing the exponent, and
MA(2) through MA(NDIG+1) each containing one digit of the mantissa, expressed
in base MBASE.  The array is dimensioned to start at MA(-1), with the
sign of the number (+1 or -1) held in MA(-1), and the  approximate number
of bits of precision stored in MA(0).  This precision value is intended to
be used by FM functions that need to monitor cancellation error in addition
and subtraction.  The cancellation monitor code is usually disabled for user
calls, and FM functions only check for cancellation when they must.  Tracking
cancellation causes most routines to run slower, with addition and
subtraction being affected the most.  The exponent is a power of MBASE and
the implied radix point is immediately before the first digit of the
mantissa.  Every nonzero number is normalized so that the second array
element (the first digit of the mantissa) is nonzero.

In both representations the sign of the number is carried on the second array
element only.  Elements 3,4,... are always nonnegative.  The exponent is a
signed integer and may be as large in magnitude as MXEXP.

For MBASE = 10,000 and NDIG = 4, the number -pi would have these
representations:
                 Word 1         2         3         4         5

       Unpacked:      1        -3      1415      9265      3590
       Packed:        1    -31415  92653590

In both formats MA(0) would be 42, indicating that the mantissa has about 42
bits of precision, and MA(-1) = -1 since the number is negative.

Because of normalization in a large base, the equivalent number of base 10
significant digits for an FM number may be as small as
LOG10(MBASE)*(NDIG-1) + 1.

The integer routines use the FM format to represent numbers, without the
number of digits (NDIG) being fixed.  Integers in IM format are essentially
variable precision, using the minimum number of words to represent each
value.

For programs using both FM and IM numbers, FM routines should not be called
with IM numbers, and IM routines should not be called with FM numbers, since
the implied value of NDIG used for an IM number may not match the explicit
NDIG expected by an FM routine.  Use the conversion routines IMFM2I and
IMI2FM to change between the FM and IM formats.

The format for complex FM numbers (called ZM numbers below) is very similar
to that for real FM numbers.  Each ZM array holds two FM numbers to represent
the real and imaginary parts of a complex number.  Each ZM array is twice as
long as a corresponding FM array, with the imaginary part starting at the
midpoint of the array.  As with FM, there are packed and unpacked formats for
the numbers.


3. INPUT/OUTPUT ROUTINES

All versions of the input routines perform free-format conversion from
characters to FM numbers.

a. Conversion to or from a character array

   FMINP converts from a character*1 array to an FM number.

   FMOUT converts an FM number to base 10 and formats it for output as an
         array of type character*1.  The output is left justified in the
         array, and the format is defined by two variables in module FMVALS,
         so that a separate format definition does not have to be provided
         for each output call.

   JFORM1 and JFORM2 define a default output format.

   JFORM1 = 0     E   format       ( .314159M+6 )
          = 1     1PE format       ( 3.14159M+5 )
          = 2     F   format       ( 314159.000 )

   JFORM2 is the number of significant digits to display (if JFORM1 =
          0 or 1).  If JFORM2 = 0 then a default number of digits is chosen.
          The default is roughly the full precision of the number.
   JFORM2 is the number of digits after the decimal point (if JFORM1 = 2).
          See the FMOUT documentation for more details.

b. Conversion to or from a character string

   FMST2M converts from a character string to an FM number.

   FMFORM converts an FM number to a character string according to a format
          provided in each call.  The format description is more like that of
          a Fortran FORMAT statement, and integer or fixed-point output is
          right justified.

c. Direct read or write

   FMPRNT uses FMOUT to print one FM number.

   FMFPRT uses FMFORM to print one FM number.

   FMWRIT writes FM numbers for later input using FMREAD.

   FMREAD reads FM numbers written by FMWRIT.

The values given to JFORM1 and JFORM2 can be used to define a default output
format when FMOUT or FMPRNT are called.  The explicit format used in a call
to FMFORM or FMFPRT overrides the settings of JFORM1 and JFORM2.

KW is the unit number to be used for standard output from the package,
   including error and warning messages, and trace output.

For multiple precision integers, the corresponding routines IMINP, IMOUT,
IMST2M, IMFORM, IMPRNT, IMFPRT, IMWRIT, and IMREAD provide similar input and
output conversions.  For output of IM numbers, JFORM1 and JFORM2 are ignored
and integer format (JFORM1=2, JFORM2=0) is used.

For ZM numbers, the corresponding routines ZMINP, ZMOUT, ZMST2M, ZMFORM,
ZMPRNT, ZMFPRT, ZMWRIT, and ZMREAD provide similar input and output
conversions.

For the output format of ZM numbers, JFORM1 and JFORM2 determine the default
format for the individual parts of a complex number as with FM numbers.

   JFORMZ determines the combined output format of the real and
          imaginary parts.

   JFORMZ = 1  normal setting    :    1.23 - 4.56 i
          = 2  use capital I     :    1.23 - 4.56 I
          = 3  parenthesis format:  ( 1.23 , -4.56 )

   JPRNTZ controls whether to print real and imaginary parts
          on one line whenever possible.

   JPRNTZ = 1  print both parts as a single string :
                   1.23456789M+321 - 9.87654321M-123 i
          = 2  print on separate lines without the 'i' :
                   1.23456789M+321
                  -9.87654321M-123

For further description of these routines, see sections 9 and 10 below.


4. ARITHMETIC TRACING

NTRACE and LVLTRC control trace printout from the package.

NTRACE =  0   No output except warnings and errors.  (Default)
       =  1   The result of each call to one of the routines
                 is printed in base 10, using FMOUT.
       = -1   The result of each call to one of the routines
                 is printed in internal base MBASE format.
       =  2   The input arguments and result of each call to one
                 of the routines is printed in base 10, using FMOUT.
       = -2   The input arguments and result of each call to one
                 of the routines is printed in base MBASE format.

LVLTRC defines the call level to which the trace is done.  LVLTRC = 1
       means only FM routines called directly by the user are traced,
       LVLTRC = 2 also prints traces for FM routines called by other
       FM routines called directly by the user, etc.  Default is 1.

In the above description, internal MBASE format means the number is
printed as it appears in the array --- an exponent followed by NDIG
base MBASE digits.


5. ERROR CONDITIONS

KFLAG is a condition value returned by the package after each call to one of
      the routines.  Negative values indicate conditions for which a warning
      message will be printed unless KWARN = 0.
      Positive values indicate conditions that may be of interest but are not
      errors.  No warning message is printed if KFLAG is nonnegative.

Subroutine FMFLAG is provided to give the user access to the current
condition code.  For example, to set the user's local variable LFLAG
to FM's internal KFLAG value:      CALL FMFLAG(LFLAG)

  KFLAG =  0     Normal operation.

        =  1     One of the operands in FMADD or FMSUB was insignificant with
                     respect to the other, so that the result was equal to
                     the argument of larger magnitude.
        =  2     In converting an FM number to a one word integer in FMM2I,
                     the FM number was not exactly an integer.  The next
                     integer toward zero was returned.

        = -1     NDIG was less than 2 or more than NDIGMX.
        = -2     MBASE was less than 2 or more than MXBASE.
        = -3     An exponent was out of range.
        = -4     Invalid input argument(s) to an FM routine.
                      UNKNOWN was returned.
        = -5     + or - OVERFLOW was generated as a result from an
                      FM routine.
        = -6     + or - UNDERFLOW was generated as a result from an
                      FM routine.
        = -7     The input string (array) to FMINP was not legal.
        = -8     The character array was not large enough in an
                 input or output routine.
        = -9     Precision could not be raised enough to provide all
                      requested guard digits.  Increasing the value
                      of NDIGMX in file FMSAVE.f90 may fix this.
                      UNKNOWN was returned.
        = -10    An FM input argument was too small in magnitude to
                      convert to the machine's single or double
                      precision in FMM2SP or FMM2DP.  Check that the
                      definitions of SPMAX and DPMAX in file FMSAVE.f90
                      are correct for the current machine.
                      Zero was returned.
        = -11    Array MBERN is not dimensioned large enough for the
                      requested number of Bernoulli numbers.
        = -12    Array MJSUMS is not dimensioned large enough for
                      the number of coefficients needed in the
                      reflection formula in FMPGAM.

When a negative KFLAG condition is encountered, the value of KWARN
determines the action to be taken.

KWARN = 0     Execution continues and no message is printed.
      = 1     A warning message is printed and execution continues.
      = 2     A warning message is printed and execution stops.

The default setting is KWARN = 1.

When an overflow or underflow is generated for an operation in which an input
argument was already an overflow or underflow, no additional message is
printed.  When an unknown result is generated and an input argument was
already unknown, no additional message is printed.  In these cases the
negative KFLAG value is still returned.

IM routines handle exceptions like OVERFLOW or UNKNOWN in the same way as FM
routines.  When using IMMPY, the product of two large positive integers will
return +OVERFLOW.  The routines IMMPYM and IMPMOD can be used to obtain a
modular result without overflow.  The largest representable IM integer is
MBASE**NDIGMX - 1.  For example, if MBASE is 10**7 and NDIGMX is set to 256,
integers less than 10**1792 can be used.


6. OTHER OPTIONS

KRAD = 0     All angles in the trigonometric functions and inverse functions
             are measured in degrees.
     = 1     All angles are measured in radians.  (Default)

KROUND = -1  All results are rounded toward minus infinity.
       =  0  All results are rounded toward zero (chopped).
       =  1  All results are rounded to the nearest FM number, or to the
             value with an even last digit if the result is halfway
             between two FM numbers.  (Default)
       =  2  All results are rounded toward plus infinity.

       In all cases, while a function is being computed all intermediate
       results are rounded to nearest, with only the final result being
       rounded according to KROUND.

KRPERF = 0   A smaller number of guard digits used, to give nearly perfect
             rounding.  This number is chosen so that the last intermediate
             result should have error less than 0.001 unit in the last place
             of the final rounded result.  (Default)
       = 1   Causes more guard digits to be used, to get perfect rounding in
             the mode set by KROUND.  This slows execution speed.

       If a small base is used for the arithmetic, like MBASE = 2, 10, or 16,
       FM assumes that the arithmetic hardware for some machine is being
       simulated, so perfect rounding is done without regard for the value
       of KRPERF.
       If KROUND = 1, then KRPERF = 1 means returned results are no more than
       0.500 units in the last place from the exact mathematical result,
       versus 0.501 for KRPERF = 0.
       If KROUND is not 1, then KRPERF = 1 means returned results are no more
       than 1.000 units in the last place from the exact mathematical result,
       versus 1.001 for KRPERF = 0.

KSWIDE defines the maximum screen width to be used for all unit KW output.
       Default is 80.

KESWCH controls the action taken in FMINP and other input routines for
       strings like 'E7' that have no digits before the exponent field.
       This is sometimes a convenient abbreviation when doing interactive
       keyboard input.
       KESWCH = 1 causes 'E7' to translate like '1.0E+7'.  (Default)
       KESWCH = 0 causes 'E7' to translate like '0.0E+7' and give 0.

CMCHAR defines the exponent letter to be used for FM variable output.
       Default is 'M', as in 1.2345M+678.
       Change it to 'E' for output to be read by a non-FM program.

KDEBUG = 0   No error checking is done to see if input arguments are valid
             and parameters like NDIG and MBASE are correct upon entry to
             each routine.  (Default)
       = 1   Some error checking is done.  (Slower speed)

See module FMVALS in file FMSAVE.f90 for additional description of these and
other variables defining various FM conditions.


7. ARRAY DIMENSIONS

The dimensions of the arrays in the FM package are defined using parameters
NDIGMX and NBITS.
NDIGMX is the maximum value the user may set for NDIG.
NBITS  is the number of bits used to represent integers for a given machine.
       See the EFFICIENCY discussion below.

The standard version of FM sets NDIGMX = 55, so on a 32-bit machine using
MBASE = 10**7 the maximum precision is about 7*54+1 = 379 significant
digits.  Previous versions of FM set NDIGMX = 256.  Two reasons for making
this change are:
(a) Almost all applications using FM use only 30 to 50 significant digits
    for checking double or quadruple precision results, and the larger
    arrays are wasted space.
(b) Most FM applications use the derived type interface so that the number
    of changes to existing code is minimized.  Many compilers implement the
    FM interface by doing copy in / copy out argument passing of the derived
    types.  Copying the entire large array when only a small part of it is
    being used causes the derived type arithmetic to be slow compared to
    making direct calls to the subroutines.  Setting NDIGMX to be only
    slightly higher than a program actually uses minimizes any performance
    penalty for the derived type arithmetic.

To change dimensions so that 10,000 significant digit calculation can be
done, NDIGMX needs to be at least  10**4/7 + 5 = 1434.  This allows for a
few user guard digits to be defined when the precision is changed using
CALL FMSET(10000).  Changing 'NDIGMX = 55' to 'NDIGMX = 1434' in FMSAVE.f90
will define all the new array sizes.

If NDIG much greater than 256 is to be used and elementary functions will
be needed, they will be faster if array MJSUMS is larger.  The parameter
defining the size of MJSUMS is set in the standard version by
    LJSUMS = 8*(LUNPCK+2)
The 8 means that up to eight concurrent sums can be used by the elementary
functions.  The approximate number needed for best speed is given by
    0.051*Log(MBASE)*NDIG**0.333 + 1.85
For example, with MBASE=10**7 and NDIG=1434 this gives 11.  Changing
'LJSUMS = 8*(LUNPCK+2)' to 'LJSUMS = 11*(LUNPCK+2)' in FMSAVE.f90 will give
slightly better speed.

FM numbers in packed format have dimension -1:LPACK, and those in unpacked
format have dimension -1:LUNPCK.

The parameters LPACKZ and LUNPKZ define the size of the packed and unpacked
ZM arrays.  The real part starts at the beginning of the array, and the
imaginary part starts at word KPTIMP for packed format or at word KPTIMU for
unpacked format.


8. PORTABILITY

In FMSET several variables are set to machine-dependent values, and many of
the variables initialized in module FMVALS in file FMSAVE.f90 are checked to
see that they have reasonable values.  FMSET will print warning messages on
unit KW for any of the FMVALS variables that seem to be poorly initialized.

If an FM run fails, call FMVARS to get a list of all the FMVALS variables
printed on unit KW.  Setting KDEBUG = 1 at the start may also identify some
errors.

Some compilers object to a function like FMCOMP with side effects such as
changing KFLAG or other module variables.  Blocks of code in FMCOMP and
IMCOMP that modify these variables are identified so they may be removed or
commented out to produce a function without side effects.  This disables
trace printing in FMCOMP and IMCOMP, and error codes are not returned in
KFLAG.  See FMCOMP and IMCOMP for further details.

In FMBER2 and FMPGAM several constants are used that require the machine's
integer word size to be at least 32 bits.


9. LIST OF ROUTINES - Shown after section 11 below.


10. NEW FOR VERSION 1.2

Version 1.2 is written in Fortran-90 free source format.

The routines for the Gamma function and related mathematical special
functions are new in version 1.2.

Several new derived-type function interfaces are included in module FMZM in
file FMZM90.f90, such as integer multiple precision operations GCD, modular
multiplication, and modular powers.  There are also formatting functions and
function interfaces for the Gamma and related special functions.

Two new rounding modes have been added, round toward -infinity and round
toward +infinity.  See the description of KROUND above.
An option has been added to force more guard digits to be used, so that basic
arithmetic operations will always round perfectly.  See the description of
KRPERF above.
These options are included for applications that use FM to check IEEE
hardware arithmetic.  They are not normally useful for most multiple
precision calculations.

The random number routine FM_RANDOM_NUMBER uses 49-digit prime numbers in a
shuffled multiplicative congruential generator.  Historically, some popular
random number routines tried so hard for maximum speed that they were later
found to fail some tests for randomness.  FM_RANDOM_NUMBER tries to return
high-quality random values.  It is much slower than other generators, but can
return about 60,000 numbers per second on a 400 MHz single-processor machine.
This is usually fast enough to be used as a check for suspicious monte carlo
results from other generators.
For more details, see the comments in the routine.

The arrays for multiple precision numbers were dimensioned starting at 0 in
version 1.1, and now begin at -1.  Array(-1) now holds the sign of the number
instead of combining the sign with Array(2) as before.  The reason for moving
the sign bit is that many of the original routines, written before Fortran-90
existed, simplified the logic by temporarily making input arguments positive,
working with positive values, then restoring the signs to the input arguments
upon return.  This became illegal under Fortran-90 when used with the derived
type interface, which demands the inputs to functions for arithmetic operator
overloading be declared with INTENT(IN).

The common blocks of earlier versions have been replaced by module FMVALS.
This makes it easier to hide the FM internal variable names from the calling
program, and these variables can be initialized in the module so the
initializing call to FMSET is no longer mandatory.  Several new routines are
provided to set or return the values for some of these variables.  See the
descriptions for FMSETVAR, FMFLAG, and FMVARS above.

Version 1.0 used integer arrays and integer arithmetic internally to perform
the multiple precision operations.  Later versions use double precision
arithmetic and arrays internally.  This is usually faster at higher
precisions, and on many machines it is also faster at lower precisions.
Version 1.2 is written so that the arithmetic used can easily be changed from
double precision to integer, or any other available arithmetic type.  This
permits the user to make the best use of a given machine's arithmetic
hardware.  See the EFFICIENCY discussion below.


11. EFFICIENCY

When the derived type interface is used to access the FM routines, there may
be a loss of speed if the arrays used to define the multiple precision data
types are larger than necessary.  See comment (b) in the section above on
array dimensions.

To take advantage of hardware architecture on different machines, the package
has been designed so that the arithmetic used to perform the multiple
precision operations can easily be changed.  All variables that must be
changed to get a different arithmetic have names beginning with 'M' and are
declared using REAL (KIND(1.0D0)) ...

For example, to change the package to use integer arithmetic internally, make
these two changes everywhere in the FM.f90 file.
Change  'REAL (KIND(1.0D0))'  to  'INTEGER'.
Change  'AINT ('  to  'INT('.  Note the blank between AINT and (.
On some systems, changing  'AINT ('  to  '('  may give better speed.

In most places in FM, an AINT function is not supposed to be changed.  These
are written 'AINT(', with no embedded blank, so they will not be changed by
the global change above.

The first of these changes must also be made throughout the files FMZM90.f90
and FMSAVE.f90.
Change  'REAL (KIND(1.0D0))'  to  'INTEGER'.

Many of the variables in FMSAVE.f90 are initialized when they are declared,
so the initialization values should be changed to integer values.
Find the lines beginning '! Integer initialization' in file FMSAVE.f90 and
change the values.  The values needed for 32-bit integer arithmetic are next
to the double precision values, but commented out.  In every case, the line
before the '! Integer initialization' should have '!' inserted in column 1
and the line after should have the '!' removed from column 1.  If a different
wordsize is used, the first call to FMSET will check the values defined in
file FMSAVE.f90 and write messages (on unit KW) if any need to be changed.

When changing to a different type of arithmetic, any FM arrays in the user's
program must be changed to agree.  If derived types are used instead of
direct calls, no changes should be needed in the calling program.

For example, in the test program TestFM.f90, change all
'REAL (KIND(1.0D0))'  to  'INTEGER', as with the other files.

This version of FM restricts the base used to be also representable in
integer variables, so using precision above double usually does not save much
time unless integers can also be declared at a higher precision.  Using IEEE
Extended would allow a base of around 10**9 to be chosen, but the delayed
digit-normalization method used for multiplication and division means that a
slightly smaller base like 10**8 would probably run faster.  This would
usually not be much faster than using the usual base 10**7 with double
precision.

The value of NBITS defined as a parameter in FMVALS refers to the number of
bits used to represent integers in an M-variable word.  Typical values for
NBITS are:  24 for IEEE single precision, 32 for integer, 53 for IEEE double
precision.  NBITS controls only array size, so setting it too high is ok, but
then the program will use slightly more memory than necessary.

For cases where special compiler directives or minor re-writing of the code
may improve speed, several of the most important loops in FM are identified
by comments containing the string '(Inner Loop)'.



--------------------------------------------------------------------------------
---------------   Routines for Real Floating-Point Operations   ----------------



These are the FM routines that are designed to be called by the user.
All are subroutines except logical function FMCOMP.
MA, MB, MC refer to FM format numbers.

In Fortran-90 and later versions of the Fortran standard, it is potentially
unsafe to use the same array more than once in the calling sequence.  The
operation MA = MA + MB should not be written as
      CALL FMADD(MA,MB,MA)
since the compiler is allowed to pass the three arguments with a copy in /
copy out mechanism.  This means the third argument, containing the result,
might not be copied out last, and then a later copy out of the original
input MA could destroy the computed result.

One solution is to use a third array and then put the result back in MA:
      CALL FMADD(MA,MB,MC)
      CALL FMEQ(MC,MA)

When the first call is doing one of the "fast" operations like addition,
the extra call to move the result back to MA can cause a noticeable loss
in efficiency.  To avoid this, separate routines are provided for the basic
arithmetic operations when the result is to be returned in the same array
as one of the inputs.

A routine name with a suffix of  "_R1" returns the result in the first input
array, and a suffix of "_R2" returns the result in the second input array.
The example above would then be:
      CALL FMADD_R1(MA,MB)

These routines each have one less argument than the original version, since
the output is re-directed to one of the inputs.  The result array should not
be the same as any input array when the original version of the routine is
used.

The routines that can be used this way are listed below.  For others, like
      CALL FMEXP(MA,MA)
the relative cost of doing an extra copy is small.  This one should become
      CALL FMEXP(MA,MB)
      CALL FMEQ(MB,MA)

If the derived-type interface is used, as in
      TYPE (FM) A,B
      ...
      A = A + B
there is no problem putting the result back into A, since the interface routine
creates a temporary scratch array for the result of A + B, allowing copy in /
copy out to work.

For each of these routines there is also a version available for which the
argument list is the same but all FM numbers are in packed format.  The
routines using packed numbers have the same names except 'FM' is replaced by
'FP' at the start of each name.


FMABS(MA,MB)         MB = ABS(MA)

FMACOS(MA,MB)        MB = ACOS(MA)

FMADD(MA,MB,MC)      MC = MA + MB

FMADD_R1(MA,MB)      MA = MA + MB

FMADD_R2(MA,MB)      MB = MA + MB

FMADDI(MA,IVAL)      MA = MA + IVAL   Increment an FM number by a one word
                                      integer.  Note this call does not have
                                      an "MB" result like FMDIVI and FMMPYI.

FMASIN(MA,MB)        MB = ASIN(MA)

FMATAN(MA,MB)        MB = ATAN(MA)

FMATN2(MA,MB,MC)     MC = ATAN2(MA,MB)

FMBIG(MA)            MA = Biggest FM number less than overflow.

FMCHSH(MA,MB,MC)     MB = COSH(MA),  MC = SINH(MA).
                          Faster than making two separate calls.

FMCOMP(MA,LREL,MB)        Logical comparison of MA and MB.
                          LREL is a CHARACTER*2 value identifying
                          which of the six comparisons is to be made.
                          Example:  IF (FMCOMP(MA,'GE',MB)) ...
                          Also can be:  IF (FMCOMP(MA,'>=',MB)) ...
                          CHARACTER*1 is ok:  IF (FMCOMP(MA,'>',MB)) ...

FMCONS                    Set several saved constants that depend on MBASE,
                          the base being used.  FMCONS should be called
                          immediately after changing MBASE.

FMCOS(MA,MB)         MB = COS(MA)

FMCOSH(MA,MB)        MB = COSH(MA)

FMCSSN(MA,MB,MC)     MB = COS(MA),  MC = SIN(MA).
                          Faster than making two separate calls.

FMDIG(NSTACK,KST)         Find a set of precisions to use during Newton
                          iteration for finding a simple root starting with
                          about double precision accuracy.

FMDIM(MA,MB,MC)      MC = DIM(MA,MB)

FMDIV(MA,MB,MC)      MC = MA / MB

FMDIV_R1(MA,MB)      MA = MA / MB

FMDIV_R2(MA,MB)      MB = MA / MB

FMDIVI(MA,IVAL,MB)   MB = MA/IVAL   IVAL is a one word integer.

FMDIVI_R1(MA,IVAL)   MA = MA/IVAL

FMDP2M(X,MA)         MA = X    Convert from double precision to FM.

FMDPM(X,MA)          MA = X    Convert from double precision to FM.
                               Faster than FMDP2M, but MA agrees with X only
                               to D.P. accuracy.  See the comments in the
                               two routines.

FMEQ(MA,MB)          MB = MA   Both have precision NDIG.
                               This is the version to use for standard
                               B = A  statements.

FMEQU(MA,MB,NA,NB)   MB = MA   Version for changing precision.
                               MA has NA digits (i.e., MA was computed
                               using NDIG = NA), and MB will be defined
                               having NB digits.
                               MB is rounded if NB < NA
                               MB is zero-padded if NB > NA

FMEXP(MA,MB)         MB = EXP(MA)

FMFLAG(K)            K = KFLAG  get the value of the FM condition
                                flag -- stored in the internal FM
                                variable KFLAG in module FMVALS.

FMFORM(FORM,MA,STRING)    MA is converted to a character string using format
                             FORM and returned in STRING.  FORM can represent
                             I, F, E, or 1PE formats.  Example:
                             CALL FMFORM('F60.40',MA,STRING)

FMFPRT(FORM,MA)           Print MA on unit KW using FORM format.

FMI2M(IVAL,MA)       MA = IVAL   Convert from one word integer to FM.

FMINP(LINE,MA,LA,LB) MA = LINE   Input conversion.
                                 Convert LINE(LA) through LINE(LB)
                                 from characters to FM.

FMINT(MA,MB)         MB = INT(MA)    Integer part of MA.

FMIPWR(MA,IVAL,MB)   MB = MA**IVAL   Raise an FM number to a one word
                                     integer power.

FMLG10(MA,MB)        MB = LOG10(MA)

FMLN(MA,MB)          MB = LOG(MA)

FMLNI(IVAL,MA)       MA = LOG(IVAL)   Natural log of a one word integer.

FMM2DP(MA,X)         X  = MA     Convert from FM to double precision.

FMM2I(MA,IVAL)       IVAL = MA   Convert from FM to integer.

FMM2SP(MA,X)         X  = MA     Convert from FM to single precision.

FMMAX(MA,MB,MC)      MC = MAX(MA,MB)

FMMIN(MA,MB,MC)      MC = MIN(MA,MB)

FMMOD(MA,MB,MC)      MC = MA mod MB

FMMPY(MA,MB,MC)      MC = MA * MB

FMMPY_R1(MA,MB)      MA = MA * MB

FMMPY_R2(MA,MB)      MB = MA * MB

FMMPYI(MA,IVAL,MB)   MB = MA*IVAL    Multiply by a one word integer.

FMMPYI_R1(MA,IVAL)   MA = MA*IVAL

FMNINT(MA,MB)        MB = NINT(MA)   Nearest FM integer.

FMOUT(MA,LINE,LB)    LINE = MA   Convert from FM to character.
                                 LINE is a character array of length LB.

FMPI(MA)             MA = pi

FMPRNT(MA)                Print MA on unit KW using current format.

FMPWR(MA,MB,MC)      MC = MA**MB

FM_RANDOM_NUMBER(X)  X    is returned as a double precision random number,
                          uniform on (0,1).  High-quality, long-period
                          generator.
                          Note that X is double precision, unlike the similar
                          Fortran intrinsic random number routine, which
                          returns a single-precision result.
                          See the comments in section 10 below and also those
                          in the routine for more details.

FMREAD(KREAD,MA)     MA   is returned after reading one (possibly multi-line)
                          FM number on unit KREAD.  This routine reads
                          numbers written by FMWRIT.

FMRPWR(MA,K,J,MB)    MB = MA**(K/J)  Rational power.
                          Faster than FMPWR for functions like the cube root.

FMSET(NPREC)              Set the internal FM variables so that the precision
                          is at least NPREC base 10 digits plus three base 10
                          guard digits.

FMSETVAR(STRING)          Define a new value for one of the internal FM
                          variables in module FMVALS that controls one of the
                          FM options.  STRING has the form  variable = value.
                          Example:  To change the screen width for FM output:
                                CALL FMSETVAR(' KSWIDE = 120 ')
                          The variables that can be changed and the options
                          they control are listed in sections 2 through 6
                          above.  Only one variable can be set per call.
                          The variable name in STRING must have no embedded
                          blanks.  The value part of STRING can be in any
                          numerical format, except in the case of variable
                          CMCHAR, which is character type.  To set CMCHAR to
                          'E', don't use any quotes in STRING:
                                CALL FMSETVAR(' CMCHAR = E ')

FMSIGN(MA,MB,MC)     MC = SIGN(MA,MB)   Sign transfer.

FMSIN(MA,MB)         MB = SIN(MA)

FMSINH(MA,MB)        MB = SINH(MA)

FMSP2M(X,MA)         MA = X   Convert from single precision to FM.

FMSQR(MA,MB)         MB = MA * MA   Faster than FMMPY.

FMSQR_R1(MA)         MA = MA * MA

FMSQRT(MA,MB)        MB = SQRT(MA)

FMSQRT_R1(MA)        MA = SQRT(MA)

FMST2M(STRING,MA)    MA = STRING
                          Convert from character string to FM.
                          STRING may be in any numerical format.
                          Often more convenient than FMINP, which converts
                          an array of CHARACTER*1 values.  Example:
                                CALL FMST2M('123.4',MA)

FMSUB(MA,MB,MC)      MC = MA - MB

FMSUB_R1(MA,MB)      MA = MA - MB

FMSUB_R2(MA,MB)      MB = MA - MB

FMTAN(MA,MB)         MB = TAN(MA)

FMTANH(MA,MB)        MB = TANH(MA)

FMULP(MA,MB)         MB = One Unit in the Last Place of MA.

FMVARS                    Write the current values of the internal FM
                          variables on unit KW.

FMWRIT(KWRITE,MA)         Write MA on unit KWRITE.
                          Multi-line numbers will have '&' as the last
                          nonblank character on all but the last line.  These
                          numbers can then be read easily using FMREAD.



These are the Gamma and Related Functions.

FMBERN(N,MA,MB)      MB = MA*B(N)  Multiply by Nth Bernoulli number

FMBETA(MA,MB,MC)     MC = Beta(MA,MB)

FMCOMB(MA,MB,MC)     MC = Combination MA choose MB  (Binomial coeff.)

FMEULR(MA)           MA = Euler's constant ( 0.5772156649... )

FMFACT(MA,MB)        MB = MA Factorial  (Gamma(MA+1))

FMGAM(MA,MB)         MB = Gamma(MA)

FMIBTA(MX,MA,MB,MC)  MC = Incomplete Beta(MX,MA,MB)

FMIGM1(MA,MB,MC)     MC = Incomplete Gamma(MA,MB).  Lower case Gamma(a,x)

FMIGM2(MA,MB,MC)     MC = Incomplete Gamma(MA,MB).  Upper case Gamma(a,x)

FMLNGM(MA,MB)        MB = Ln(Gamma(MA))

FMPGAM(N,MA,MB)      MB = Polygamma(N,MA)  (Nth derivative of Psi)

FMPOCH(MA,N,MB)      MB = MA*(MA+1)*(MA+2)*...*(MA+N-1)  (Pochhammer)

FMPSI(MA,MB)         MB = Psi(MA)      (Derivative of Ln(Gamma(MA))




--------------------------------------------------------------------------------
---------------------   Routines for Integer Operations   ----------------------



These are the integer routines that are designed to be called by the user.
All are subroutines except logical function IMCOMP.  MA, MB, MC refer to IM
format numbers.  In each case the version of the routine to handle packed IM
numbers has the same name, with 'IM' replaced by 'IP'.

IMABS(MA,MB)         MB = ABS(MA)

IMADD(MA,MB,MC)      MC = MA + MB

IMBIG(MA)            MA = Biggest IM number less than overflow.

IMCOMP(MA,LREL,MB)        Logical comparison of MA and MB.
                          LREL is a CHARACTER*2 value identifying which of
                          the six comparisons is to be made.
                          Example:  IF (IMCOMP(MA,'GE',MB)) ...
                          Also can be:  IF (IMCOMP(MA,'>=',MB))
                          CHARACTER*1 is ok:  IF (IMCOMP(MA,'>',MB)) ...

IMDIM(MA,MB,MC)      MC = DIM(MA,MB)

IMDIV(MA,MB,MC)      MC = int(MA/MB)
                          Use IMDIVR if the remainder is also needed.

IMDIVI(MA,IVAL,MB)   MB = int(MA/IVAL)
                          IVAL is a one word integer.
                          Use IMDVIR to get the remainder also.

IMDIVR(MA,MB,MC,MD)  MC = int(MA/MB),   MD = MA mod MB
                          When both the quotient and remainder are needed,
                          this routine is twice as fast as calling both
                          IMDIV and IMMOD.

IMDVIR(MA,IVAL,MB,IREM)   MB = int(MA/IVAL),   IREM = MA mod IVAL
                          IVAL and IREM are one word integers.

IMEQ(MA,MB)          MB = MA

IMFM2I(MAFM,MB)      MB = MAFM  Convert from real (FM) format to
                                integer (IM) format.

IMFORM(FORM,MA,STRING)    MA is converted to a character string using format
                             FORM and returned in STRING.  FORM can represent
                             I, F, E, or 1PE formats.  Example:
                             CALL IMFORM('I70',MA,STRING)

IMFPRT(FORM,MA)           Print MA on unit KW using FORM format.

IMGCD(MA,MB,MC)      MC = greatest common divisor of MA and MB.

IMI2FM(MA,MBFM)      MBFM = MA  Convert from integer (IM) format to
                                real (FM) format.

IMI2M(IVAL,MA)       MA = IVAL   Convert from one word integer to IM.

IMINP(LINE,MA,LA,LB) MA = LINE   Input conversion.
                                 Convert LINE(LA) through LINE(LB)
                                 from characters to IM.

IMM2DP(MA,X)         X  = MA     Convert from IM to double precision.

IMM2I(MA,IVAL)       IVAL = MA   Convert from IM to one word integer.

IMMAX(MA,MB,MC)      MC = MAX(MA,MB)

IMMIN(MA,MB,MC)      MC = MIN(MA,MB)

IMMOD(MA,MB,MC)      MC = MA mod MB

IMMPY(MA,MB,MC)      MC = MA*MB

IMMPYI(MA,IVAL,MB)   MB = MA*IVAL    Multiply by a one word integer.

IMMPYM(MA,MB,MC,MD)  MD = MA*MB mod MC
                          Slightly faster than calling IMMPY and IMMOD
                          separately, and it works for cases where IMMPY
                          would return OVERFLOW.

IMOUT(MA,LINE,LB)    LINE = MA   Convert from IM to character.
                                 LINE is a character array of length LB.

IMPMOD(MA,MB,MC,MD)  MD = MA**MB mod MC

IMPRNT(MA)                Print MA on unit KW.

IMPWR(MA,MB,MC)      MC = MA**MB

IMREAD(KREAD,MA)     MA   is returned after reading one (possibly multi-line)
                          IM number on unit KREAD.
                          This routine reads numbers written by IMWRIT.

IMSIGN(MA,MB,MC)     MC = SIGN(MA,MB)   Sign transfer.

IMSQR(MA,MB)         MB = MA*MA   Faster than IMMPY.

IMST2M(STRING,MA)    MA = STRING
                          Convert from character string to IM.
                          Often more convenient than IMINP, which converts an
                          array of CHARACTER*1 values.  Example:
                               CALL IMST2M('12345678901',MA)

IMSUB(MA,MB,MC)      MC = MA - MB

IMWRIT(KWRITE,MA)         Write MA on unit KWRITE.
                          Multi-line numbers will have '&' as the last nonblank
                          character on all but the last line.
                          These numbers can then be read easily using IMREAD.




--------------------------------------------------------------------------------
--------------   Routines for Complex Floating-Point Operations   --------------



These are the complex routines that are designed to be called by the user.
All are subroutines, and in each case the version of the routine to handle
packed ZM numbers has the same name, with 'ZM' replaced by 'ZP'.

MA, MB, MC refer to ZM format complex numbers.
MAFM, MBFM, MCFM refer to FM format real numbers.
INTEG is a Fortran INTEGER variable.
ZVAL is a Fortran COMPLEX variable.

ZMABS(MA,MBFM)       MBFM = ABS(MA)    Result is real.

ZMACOS(MA,MB)        MB = ACOS(MA)

ZMADD(MA,MB,MC)      MC = MA + MB

ZMADDI(MA,INTEG)     MA = MA + INTEG  Increment an ZM number by a one word
                                      integer.  Note this call does not have
                                      an "MB" result like ZMDIVI and ZMMPYI.

ZMARG(MA,MBFM)       MBFM = Argument(MA)    Result is real.

ZMASIN(MA,MB)        MB = ASIN(MA)

ZMATAN(MA,MB)        MB = ATAN(MA)

ZMCHSH(MA,MB,MC)     MB = COSH(MA),  MC = SINH(MA).
                          Faster than 2 calls.

ZMCMPX(MAFM,MBFM,MC) MC = CMPLX(MAFM,MBFM)

ZMCONJ(MA,MB)        MB = CONJG(MA)

ZMCOS(MA,MB)         MB = COS(MA)

ZMCOSH(MA,MB)        MB = COSH(MA)

ZMCSSN(MA,MB,MC)     MB = COS(MA),  MC = SIN(MA).
                          Faster than 2 calls.

ZMDIV(MA,MB,MC)      MC = MA / MB

ZMDIVI(MA,INTEG,MB)  MB = MA / INTEG

ZMEQ(MA,MB)          MB = MA

ZMEQU(MA,MB,NDA,NDB) MB = MA    Version for changing precision.
                                (NDA and NDB are as in FMEQU)

ZMEXP(MA,MB)         MB = EXP(MA)

ZMFORM(FORM1,FORM2,MA,STRING)   STRING = MA
                     MA is converted to a character string using format
                     FORM1 for the real part and FORM2 for the imaginary
                     part.  The  result is returned in STRING.  FORM1 and
                     FORM2 can represent I, F, E, or 1PE formats.  Example:
                           CALL ZMFORM('F20.10','F15.10',MA,STRING)
                     A 1PE in the first format does not carry over to the
                     other format descriptor, as it would in an ordinary
                     FORMAT statement.

ZMFPRT(FORM1,FORM2,MA)    Print MA on unit KW using formats FORM1 and FORM2.

ZMI2M(INTEG,MA)           MA = CMPLX(INTEG,0)

ZM2I2M(INTEG1,INTEG2,MA)  MA = CMPLX(INTEG1,INTEG2)

ZMIMAG(MA,MBFM)           MBFM = IMAG(MA)    Imaginary part.

ZMINP(LINE,MA,LA,LB)      MA = LINE   Input conversion.
                               Convert LINE(LA) through LINE(LB) from
                               characters to ZM.  LINE is a character array
                               of length at least LB.

ZMINT(MA,MB)         MB = INT(MA)        Integer part of both Real
                                         and Imaginary parts of MA.

ZMIPWR(MA,INTEG,MB)  MB = MA ** INTEG    Integer power function.

ZMLG10(MA,MB)        MB = LOG10(MA)

ZMLN(MA,MB)          MB = LOG(MA)

ZMM2I(MA,INTEG)      INTEG = INT(REAL(MA))

ZMM2Z(MA,ZVAL)       ZVAL = MA

ZMMPY(MA,MB,MC)      MC = MA * MB

ZMMPYI(MA,INTEG,MB)  MB = MA * INTEG

ZMNINT(MA,MB)        MB = NINT(MA)   Nearest integer of both Real
                                     and Imaginary.

ZMOUT(MA,LINE,LB,LAST1,LAST2)        LINE = MA
                     Convert from FM to character.
                     LINE  is the returned character*1 array.
                     LB    is the dimensioned size of LINE.
                     LAST1 is returned as the position in LINE of
                           the last character of REAL(MA).
                     LAST2 is returned as the position in LINE
                           of the last character of AIMAG(MA).

ZMPRNT(MA)           Print MA on unit KW using current format.

ZMPWR(MA,MB,MC)      MC = MA ** MB

ZMREAD(KREAD,MA)     MA   is returned after reading one (possibly multi-line)
                          ZM number on unit KREAD.
                          This routine reads numbers written by ZMWRIT.

ZMREAL(MA,MBFM)      MBFM = REAL(MA)    Real part.

ZMRPWR(MA,IVAL,JVAL,MB)     MB = MA ** (IVAL/JVAL)

ZMSET(NPREC)         Set precision to the equivalent of a few more than NPREC
                     base 10 digits.  This is now the same as FMSET, but is
                     retained for compatibility with earlier versions of the
                     package.

ZMSIN(MA,MB)         MB = SIN(MA)

ZMSINH(MA,MB)        MB = SINH(MA)

ZMSQR(MA,MB)         MB = MA*MA    Faster than ZMMPY.

ZMSQRT(MA,MB)        MB = SQRT(MA)

ZMST2M(STRING,MA)    MA = STRING
                          Convert from character string to ZM.
                          Often more convenient than ZMINP, which
                          converts an array of CHARACTER*1 values.
                          Example: CALL ZMST2M('123.4+5.67i',MA).

ZMSUB(MA,MB,MC)      MC = MA - MB

ZMTAN(MA,MB)         MB = TAN(MA)

ZMTANH(MA,MB)        MB = TANH(MA)

ZMWRIT(KWRITE,MA)    Write MA on unit KWRITE.  Multi-line numbers are
                     formatted for automatic reading with ZMREAD.

ZMZ2M(ZVAL,MA)       MA = ZVAL



================================================================================
================================================================================
SHAR_EOF
fi # end of overwriting check
cd ..
if test ! -d 'Fortran90'
then
	mkdir 'Fortran90'
fi
cd 'Fortran90'
if test ! -d 'Sp'
then
	mkdir 'Sp'
fi
cd 'Sp'
if test ! -d 'Drivers'
then
	mkdir 'Drivers'
fi
cd 'Drivers'
if test -f 'SAMPLE.CHK'
then
	echo shar: will not over-write existing file "'SAMPLE.CHK'"
else
cat << "SHAR_EOF" > 'SAMPLE.CHK'


 Sample 1.  Real root of f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.


 Iteration       Newton Approximation

         0       3.120000000000000000000000000000000000000000000000000000000000

         1       3.120656718532108533919391265947916793506741449899073468862023

         2       3.120656215327022122238354686569835883519704471397219749798884

         3       3.120656215326726500470956115551705969611230193197937042123082

         4       3.120656215326726500470956013523797484654623935599078168006617

         5       3.120656215326726500470956013523797484654623935599066014988828

         6       3.120656215326726500470956013523797484654623935599066014988828



 Sample 2.  Find the root above to 300 decimal places.

       3.12065621532672650047095601352379748465462393559906601498882843581902649995179546
      89783257450017151095811923431332682839420040840535954560118152245371792881305271951
      01711893889821240366205830730398354737691328200011005827350420283867070989561927541
      348452154928259189115694520078941581838752951201099960



 Sample 3.          109 terms were added in the Zeta sum

 Zeta(3) = 1.202056903159594285399738161511449990764986292340498881792272



 Sample 4.           57 values were checked before finding a prime p.

 p =  5468317884572019103692012212053793153845065543480825746529998049913561



 Sample 5.  Check that Gamma(1/2) = Sqrt(pi)

 Gamma(1/2) = 1.772453850905516027298167483341145182797549456122387128213808



 Sample 6.  Psi and Polygamma functions.

 Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) = 
             .013499486145413024755107829105035147950644978635837270816327



 Sample 7.  Incomplete gamma and Gamma functions.

 Probability =  .19373313011487144632751025918250599953472318607121386973066



 Sample 8.  Complex root of f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.


 Iteration       Newton Approximation

     0     .560000000000000000000000000000 + 1.060000000000000000000000000000 i

     1     .561964780980333719745880263787 + 1.061135231152741154895778904059 i

     2     .561958308372772219534516409947 + 1.061134679566247415769456345141 i

     3     .561958308335403235495113920123 + 1.061134679604332556981397796290 i

     4     .561958308335403235498111195347 + 1.061134679604332556983391239059 i

     5     .561958308335403235498111195347 + 1.061134679604332556983391239059 i



 Sample 9.           44 terms were added to get Exp(1.23-2.34i)

 Result= -2.379681796854777515745457977697 - 2.458032970832342652397461908326 i



 Sample 10.  Exception handling.

             Iterate Exp(x) starting at 1.0 until overflow occurs.


 Iteration  1      2.718281828459045235360287471352662497757M+0

 Iteration  2      1.515426224147926418976043027262991190553M+1

 Iteration  3      3.814279104760220592209219594098203571024M+6

 Iteration  4      2.331504399007195462289689911012137666332M+1656520

 Iteration  5      + OVERFLOW

 Overflow was correctly detected.


 All results were ok.
SHAR_EOF
fi # end of overwriting check
if test -f 'SampleFM.f90'
then
	echo shar: will not over-write existing file "'SampleFM.f90'"
else
cat << "SHAR_EOF" > 'SampleFM.f90'
      PROGRAM SAMPLE

!                             David M. Smith

!    This is a sample program using the FM Fortran-90 modules for
!    doing arithmetic using the FM, IM, and ZM derived types.

!    The output is saved in file SAMPLE.LOG.  A comparison file,
!    SAMPLE.CHK, is provided showing the expected output from 32-bit
!    (IEEE arithmetic) machines.  When run on other computers, all the
!    numerical results should still be the same, but the number of terms
!    needed for some of the results might be slightly different.  The
!    program checks all the results and the last line of the log file
!    should be "All results were ok."

!    In a few places, an explicit call is made to an FM or ZM routine.
!    For a call like CALL FM_FORM('F65.60',MAFM,ST1), note that the
!    "FM_" form is used since MAFM is a TYPE (FM) variable and not just
!    an array.  See the discussion in FMZM90.f.


      USE FMZM

      IMPLICIT NONE

      TYPE ( FM ) MAFM,MBFM,MCFM,MDFM
      TYPE ( IM ) MAIM,MBIM,MCIM
      TYPE ( ZM ) MAZM,MBZM,MCZM,MDZM

      CHARACTER(80)  :: ST1
      CHARACTER(175) :: FMT
      INTEGER ITER,J,K,KLOG,LFLAG,NERROR
      INTEGER SEED(7)
      DOUBLE PRECISION VALUE

!             Write output to the screen (unit *), and also to the
!             file SAMPLE.LOG.

      KLOG = 18
      OPEN (KLOG,FILE='SAMPLE.LOG')

      NERROR = 0


!             1.  Find a root of the equation
!                 f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.

!                 Set precision to give at least 60 significant digits.

      CALL FM_SET(60)

!                 Use Newton's method with initial guess x = 3.12.
!                 This version is not tuned for speed.  See the FMSQRT
!                 routine for possible ways to increase speed.
!                 Horner's rule is used to evaluate the function.

!                 MAFM is the previous iterate.
!                 MBFM is the current iterate.

!                 TO_FM is a function for converting other types of numbers
!                 to type FM.  Note that TO_FM(3.12) converts the REAL
!                 constant to FM, but it is accurate only to single
!                 precision.  TO_FM(3.12D0) agrees with 3.12 to double
!                 precision accuracy, and TO_FM('3.12') or
!                 TO_FM(312)/TO_FM(100) agrees to full FM accuracy.
!                 Here, TO_FM(3.12) would be ok, since Newton iteration
!                 will correct the error coming from single precision,
!                 but it is a good habit to use the more accurate form.

      MAFM = TO_FM('3.12')

!                 Print the first iteration.

      FMT = "(//' Sample 1.  Real root of f(x) = x**5 - 3x**4 + ',"// &
            "'x**3 - 4x**2 + x - 6 = 0.'///"                       // &
            "' Iteration       Newton Approximation')"
      WRITE (*,FMT)
      WRITE (KLOG,FMT)

!                 FM_FORMAT is a formatting function that returns a
!                 character string (of length 200).
!                 Avoid using FM_FORMAT in the write list, since this
!                 function itself does internal WRITE operations, and
!                 some compilers object to recursive WRITE references.

      ST1 = FM_FORMAT('F65.60',MAFM)
      WRITE (*   ,"(/I10,4X,A)") 0,TRIM(ST1)
      WRITE (KLOG,"(/I10,4X,A)") 0,TRIM(ST1)

      DO ITER = 1, 10

!                 MCFM is f(MAFM).

         MCFM = ((((MAFM-3)*MAFM+1)*MAFM-4)*MAFM+1)*MAFM-6

!                 MDFM is f'(MAFM).

         MDFM = (((5*MAFM-12)*MAFM+3)*MAFM-8)*MAFM+1

         MBFM = MAFM - MCFM/MDFM

!                 Print each iteration.

!                 FM_FORM is a formatting subroutine.  FM_FORM can
!                 handle output strings longer that 200 characters.

         CALL FM_FORM('F65.60',MBFM,ST1)
         WRITE (*   ,"(/I10,4X,A)") ITER,TRIM(ST1)
         WRITE (KLOG,"(/I10,4X,A)") ITER,TRIM(ST1)

!                 Stop iterating if MAFM and MBFM agree to over 60 places.

         MDFM = ABS(MAFM-MBFM)
         IF (MDFM < 1.0D-61) EXIT

!                 Set MAFM = MBFM for the next iteration.

         MAFM = MBFM
      ENDDO

!                 Check the answer.

      MCFM = TO_FM('3.120656215326726500470956013523797484654623'// &
                   '9355990660149888284358')

!                 It is slightly safer to do this test with .NOT. instead of
!                       IF (ABS(MCFM-MBFM) >= 1.0D-61) THEN
!                 because if the result of ABS(MCFM-MBFM) is FM's UNKNOWN value,
!                 the comparison returns false for all comparisons.

      IF (.NOT.(ABS(MCFM-MBFM) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 1.'/)")
          WRITE (KLOG,"(/' Error in sample case number 1.'/)")
      ENDIF


!             2.  Higher Precision.  Compute the root above to 300 decimal places.

      CALL FM_SET(300)

!                 It is tempting to just say MAFM = MCFM here to initialize the
!                 start of the higher precision iterations to be the check value
!                 defined above.  That will not work, because precision has
!                 changed.  Most of the digits of MCFM may be undefined at the
!                 new precision.
!                 The usual way to pad a lower precision value with zeros when
!                 raising precision is to use subroutine FM_EQU, but here it is
!                 easier to define MAFM from scratch at the new precision.

      MAFM = TO_FM('3.120656215326726500470956013523797484654623'// &
                   '9355990660149888284358')

      DO ITER = 1, 10

!                 MCFM is f(MAFM).

         MCFM = ((((MAFM-3)*MAFM+1)*MAFM-4)*MAFM+1)*MAFM-6

!                 MDFM is f'(MAFM).

         MDFM = (((5*MAFM-12)*MAFM+3)*MAFM-8)*MAFM+1

         MBFM = MAFM - MCFM/MDFM

!                 Stop iterating if MAFM and MBFM agree to over 300 places.

         MDFM = ABS(MAFM-MBFM)
         IF (MDFM < TO_FM('1.0E-301')) EXIT

!                 Set MAFM = MBFM for the next iteration.

         MAFM = MBFM
      ENDDO

!                 For very high precision output, it is sometimes more
!                 convenient to use FM_PRNT to format and print the numbers,
!                 since the line breaks are handled automatically.
!                 The unit number for the output, KW, and the format codes
!                 to be used, JFORM1 and JFORM2, are internal FM variables.
!                 Subroutine FMSETVAR is used to re-define these, and the
!                 new values will remain in effect for any further calls
!                 to FM_PRNT.

!                 Other variables that can be changed and the  options they
!                 control are listed in the documentation at the top of file
!                 FM.f.

!                 Set the format to F305.300

      CALL FMSETVAR(' JFORM1 = 2 ')
      CALL FMSETVAR(' JFORM2 = 300 ')

!                 Set the output screen width to 90 columns.

      CALL FMSETVAR(' KSWIDE = 90 ')

      WRITE (*   ,"(///' Sample 2.  Find the root above to 300 decimal places.'/)")
      WRITE (KLOG,"(///' Sample 2.  Find the root above to 300 decimal places.'/)")

!                 Write to the log file.

      CALL FMSETVAR(' KW = 18 ')
      CALL FM_PRNT(MBFM)

!                 Write to the screen (unit 6).

      CALL FMSETVAR(' KW = 6 ')
      CALL FM_PRNT(MBFM)

!                 Check the answer.

      MCFM = TO_FM('3.12065621532672650047095601352379748465462393559906601'// &
                   '4988828435819026499951795468978325745001715109581192343'// &
                   '1332682839420040840535954560118152245371792881305271951'// &
                   '0171189388982124036620583073039835473769132820001100582'// &
                   '7350420283867070989561927541348452154928259189115694520'// &
                   '0789415818387529512010999602155131321076797099026664236')

      IF (.NOT.(ABS(MCFM-MBFM) < TO_FM('1.0E-301'))) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 2.'/)")
          WRITE (KLOG,"(/' Error in sample case number 2.'/)")
      ENDIF


!             3.  Compute the Riemann Zeta function for s=3.

!                 Use Gosper's formula:  Zeta(3) =
!                 (5/4)*Sum[ (-1)**k * (k!)**2 / ((k+1)**2 * (2k+1)!) ]
!                 while k = 0, 1, ....

!                 MAFM is the current partial sum.
!                 MBFM is the current term.
!                 MCFM is k!
!                 MDFM is (2k+1)!

      CALL FM_SET(60)
      MAFM = 1
      MCFM = 1
      MDFM = 1
      DO K = 1, 200
         MCFM = K*MCFM
         J = 2*K*(2*K+1)
         MDFM = J*MDFM
         MBFM = MCFM**2
         J = (K+1)*(K+1)
         MBFM = (MBFM/J)/MDFM
         IF (MOD(K,2) == 0) THEN
             MAFM = MAFM + MBFM
         ELSE
             MAFM = MAFM - MBFM
         ENDIF

!                 Test for convergence.

         IF (MAFM-MBFM == MAFM) THEN
             WRITE (*   ,  &
             "(///' Sample 3.',8X,I5,' terms were added in the Zeta sum'/)") K
             WRITE (KLOG,  &
             "(///' Sample 3.',8X,I5,' terms were added in the Zeta sum'/)") K
             EXIT
         ENDIF
      ENDDO

!                 Print the result.

      MAFM = (5*MAFM)/4
      CALL FM_FORM('F62.60',MAFM,ST1)
      WRITE (*   ,"(' Zeta(3) = ',A)") TRIM(ST1)
      WRITE (KLOG,"(' Zeta(3) = ',A)") TRIM(ST1)

!                 Check the answer.

      MCFM = TO_FM('1.20205690315959428539973816151144999076498'// &
                   '6292340498881792271555')
      IF (.NOT.(ABS(MAFM-MCFM) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 3.'/)")
          WRITE (KLOG,"(/' Error in sample case number 3.'/)")
      ENDIF


!             4.  Integer multiple precision calculations.

!                 Fermat's theorem says  x**(p-1) mod p = 1
!                 when p is prime and x is not a multiple of p.
!                 If  x**(p-1) mod p  gives 1 for some p with
!                 several different x's, then it is very likely
!                 that p is prime (but it is not certain until
!                 further tests are done).

!                 Find a 70-digit number p that is "probably" prime.

!                 Use FM_RANDOM_NUMBER to generate a random 70-digit
!                 starting value and search for a prime from that point.
!                 Initialize the generator.
!                 Note that VALUE is double precision, unlike the similar
!                 Fortran intrinsic random number routine, which returns
!                 a single-precision result.

      CALL FM_SET(80)
      SEED = (/ 2718281,8284590,4523536,0287471,3526624,9775724,7093699 /)
      CALL FM_RANDOM_SEED(PUT=SEED)

!                 MAIM is the value p being tested.

      MAIM = 0
      MCIM = TO_IM(10)**13
      DO J = 1, 6
         CALL FM_RANDOM_NUMBER(VALUE)
         MBIM = 1.0D+13*VALUE
         MAIM = MAIM*MCIM + MBIM
      ENDDO
      MCIM = TO_IM(10)**70
      MAIM = MOD(MAIM,MCIM)

!                 To speed up the search, test only values that are
!                 not multiples of 2, 3, 5, 7, 11, 13.

      K = 2*3*5*7*11*13
      MAIM = (MAIM/K)*K + K + 1
      MCIM = 3

      DO J = 1, 100
         MBIM = MAIM - 1

!                 Compute 3**(p-1) mod p

         MCIM = POWER_MOD(MCIM,MBIM,MAIM)
         IF (MCIM == 1) THEN

!                 Check that 7**(p-1) mod p is also 1.

             MCIM = 7
             MCIM = POWER_MOD(MCIM,MBIM,MAIM)
             IF (MCIM == 1) THEN
                 FMT = "(///' Sample 4.',8X,I5,' values were"//  &
                       " checked before finding a prime p.'/)"
                 WRITE (*   ,FMT) J
                 WRITE (KLOG,FMT) J
                 EXIT
             ENDIF
         ENDIF

         MCIM = 3
         MAIM = MAIM + K
      ENDDO

!                 Print the result.

      CALL IM_FORM('I72',MAIM,ST1)
      WRITE (*   ,"(' p =',A)") TRIM(ST1)
      WRITE (KLOG,"(' p =',A)") TRIM(ST1)

!                 Check the answer.

      MCIM = TO_IM('546831788457201910369201221205379315384'// &
                   '5065543480825746529998049913561')
      IF (.NOT.(MAIM == MCIM)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 4.'/)")
          WRITE (KLOG,"(/' Error in sample case number 4.'/)")
      ENDIF


!             5.  Gamma function.

!                 Check that Gamma(1/2) is Sqrt(pi)

      CALL FM_SET(60)
      WRITE (*   ,"(///' Sample 5.  Check that Gamma(1/2) = Sqrt(pi)'/)")
      WRITE (KLOG,"(///' Sample 5.  Check that Gamma(1/2) = Sqrt(pi)'/)")

      MBFM = GAMMA(TO_FM('0.5'))

!                 Print the result.

      CALL FM_FORM('F62.60',MBFM,ST1)
      WRITE (*   ,"(' Gamma(1/2) = ',A)") TRIM(ST1)
      WRITE (KLOG,"(' Gamma(1/2) = ',A)") TRIM(ST1)

!                 Check the answer.

      MCFM = SQRT(4*ATAN(TO_FM(1)))
      IF (.NOT.(ABS(MCFM-MBFM) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 5.'/)")
          WRITE (KLOG,"(/' Error in sample case number 5.'/)")
      ENDIF


!             6.  Psi and Polygamma functions.

!                 Rational series can often be summed using these functions.
!                 Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) =
!                 16*(Psi(1) - Psi(9/8)) + Polygamma(1,1) + Polygamma(1,9/8)
!                 Ref: Abramowitz & Stegun, Handbook of Mathematical Functions,
!                      chapter 6, Example 10.

      WRITE (*   ,"(///' Sample 6.  Psi and Polygamma functions.'/)")
      WRITE (KLOG,"(///' Sample 6.  Psi and Polygamma functions.'/)")

      MBFM = 16*(PSI(TO_FM(1)) - PSI(TO_FM(9)/8)) +  &
             POLYGAMMA(1,TO_FM(1)) + POLYGAMMA(1,TO_FM(9)/8)

!                 Print the result.

      CALL FM_FORM('F65.60',MBFM,ST1)
      WRITE (*   ,"(' Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) = '/9X,A)") TRIM(ST1)
      WRITE (KLOG,"(' Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) = '/9X,A)") TRIM(ST1)

!                 Check the answer.

      MCFM = TO_FM('1.34994861454130247551078291050351479506449786'//  &
                   '35837270816327396M-2')
      IF (.NOT.(ABS(MCFM-MBFM) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 6.'/)")
          WRITE (KLOG,"(/' Error in sample case number 6.'/)")
      ENDIF


!             7.  Incomplete gamma and Gamma functions.

!                 Find the probability that an observed chi-square for a correct
!                 model should be less that 2.3 when the number of degrees of
!                 freedom is 5.
!                 Ref: Knuth, Volume 2, 3rd ed., Page 56, and Press, Flannery,
!                      Teukolsky, Vetterling, Numerical Recipes, 1st ed., Page 165.

      WRITE (*   ,"(///' Sample 7.  Incomplete gamma and Gamma functions.'/)")
      WRITE (KLOG,"(///' Sample 7.  Incomplete gamma and Gamma functions.'/)")

      MAFM = TO_FM(5)/2
      MBFM = INCOMPLETE_GAMMA1(MAFM,TO_FM('2.3')/2) / GAMMA(MAFM)

!                 Print the result.

      CALL FM_FORM('F61.60',MBFM,ST1)
      WRITE (*   ,"(' Probability = ',A)") TRIM(ST1)
      WRITE (KLOG,"(' Probability = ',A)") TRIM(ST1)

!                 Check the answer.

      MCFM = TO_FM('0.193733130114871446327510259182505999534723186'//  &
                   '07121386973066283739')
      IF (.NOT.(ABS(MCFM-MBFM) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 7.'/)")
          WRITE (KLOG,"(/' Error in sample case number 7.'/)")
      ENDIF


!             Complex arithmetic.

!             Set precision to give at least 30 significant digits.

      CALL FM_SET(30)


!             8.  Find a complex root of the equation
!                 f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.

!                 Newton's method with initial guess x = .56 + 1.06 i.
!                 This version is not tuned for speed.  See the ZMSQRT
!                 routine for possible ways to increase speed.
!                 Horner's rule is used to evaluate the function.

!                 MAZM is the previous iterate.
!                 MBZM is the current iterate.

      MAZM = TO_ZM('.56 + 1.06 i')

!                 Print the first iteration.

      FMT = "(///' Sample 8.  Complex root of f(x) = x**5 - 3x**4 + ',"// &
            "'x**3 - 4x**2 + x - 6 = 0.'///"                           // &
            "' Iteration       Newton Approximation')"
      WRITE (*,FMT)
      WRITE (KLOG,FMT)
      CALL ZM_FORM('F32.30','F32.30',MAZM,ST1)
      WRITE (*   ,"(/I6,4X,A)") 0,TRIM(ST1)
      WRITE (KLOG,"(/I6,4X,A)") 0,TRIM(ST1)

      DO ITER = 1, 10

!                 MCZM is f(MAZM).

         MCZM = ((((MAZM-3)*MAZM+1)*MAZM-4)*MAZM+1)*MAZM-6

!                 MDZM is f'(MAZM).

         MDZM = (((5*MAZM-12)*MAZM+3)*MAZM-8)*MAZM+1

         MBZM = MAZM - MCZM/MDZM

!                 Print each iteration.

         CALL ZM_FORM('F32.30','F32.30',MBZM,ST1)
         WRITE (*   ,"(/I6,4X,A)") ITER,TRIM(ST1)
         WRITE (KLOG,"(/I6,4X,A)") ITER,TRIM(ST1)

!                 Stop iterating if MAZM and MBZM agree to over 30 places.

         IF (ABS(MAZM-MBZM) < 1.0D-31) EXIT

!                 Set MAZM = MBZM for the next iteration.

         MAZM = MBZM
      ENDDO

!                 Check the answer.

      MCZM = TO_ZM('0.561958308335403235498111195347453 +'// &
                   '1.061134679604332556983391239058885 i')
      IF (.NOT.(ABS(MCZM-MBZM) < 1.0D-31)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 8.'/)")
          WRITE (KLOG,"(/' Error in sample case number 8.'/)")
      ENDIF


!             9.  Compute Exp(1.23-2.34i).

!                 Use the direct Taylor series.  See the ZMEXP routine
!                 for a faster way to get Exp(x).

!                 MAZM is x.
!                 MBZM is the current term, x**n/n!.
!                 MCZM is the current partial sum.

      MAZM = TO_ZM('1.23-2.34i')
      MBZM = 1
      MCZM = 1
      DO K = 1, 100
         MBZM = MBZM*MAZM/K
         MDZM = MCZM + MBZM

!                 Test for convergence.

         IF (MDZM == MCZM) THEN
             FMT = "(///' Sample 9.',8X,I5,' terms were added ',"// &
                   "'to get Exp(1.23-2.34i)'/)"
             WRITE (*   ,FMT) K
             WRITE (KLOG,FMT) K
             EXIT
         ENDIF
         MCZM = MDZM
      ENDDO

!                 Print the result.

      CALL ZM_FORM('F33.30','F32.30',MCZM,ST1)
      WRITE (*   ,"(' Result= ',A)") TRIM(ST1)
      WRITE (KLOG,"(' Result= ',A)") TRIM(ST1)

!                 Check the answer.

      MDZM = TO_ZM('-2.379681796854777515745457977696745 -'// &
                   ' 2.458032970832342652397461908326042 i')
      IF (.NOT.(ABS(MDZM-MCZM) < 1.0D-31)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 9.'/)")
          WRITE (KLOG,"(/' Error in sample case number 9.'/)")
      ENDIF


!            10.  Exception handling.
!                 Iterate (real) Exp(x) starting at 1.0 until overflow occurs.
!
!                 Testing type FM numbers directly using an IF can
!                 be tricky.  When MAFM is +overflow, the statement
!                       IF (MAFM == TO_FM(' +OVERFLOW ')) THEN
!                 will return false, since the comparison routine cannot be
!                 sure that two different overflowed results would have been
!                 equal if the overflow threshold had been higher.
!
!                 In this case, calling subroutine FMFLAG will tell when
!                 an exception has happened.
!
!                 However, for a complicated expression that generates several
!                 FM calls using the derived type numbers, note that the FM
!                 result flag may be zero at the end of the expression even if
!                 an exception occurred.  For example, if EXP(A) overflows in
!                       X = (3 + 1/EXP(A))*2
!                 then the result is 6 with a flag of zero, since the exception
!                 caused no loss of accuracy in the final result.  A warning
!                 message will still appear because of the overflow.
!
!                 The FM warning message is written on unit KW, so in this test
!                 it appears on the screen and not in the log file.
!
!                 The final result is checked by formatting the result and finding
!                 that the output string is '+ OVERFLOW'.

      CALL FM_SET(60)

      MAFM = TO_FM(1)

      FMT = "(///' Sample 10.  Exception handling.'//"                         // &
            "12X,' Iterate Exp(x) starting at 1.0 until overflow occurs.'//"  // &
            "12X,' An FM warning message will be printed before the last iteration.'/)"
      WRITE (*,FMT)
      FMT = "(///' Sample 10.  Exception handling.'//"                         // &
            "12X,' Iterate Exp(x) starting at 1.0 until overflow occurs.'/)"
      WRITE (KLOG,FMT)

      DO J = 1, 10
         MAFM = EXP(MAFM)
         CALL FMFLAG(LFLAG)
         CALL FM_FORM('1PE60.40',MAFM,ST1)
         WRITE (*   ,"(/' Iteration',I3,5X,A)") J,TRIM(ST1)
         WRITE (KLOG,"(/' Iteration',I3,5X,A)") J,TRIM(ST1)
         IF (LFLAG < 0) EXIT
      ENDDO

!             Check that the last result was +overflow.

      IF (FM_FORMAT('E60.40',MAFM) == FM_FORMAT('E60.40',TO_FM('+OVERFLOW'))) THEN
          WRITE (*   ,"(/' Overflow was correctly detected.')")
          WRITE (KLOG,"(/' Overflow was correctly detected.')")
      ELSE
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 10.'/)")
          WRITE (*   ,"(/' Overflow was not correctly detected.')")
          WRITE (KLOG   ,"(/' Error in sample case number 10.'/)")
          WRITE (KLOG   ,"(/' Overflow was not correctly detected.')")
      ENDIF

      IF (NERROR == 0) THEN
          WRITE (*   ,"(//A/)") ' All results were ok.'
          WRITE (KLOG,"(//A/)") ' All results were ok.'
      ELSE
          WRITE (*   ,"(//I3,A/)") NERROR,' error(s) found.'
          WRITE (KLOG,"(//I3,A/)") NERROR,' error(s) found.'
      ENDIF

      END PROGRAM SAMPLE
SHAR_EOF
fi # end of overwriting check
if test -f 'TestFM.f90'
then
	echo shar: will not over-write existing file "'TestFM.f90'"
else
cat << "SHAR_EOF" > 'TestFM.f90'

!                        David M. Smith

!  This is a test program for FMLIB 1.2, a multiple-precision
!  arithmetic package.  Most of the FM (floating-point real)
!  and ZM (floating-point complex) routines are tested.
!  Precision is set to 50 significant digits and the results
!  are checked to that accuracy.
!  Most of the IM (integer) routines are tested, with exact
!  results required to pass the tests.
!  Most of the USE FMZM derived type interface routines are
!  tested in the same manner as those described above.

!  If all tests are completed successfully, this line is printed:

!  935 cases tested.  No errors were found.

      MODULE TEST_VARS

      USE FMVALS
      USE FMZM

!             Declare arrays for FM variables.

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK),  &
                            MD(-1:LUNPCK),ME(-1:LUNPCK),MP1(-1:LPACK),  &
                            MP2(-1:LPACK),MP3(-1:LPACK)
      REAL (KIND(1.0D0)) :: ZA(-1:LUNPKZ),ZB(-1:LUNPKZ),ZC(-1:LUNPKZ),  &
                            ZD(-1:LUNPKZ),ZE(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MLNSV2(-1:LUNPCK),MLNSV3(-1:LUNPCK),  &
                            MLNSV5(-1:LUNPCK),MLNSV7(-1:LUNPCK)

!             Declare derived type variables.

      TYPE (FM), SAVE :: M_A,M_B,M_C,M_D,MFM1,MFM2,MFM3,MFM4,MFM5,MFM6,  &
                         MSMALL,MFMV1(3),MFMV2(3),MFMA(3,3),MFMB(3,3),MFMC(3,3)
      TYPE (IM), SAVE :: M_J,M_K,M_L,MIM1,MIM2,MIM3,MIM4,MIM5,MIMV1(3),  &
                         MIMV2(3),MIMA(2,2),MIMB(2,2),MIMC(2,2)
      TYPE (ZM), SAVE :: M_X,M_Y,M_Z,MZM1,MZM2,MZM3,MZM4,MZM5,MZMV1(3),  &
                         MZMV2(3),MZMA(2,3),MZMB(3,4),MZMC(2,4)

      INTEGER, SAVE :: J1,J2,J3,J4,J5
      REAL, SAVE :: R1,R2,R3,R4,R5,RSMALL
      DOUBLE PRECISION, SAVE :: D1,D2,D3,D4,D5,DSMALL
      COMPLEX, SAVE :: C1,C2,C3,C4,C5
      COMPLEX (KIND(0.0D0)), SAVE :: CD1,CD2,CD3,CD4

      END MODULE TEST_VARS

      PROGRAM TEST

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

!             Character strings used for input and output.

      CHARACTER(80) :: ST1,ST2
      CHARACTER(160) :: STZ1,STZ2

      INTEGER KLOG,KWSAVE,NCASE,NERROR
      REAL TIME1,TIME2

!             Write output to the standard FM output (unit KW, defined
!             in subroutine FMSET), and also to the file TESTFM.LOG.

      KLOG = 18
      OPEN (KLOG,FILE='TESTFM.LOG')
      KWSAVE = KW
      KW = KLOG

!             Set precision to give at least 50 significant digits
!             and initialize the FM package.
!             This call also checks many of the initialization values
!             used in module FMVALS (file FMSAVE.f90).  Set KW = KLOG for
!             this call so that any messages concerning these values will
!             appear in file TESTFM.LOG.

      CALL FMSET(50)
      KW = KWSAVE

      CALL TIMEIT(TIME1)

      J2 = 131
      R2 = 241.21
      D2 = 391.61D0
      C2 = ( 411.11D0 , 421.21D0 )
      CD2 = ( 431.11D0 , 441.21D0 )
      CALL FM_ST2M('581.21',MFM1)
      CALL FM_ST2M('-572.42',MFM2)
      CALL IM_ST2M('661',MIM1)
      CALL IM_ST2M('-602',MIM2)
      CALL ZM_ST2M('731.51 + 711.41 i',MZM1)
      CALL ZM_ST2M('-762.12 - 792.42 i',MZM2)

!             NERROR is the number of errors found.
!             NCASE is the number of cases tested.

      NERROR = 0

!             Test input and output conversion.

      CALL TEST1(ST1,ST2,NCASE,NERROR,KLOG)

!             Test add and subtract.

      CALL TEST2(ST1,ST2,NCASE,NERROR,KLOG)

!             Test multiply, divide and square root.

      CALL TEST3(ST1,ST2,NCASE,NERROR,KLOG)

!             Test stored constants.

      CALL TEST4(NCASE,NERROR,KLOG)

!             Test exponentials.

      CALL TEST5(ST1,ST2,NCASE,NERROR,KLOG)

!             Test logarithms.

      CALL TEST6(ST1,ST2,NCASE,NERROR,KLOG)

!             Test trigonometric functions.

      CALL TEST7(ST1,ST2,NCASE,NERROR,KLOG)

!             Test inverse trigonometric functions.

      CALL TEST8(ST1,ST2,NCASE,NERROR,KLOG)

!             Test hyperbolic functions.

      CALL TEST9(ST1,ST2,NCASE,NERROR,KLOG)

!             Test integer input and output conversion.

      CALL TEST10(ST1,ST2,NCASE,NERROR,KLOG)

!             Test integer add and subtract.

      CALL TEST11(ST1,ST2,NCASE,NERROR,KLOG)

!             Test integer multiply and divide.

      CALL TEST12(ST1,ST2,NCASE,NERROR,KLOG)

!             Test conversions between FM and IM format.

      CALL TEST13(NCASE,NERROR,KLOG)

!             Test integer power and GCD functions.

      CALL TEST14(ST1,ST2,NCASE,NERROR,KLOG)

!             Test integer modular functions.

      CALL TEST15(ST1,ST2,NCASE,NERROR,KLOG)

!             Test complex input and output conversion.

      CALL TEST16(STZ1,STZ2,NCASE,NERROR,KLOG)

!             Test complex add and subtract.

      CALL TEST17(STZ1,STZ2,NCASE,NERROR,KLOG)

!             Test complex multiply, divide and square root.

      CALL TEST18(STZ1,STZ2,NCASE,NERROR,KLOG)

!             Test complex exponentials.

      CALL TEST19(STZ1,STZ2,NCASE,NERROR,KLOG)

!             Test complex logarithms.

      CALL TEST20(STZ1,STZ2,NCASE,NERROR,KLOG)

!             Test complex trigonometric functions.

      CALL TEST21(STZ1,STZ2,NCASE,NERROR,KLOG)

!             Test complex inverse trigonometric functions.

      CALL TEST22(STZ1,STZ2,NCASE,NERROR,KLOG)

!             Test complex hyperbolic functions.

      CALL TEST23(STZ1,STZ2,NCASE,NERROR,KLOG)

!             Test the derived type = interface.

      CALL TEST24(NCASE,NERROR,KLOG)

!             Test the derived type == interface.

      CALL TEST25(NCASE,NERROR,KLOG)

!             Test the derived type /= interface.

      CALL TEST26(NCASE,NERROR,KLOG)

!             Test the derived type > interface.

      CALL TEST27(NCASE,NERROR,KLOG)

!             Test the derived type >= interface.

      CALL TEST28(NCASE,NERROR,KLOG)

!             Test the derived type < interface.

      CALL TEST29(NCASE,NERROR,KLOG)

!             Test the derived type <= interface.

      CALL TEST30(NCASE,NERROR,KLOG)

!             Test the derived type + interface.

      CALL TEST31(NCASE,NERROR,KLOG)

!             Test the derived type - interface.

      CALL TEST32(NCASE,NERROR,KLOG)

!             Test the derived type * interface.

      CALL TEST33(NCASE,NERROR,KLOG)

!             Test the derived type / interface.

      CALL TEST34(NCASE,NERROR,KLOG)

!             Test the derived type ** interface.

      CALL TEST35(NCASE,NERROR,KLOG)

!             Test the derived type functions ABS, ..., CEILING interface.

      CALL TEST36(NCASE,NERROR,KLOG)

!             Test the derived type functions CMPLX, ..., EXPONENT interface.

      CALL TEST37(NCASE,NERROR,KLOG)

!             Test the derived type functions FLOOR, ..., MIN interface.

      CALL TEST38(NCASE,NERROR,KLOG)

!             Test the derived type functions MINEXPONENT, ..., RRSPACING interface.

      CALL TEST39(NCASE,NERROR,KLOG)

!             Test the derived type functions SCALE, ..., TINY interface.

      CALL TEST40(NCASE,NERROR,KLOG)

!             Test the derived type functions TO_FM, TO_IM, TO_ZM, ..., TO_DPZ interface.

      CALL TEST41(NCASE,NERROR,KLOG)

!             Test the derived type functions ADDI, ..., Z2M interface.

      CALL TEST42(NCASE,NERROR,KLOG)

!             Test Bernoulli numbers, Pochhammer's function, Euler's constant.

      CALL TEST43(NCASE,NERROR,KLOG)

!             Test Gamma, Factorial, Log(Gamma), Beta, Binomial.

      CALL TEST44(NCASE,NERROR,KLOG)

!             Test Incomplete Gamma, Incomplete Beta.

      CALL TEST45(NCASE,NERROR,KLOG)

!             Test Polygamma, Psi.

      CALL TEST46(NCASE,NERROR,KLOG)

!             Test the different rounding modes.

      CALL TEST47(NCASE,NERROR,KLOG)

!             End of tests.

      CALL TIMEIT(TIME2)

      IF (NERROR == 0) THEN
          WRITE (KW,  &
                 "(///1X,I5,' cases tested.  No errors were found.'/)"  &
          ) NCASE
          WRITE (KLOG,  &
                 "(///1X,I5,' cases tested.  No errors were found.'/)"  &
          ) NCASE
      ELSE IF (NERROR == 1) THEN
          WRITE (KW,  &
                 "(///1X,I5,' cases tested.  1 error was found.'/)"  &
          ) NCASE
          WRITE (KLOG,  &
                 "(///1X,I5,' cases tested.  1 error was found.'/)"  &
          ) NCASE
      ELSE
          WRITE (KW,  &
                 "(///1X,I5,' cases tested.',I4,' errors were found.'/)"  &
          ) NCASE,NERROR
          WRITE (KLOG,  &
                 "(///1X,I5,' cases tested.',I4,' errors were found.'/)"  &
          ) NCASE,NERROR
      ENDIF

      IF (NERROR >= 1) THEN
          KWSAVE = KW
          KW = KLOG

!             Write some of the initialized values in common.

          CALL FMVARS
          KW = KWSAVE
      ENDIF

      WRITE (KW,*) ' '
      WRITE (KW,"(F10.2,A)") TIME2-TIME1,' Seconds for TestFM.'
      WRITE (KW,*) ' '
      WRITE (KLOG,*) ' '
      WRITE (KLOG,"(F10.2,A)") TIME2-TIME1,' Seconds for TestFM.'
      WRITE (KLOG,*) ' '

      WRITE (KW,*)' End of run.'

      STOP
      END PROGRAM TEST

      SUBROUTINE TEST1(ST1,ST2,NCASE,NERROR,KLOG)

!  Input and output testing.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

!             Logical function for comparing FM numbers.

      LOGICAL FMCOMP

      CHARACTER(80) :: ST1,ST2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing input and output routines.')")

      NCASE = 1
      CALL FMST2M('123',MA)
      CALL FMI2M(123,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-48,ME)
      CALL FMEQ(ME,MB)

!             Use the .NOT. because FMCOMP returns FALSE for special
!             cases like MD = UNKNOWN, and these should be treated
!             as errors for these tests.

      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMST2M',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 2
      ST1 = '1.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMI2M(131,MB)
      CALL FMI2M(97,MC)
      CALL FMDIV(MB,MC,ME)
      CALL FMEQ(ME,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMST2M',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 3
      ST1 = '1.3505154639175257731958762886597938144329896907216495E-2'
      CALL FMST2M(ST1,MA)
      CALL FMI2M(131,MB)
      CALL FMI2M(9700,MC)
      CALL FMDIV(MB,MC,ME)
      CALL FMEQ(ME,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-52',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMST2M',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 4
      ST1 = '1.3505154639175257731958762886597938144329896907216495E-2'
      CALL FMST2M(ST1,MA)
      CALL FMFORM('F40.30',MA,ST2)
      CALL FMST2M(ST2,MA)
      ST1 = '         .013505154639175257731958762887'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('0',MB)
      IF ((.NOT.FMCOMP(MD,'LE',MB)) .OR. ST1 /= ST2) THEN
          CALL ERRPRTFM('FMFORM',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 5
      ST1 = '1.3505154639175257731958762886597938144329896907216495E+16'
      CALL FMST2M(ST1,MA)
      CALL FMFORM('F53.33',MA,ST2)
      CALL FMST2M(ST2,MA)
      ST1 = '13505154639175257.731958762886597938144329896907216'
      CALL FMST2M(ST1,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('0',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMFORM',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 6
      ST1 = '1.3505154639175257731958762886597938144329896907216495E+16'
      CALL FMST2M(ST1,MA)
      CALL FMFORM('I24',MA,ST2)
      CALL FMST2M(ST2,MA)
      ST1 = '13505154639175258'
      CALL FMST2M(ST1,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('0',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMFORM',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 7
      ST1 ='-1.3505154639175257731958762886597938144329896907216495E+16'
      CALL FMST2M(ST1,MA)
      CALL FMFORM('E55.49',MA,ST2)
      CALL FMST2M(ST2,MA)
      ST1 = '-1.350515463917525773195876288659793814432989690722D16'
      CALL FMST2M(ST1,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('0',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMFORM',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 8
      ST1 ='-1.3505154639175257731958762886597938144329896907216495E+16'
      CALL FMST2M(ST1,MA)
      CALL FMFORM('1PE54.46',MA,ST2)
      CALL FMST2M(ST2,MA)
      ST1 = '-1.350515463917525773195876288659793814432989691M+16'
      CALL FMST2M(ST1,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('0',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMFORM',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST1

      SUBROUTINE TEST2(ST1,ST2,NCASE,NERROR,KLOG)

!  Test add and subtract.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP

      CHARACTER(80) :: ST1,ST2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing add and subtract routines.')")

      NCASE = 9
      CALL FMST2M('123',MA)
      CALL FMST2M('789',MB)
      CALL FMADD(MA,MB,ME)
      CALL FMEQ(ME,MA)
      CALL FMI2M(912,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('0',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMADD ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 10
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      ST1 = '0.7319587628865979381443298969072164948453608247422680'
      CALL FMST2M(ST1,MB)
      CALL FMADD(MA,MB,ME)
      CALL FMEQ(ME,MA)
      ST2 = '1.0824742268041237113402061855670103092783505154639175'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMADD ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 11
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      ST1 = '0.7319587628865979381443298969072164948453608247422680'
      CALL FMST2M(ST1,MB)
      CALL FMSUB(MA,MB,ME)
      CALL FMEQ(ME,MA)
      ST2 = '-.3814432989690721649484536082474226804123711340206185'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMSUB ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 12
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      ST1 = '0.3505154639175257731443298969072164948453608247422680'
      CALL FMST2M(ST1,MB)
      CALL FMSUB(MA,MB,ME)
      CALL FMEQ(ME,MA)
      ST2 = '5.15463917525773195876288659793815M-20'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMSUB ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 13
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMADDI(MA,1)
      ST2 = '1.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMADDI',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 14
      ST1 = '4.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMADDI(MA,5)
      ST2 = '9.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMADDI',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST2

      SUBROUTINE TEST3(ST1,ST2,NCASE,NERROR,KLOG)

!  Test multiply, divide and square root.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP

      CHARACTER(80) :: ST1,ST2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing multiply, divide and square root routines.')")

      NCASE = 15
      CALL FMST2M('123',MA)
      CALL FMST2M('789',MB)
      CALL FMMPY(MA,MB,ME)
      CALL FMEQ(ME,MA)
      CALL FMI2M(97047,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('0',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMMPY ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 16
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      ST1 = '0.7319587628865979381443298969072164948453608247422680'
      CALL FMST2M(ST1,MB)
      CALL FMMPY(MA,MB,ME)
      CALL FMEQ(ME,MA)
      ST2 = '0.2565628653416941226485280051014985652035285365075991'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMMPY ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 17
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      ST1 = '0.7319587628865979381443298969072164948453608247422680'
      CALL FMST2M(ST1,MB)
      CALL FMDIV(MA,MB,ME)
      CALL FMEQ(ME,MA)
      ST2 = '0.4788732394366197183098591549295774647887323943661972'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMDIV ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 18
      ST1 = '0.7319587628865979381443298969072164948453608247422680'
      CALL FMST2M(ST1,MA)
      CALL FMMPYI(MA,14,ME)
      CALL FMEQ(ME,MA)
      ST2 = '10.2474226804123711340206185567010309278350515463917526'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMMPYI',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 19
      ST1 = '0.7319587628865979381443298969072164948453608247422680'
      CALL FMST2M(ST1,MA)
      CALL FMDIVI(MA,24,ME)
      CALL FMEQ(ME,MA)
      ST2 = '0.0304982817869415807560137457044673539518900343642612'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMDIVI',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 20
      ST1 = '-0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMSQR(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '0.1228610904453183122542246784993091720692953555106813'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMSQR ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 21
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMSQRT(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '0.5920434645509785316136003710368759268547372945659987'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMSQRT',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST3

      SUBROUTINE TEST4(NCASE,NERROR,KLOG)

!  Test stored constants.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP

      REAL (KIND(1.0D0)) :: MBSAVE
      INTEGER J,JEXP,KLOG,NCASE,NDGSAV,NERROR

      WRITE (KW,"(/' Testing stored constants.'//'     Check e.'/)")

!             Switch to base 10 and check the stored digits.

      IF (NDIGMX < 55) THEN
          WRITE (KLOG,*) ' '
          WRITE (KLOG,*)  &
                  ' To test these constants at their stored precision requires'
          WRITE (KLOG,*)  &
                  ' setting NDIG=55 (number of digits).  The current maximum'
          WRITE (KLOG,*) ' for NDIG is NDIGMX = ',NDIGMX
          WRITE (KLOG,*) ' Skip the tests for stored constants.'
          RETURN
      ENDIF

      MBSAVE = MBASE
      NDGSAV = NDIG
      NCASE = 22
      CALL FMSETVAR(' MBASE = 1000 ')
      CALL FMSETVAR(' NDIG = 55 ')
      CALL FMCONS
      CALL FMI2M(1,MB)
      CALL FMEXP(MB,MC)
      DO J = 49, 51
         NDIG = J
         NDIGE = 0
         CALL FMI2M(1,MB)
         CALL FMEXP(MB,MA)
         CALL FMSUB(MA,MC,MD)
         CALL FMABS(MD,ME)
         CALL FMEQ(ME,MD)
         CALL FMI2M(1000,MB)
         JEXP = -J + 1
         CALL FMIPWR(MB,JEXP,ME)
         CALL FMEQ(ME,MB)
         IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
             CALL ERRPRTFM(' e    ',MA,'MA',MC,'MC',MD,'MD',  &
                            NCASE,NERROR,KLOG)
             EXIT
         ENDIF
      ENDDO

      NCASE = 23
      CALL FMSETVAR(' MBASE = 1000 ')
      CALL FMSETVAR(' NDIG = 55 ')
      CALL FMI2M(2,MB)
      CALL FMLN(MB,MC)
      CALL FMEQ(MLN1,MLNSV2)
      CALL FMEQ(MLN2,MLNSV3)
      CALL FMEQ(MLN3,MLNSV5)
      CALL FMEQ(MLN4,MLNSV7)
      WRITE (KW,"('     Check ln(2).'/)")
      DO J = 49, 51
         NDIG = J
         NDIGLI = 0
         CALL FMI2M(2,MB)
         CALL FMLN(MB,MA)
         CALL FMSUB(MA,MC,MD)
         CALL FMABS(MD,ME)
         CALL FMEQ(ME,MD)
         CALL FMI2M(1000,MB)
         JEXP = -J
         CALL FMIPWR(MB,JEXP,ME)
         CALL FMEQ(ME,MB)
         IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
             CALL ERRPRTFM(' ln(2)',MA,'MA',MC,'MC',MD,'MD',  &
                            NCASE,NERROR,KLOG)
             EXIT
         ENDIF
      ENDDO

      NCASE = 24
      CALL FMSETVAR(' MBASE = 1000 ')
      CALL FMSETVAR(' NDIG = 55 ')
      WRITE (KW,"('     Check ln(3).'/)")
      CALL FMEQ(MLNSV3,MC)
      DO J = 49, 51
         NDIG = J
         NDIGLI = 0
         CALL FMI2M(3,MB)
         CALL FMLN(MB,MA)
         CALL FMSUB(MA,MC,MD)
         CALL FMABS(MD,ME)
         CALL FMEQ(ME,MD)
         CALL FMI2M(1000,MB)
         JEXP = -J + 1
         CALL FMIPWR(MB,JEXP,ME)
         CALL FMEQ(ME,MB)
         IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
             CALL ERRPRTFM(' ln(3)',MA,'MA',MC,'MC',MD,'MD',  &
                            NCASE,NERROR,KLOG)
             EXIT
         ENDIF
      ENDDO

      NCASE = 25
      CALL FMSETVAR(' MBASE = 1000 ')
      CALL FMSETVAR(' NDIG = 55 ')
      WRITE (KW,"('     Check ln(5).'/)")
      CALL FMEQ(MLNSV5,MC)
      DO J = 49, 51
         NDIG = J
         NDIGLI = 0
         CALL FMI2M(5,MB)
         CALL FMLN(MB,MA)
         CALL FMSUB(MA,MC,MD)
         CALL FMABS(MD,ME)
         CALL FMEQ(ME,MD)
         CALL FMI2M(1000,MB)
         JEXP = -J + 1
         CALL FMIPWR(MB,JEXP,ME)
         CALL FMEQ(ME,MB)
         IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
             CALL ERRPRTFM(' ln(5)',MA,'MA',MC,'MC',MD,'MD',  &
                            NCASE,NERROR,KLOG)
             EXIT
         ENDIF
      ENDDO

      NCASE = 26
      CALL FMSETVAR(' MBASE = 1000 ')
      CALL FMSETVAR(' NDIG = 55 ')
      WRITE (KW,"('     Check ln(7).'/)")
      CALL FMEQ(MLNSV7,MC)
      DO J = 49, 51
         NDIG = J
         NDIGLI = 0
         CALL FMI2M(7,MB)
         CALL FMLN(MB,MA)
         CALL FMSUB(MA,MC,MD)
         CALL FMABS(MD,ME)
         CALL FMEQ(ME,MD)
         CALL FMI2M(1000,MB)
         JEXP = -J + 1
         CALL FMIPWR(MB,JEXP,ME)
         CALL FMEQ(ME,MB)
         IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
             CALL ERRPRTFM(' ln(7)',MA,'MA',MC,'MC',MD,'MD',  &
                            NCASE,NERROR,KLOG)
             EXIT
         ENDIF
      ENDDO

      NCASE = 27
      CALL FMSETVAR(' MBASE = 1000 ')
      CALL FMSETVAR(' NDIG = 55 ')
      WRITE (KW,"('     Check pi.')")
      CALL FMPI(MC)
      DO J = 49, 51
         NDIG = J
         NDIGPI = 0
         CALL FMPI(MA)
         CALL FMSUB(MA,MC,MD)
         CALL FMABS(MD,ME)
         CALL FMEQ(ME,MD)
         CALL FMI2M(1000,MB)
         JEXP = -J + 1
         CALL FMIPWR(MB,JEXP,ME)
         CALL FMEQ(ME,MB)
         IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
             CALL ERRPRTFM(' pi   ',MA,'MA',MC,'MC',MD,'MD',  &
                            NCASE,NERROR,KLOG)
             EXIT
         ENDIF
      ENDDO

!             Restore base and precision.

      MBASE = MBSAVE
      NDIG = NDGSAV
      CALL FMCONS
      RETURN
      END SUBROUTINE TEST4

      SUBROUTINE TEST5(ST1,ST2,NCASE,NERROR,KLOG)

!  Test exponentials.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP

      CHARACTER(80) :: ST1,ST2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing exponential routines.')")

      NCASE = 28
      ST1 = '-0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMEXP(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '0.7043249420381570899426746185150096342459216636010743'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMEXP ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 29
      ST1 = '5.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMEXP(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '210.7168868293979289717186453717687341395104929999527672'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-48',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMEXP ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 30
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMIPWR(MA,13,ME)
      CALL FMEQ(ME,MA)
      ST2 = '1.205572620050170403854527299272882946980306577287581E-6'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-56',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMIPWR',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 31
      ST1 = '0.7319587628865979381443298969072164948453608247422680'
      CALL FMST2M(ST1,MA)
      CALL FMIPWR(MA,-1234,ME)
      CALL FMEQ(ME,MA)
      ST2 = '1.673084074011006302103793189789209370839697748745938E167'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E+120',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMIPWR',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 32
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      ST1 = '0.7319587628865979381443298969072164948453608247422680'
      CALL FMST2M(ST1,MB)
      CALL FMPWR(MA,MB,ME)
      CALL FMEQ(ME,MA)
      ST2 = '0.4642420045002127676457665673753493595170650613692580'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMPWR ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 33
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      ST1 = '-34.7319587628865979381443298969072164948453608247422680'
      CALL FMST2M(ST1,MB)
      CALL FMPWR(MA,MB,ME)
      CALL FMEQ(ME,MA)
      ST2 = '6.504461581246879800523526109766882955934341922848773E15'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-34',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMPWR ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 34
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMRPWR(MA,1,3,ME)
      CALL FMEQ(ME,MA)
      ST2 = '0.7050756680967220302067310420367584779561732592049823'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMRPWR',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 35
      ST1 = '0.7319587628865979381443298969072164948453608247422680'
      CALL FMST2M(ST1,MA)
      CALL FMRPWR(MA,-17,5,ME)
      CALL FMEQ(ME,MA)
      ST2 = '2.8889864895853344043562747681699203201333872009477318'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMRPWR',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST5

      SUBROUTINE TEST6(ST1,ST2,NCASE,NERROR,KLOG)

!  Test logarithms.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP

      CHARACTER(80) :: ST1,ST2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing logarithm routines.')")

      NCASE = 36
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMLN(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '-1.0483504538872214324499548823726586101452117557127813'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-49',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMLN  ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 37
      ST1 = '0.3505154639175257731958762886597938144329896907216495E123'
      CALL FMST2M(ST1,MA)
      CALL FMLN(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '282.1696159843803977017629940438041389247902713456262947'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-47',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMLN  ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 38
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMLG10(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '-0.4552928172239897280304530226127473926500843247517120'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-49',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMLG10',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 39
      CALL FMLNI(210,MA)
      ST2 = '5.3471075307174686805185894350500696418856767760333836'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-49',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMIPWR',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 40
      CALL FMLNI(211,MA)
      ST2 = '5.3518581334760664957419562654542801180411581735816684'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-49',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMPWR ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST6

      SUBROUTINE TEST7(ST1,ST2,NCASE,NERROR,KLOG)

!  Test trigonometric functions.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP

      CHARACTER(80) :: ST1,ST2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing trigonometric routines.')")

      NCASE = 41
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMCOS(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '0.9391958366109693586000906984500978377093121163061328'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMCOS ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 42
      ST1 = '-43.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMCOS(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '0.8069765551968063243992244125871029909816207609700968'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMCOS ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 43
      ST1 = '-0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMSIN(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '-0.3433819746180939949443652360333010581867042625893927'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMSIN ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 44
      ST1 = '43.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMSIN(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '-0.5905834736620182429243173169772978155668602154136946'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMSIN ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 45
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMTAN(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '0.3656127521360899712035823015565426347554405301360773'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMTAN ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 46
      ST1 = '43.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMTAN(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '-0.7318471272291003544610122296764031536071117330470298'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMTAN ',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 47
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMCSSN(MA,ME,MC)
      CALL FMEQ(ME,MA)
      ST2 = '0.9391958366109693586000906984500978377093121163061328'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMCSSN',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 48
      ST1 = '-43.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMCSSN(MA,ME,MC)
      CALL FMEQ(ME,MA)
      ST2 = '0.8069765551968063243992244125871029909816207609700968'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMCSSN',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 49
      ST1 = '-0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMCSSN(MA,MC,ME)
      CALL FMEQ(ME,MA)
      ST2 = '-0.3433819746180939949443652360333010581867042625893927'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMCSSN',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 50
      ST1 = '43.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMCSSN(MA,MC,ME)
      CALL FMEQ(ME,MA)
      ST2 = '-0.5905834736620182429243173169772978155668602154136946'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMCSSN',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST7

      SUBROUTINE TEST8(ST1,ST2,NCASE,NERROR,KLOG)

!  Test inverse trigonometric functions.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP

      CHARACTER(80) :: ST1,ST2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing inverse trigonometric routines.')")

      NCASE = 51
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMACOS(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '1.2126748979730954046873545995574544481988102502510807'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMACOS',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 52
      ST1 = '-0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMACOS(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '1.9289177556166978337752887837220484359983591491240252'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMACOS',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 53
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMASIN(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '0.3581214288218012145439670920822969938997744494364723'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMASIN',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 54
      ST1 = '-0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMASIN(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '-0.3581214288218012145439670920822969938997744494364723'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMASIN',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 55
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMATAN(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '0.3371339561772373443347761845672381725353758541616570'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMATAN',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 56
      ST1 = '43.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMATAN(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '1.5477326406586162039457549832092678908202994134569781'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMATAN',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST8

      SUBROUTINE TEST9(ST1,ST2,NCASE,NERROR,KLOG)

!  Test hyperbolic functions.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP

      CHARACTER(80) :: ST1,ST2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing hyperbolic routines.')")

      NCASE = 57
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMCOSH(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '1.0620620786534654254819884264931372964608741056397718'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-49',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMCOSH',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 58
      ST1 = '-43.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMCOSH(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '3.356291383454381441662669560464886179346554730604556E+18'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-31',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMCOSH',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 59
      ST1 = '-0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMSINH(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '-0.3577371366153083355393138079781276622149524420386975'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMSINH',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 60
      ST1 = '43.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMSINH(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '3.356291383454381441662669560464886179197580776059111E+18'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-31',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMSINH',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 61
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMTANH(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '0.3368326049912874057089491946232983472275659538703038'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMTANH',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 62
      ST1 = '43.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMTANH(MA,ME)
      CALL FMEQ(ME,MA)
      ST2 = '0.9999999999999999999999999999999999999556135217341837'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMTANH',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 63
      ST1 = '0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMCHSH(MA,ME,MC)
      CALL FMEQ(ME,MA)
      ST2 = '1.0620620786534654254819884264931372964608741056397718'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-49',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMCHSH',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 64
      ST1 = '-43.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMCHSH(MA,ME,MC)
      CALL FMEQ(ME,MA)
      ST2 = '3.356291383454381441662669560464886179346554730604556E+18'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-31',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMCHSH',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 65
      ST1 = '-0.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMCHSH(MA,MC,ME)
      CALL FMEQ(ME,MA)
      ST2 = '-0.3577371366153083355393138079781276622149524420386975'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-50',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMCHSH',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 66
      ST1 = '43.3505154639175257731958762886597938144329896907216495'
      CALL FMST2M(ST1,MA)
      CALL FMCHSH(MA,MC,ME)
      CALL FMEQ(ME,MA)
      ST2 = '3.356291383454381441662669560464886179197580776059111E+18'
      CALL FMST2M(ST2,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('1.0E-31',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('FMCHSH',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST9

      SUBROUTINE TEST10(ST1,ST2,NCASE,NERROR,KLOG)

!  Input and output testing for IM routines.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

!             Logical function for comparing IM numbers.

      LOGICAL IMCOMP

      CHARACTER(80) :: ST1,ST2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing integer input and output routines.')")

      NCASE = 67
      CALL IMST2M('123',MA)
      CALL IMI2M(123,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMST2M',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 68
      ST1 = '-350515'
      CALL IMST2M(ST1,MA)
      CALL IMI2M(-350515,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMST2M',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 69
      ST1 = '19895113660064588580108197261066338165074766609'
      CALL IMST2M(ST1,MA)
      CALL IMI2M(23,MB)
      CALL IMI2M(34,MC)
      CALL IMPWR(MB,MC,ME)
      CALL IMEQ(ME,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMPWR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 70
      ST1 = '-20800708073664542533904165663516279809808659679033703'
      CALL IMST2M(ST1,MA)
      CALL IMI2M(-567,MB)
      CALL IMI2M(19,MC)
      CALL IMPWR(MB,MC,ME)
      CALL IMEQ(ME,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMPWR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 71
      ST1 = '19895113660064588580108197261066338165074766609'
      CALL IMST2M(ST1,MA)
      CALL IMFORM('I53',MA,ST2)
      CALL IMST2M(ST2,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMFORM',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 72
      ST1 = '-20800708073664542533904165663516279809808659679033703'
      CALL IMST2M(ST1,MA)
      CALL IMFORM('I73',MA,ST2)
      CALL IMST2M(ST2,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMFORM',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST10

      SUBROUTINE TEST11(ST1,ST2,NCASE,NERROR,KLOG)

!  Test add and subtract for IM routines.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL IMCOMP

      CHARACTER(80) :: ST1,ST2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing integer add and subtract routines.')")

      NCASE = 73
      CALL IMST2M('123',MA)
      CALL IMST2M('789',MB)
      CALL IMADD(MA,MB,ME)
      CALL IMEQ(ME,MA)
      CALL IMI2M(912,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMADD ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 74
      ST1 = '3505154639175257731958762886597938144329896907216495'
      CALL IMST2M(ST1,MA)
      ST1 = '7319587628865979381443298969072164948453608247422680'
      CALL IMST2M(ST1,MB)
      CALL IMADD(MA,MB,ME)
      CALL IMEQ(ME,MA)
      ST2 = '10824742268041237113402061855670103092783505154639175'
      CALL IMST2M(ST2,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMADD ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 75
      ST1 = '3505154639175257731958762886597938144329896907216495'
      CALL IMST2M(ST1,MA)
      ST1 = '7319587628865979381443298969072164948453608247422680'
      CALL IMST2M(ST1,MB)
      CALL IMSUB(MA,MB,ME)
      CALL IMEQ(ME,MA)
      ST2 = '-3814432989690721649484536082474226804123711340206185'
      CALL IMST2M(ST2,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMSUB ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 76
      ST1 = '3505154639175257731958762886597938144329896907216495'
      CALL IMST2M(ST1,MA)
      ST1 = '3505154639175257731443298969072164948453608247422680'
      CALL IMST2M(ST1,MB)
      CALL IMSUB(MA,MB,ME)
      CALL IMEQ(ME,MA)
      ST2 = '515463917525773195876288659793815'
      CALL IMST2M(ST2,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMSUB ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST11

      SUBROUTINE TEST12(ST1,ST2,NCASE,NERROR,KLOG)

!  Test integer multiply and divide.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL IMCOMP

      CHARACTER(80) :: ST1,ST2
      INTEGER IREM,KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing integer multiply, divide and square routines.')")

      NCASE = 77
      CALL IMST2M('123',MA)
      CALL IMST2M('789',MB)
      CALL IMMPY(MA,MB,ME)
      CALL IMEQ(ME,MA)
      CALL IMI2M(97047,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMMPY ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 78
      ST1 = '10430738374625018354698'
      CALL IMST2M(ST1,MA)
      ST1 = '2879494424799214514791045985'
      CALL IMST2M(ST1,MB)
      CALL IMMPY(MA,MB,ME)
      CALL IMEQ(ME,MA)
      ST2 = '30035252996271960952238822892375588336807158787530'
      CALL IMST2M(ST2,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMMPY ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 79
      CALL IMST2M('12347',MA)
      CALL IMST2M('47',MB)
      CALL IMDIV(MA,MB,ME)
      CALL IMEQ(ME,MA)
      CALL IMST2M('262',MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMDIV ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 80
      ST1 = '2701314697583086005158008013691015597308949443159762'
      CALL IMST2M(ST1,MA)
      ST1 = '-978132616472842669976589722394'
      CALL IMST2M(ST1,MB)
      CALL IMDIV(MA,MB,ME)
      CALL IMEQ(ME,MA)
      CALL IMST2M('-2761705981469115610382',MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMDIV ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 81
      CALL IMST2M('12368',MA)
      CALL IMST2M('67',MB)
      CALL IMMOD(MA,MB,ME)
      CALL IMEQ(ME,MB)
      CALL IMST2M('40',MC)
      IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
          CALL ERRPRTIM('IMMOD ',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 82
      ST1 = '2701314697583086005158008013691015597308949443159762'
      CALL IMST2M(ST1,MA)
      ST1 = '-978132616472842669976589722394'
      CALL IMST2M(ST1,MB)
      CALL IMMOD(MA,MB,ME)
      CALL IMEQ(ME,MB)
      CALL IMST2M('450750319653685523300198865254',MC)
      IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
          CALL ERRPRTIM('IMMOD ',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 83
      CALL IMST2M('1234',MA)
      CALL IMST2M('17',MB)
      CALL IMDIVR(MA,MB,MC,MD)
      CALL IMEQ(MC,MA)
      CALL IMEQ(MD,MB)
      CALL IMST2M('72',MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMDIVR',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF
      CALL IMST2M('10',MC)
      IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
          CALL ERRPRTIM('IMDIVR',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 84
      ST1 = '34274652243817531418235301715935108945364446765801943'
      CALL IMST2M(ST1,MA)
      ST1 = '-54708769795848731641842224621693'
      CALL IMST2M(ST1,MB)
      CALL IMDIVR(MA,MB,MC,MD)
      CALL IMEQ(MC,MA)
      CALL IMEQ(MD,MB)
      CALL IMST2M('-626492834178447772323',MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMDIVR',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF
      CALL IMST2M('31059777254296217822749494999104',MC)
      IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
          CALL ERRPRTIM('IMDIVR',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 85
      CALL IMST2M('4866',MA)
      CALL IMMPYI(MA,14,ME)
      CALL IMEQ(ME,MA)
      CALL IMST2M('68124',MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMMPYI',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 86
      CALL IMST2M('270131469758308600515800801369101559730894',MA)
      CALL IMMPYI(MA,-2895,ME)
      CALL IMEQ(ME,MA)
      CALL IMST2M('-782030604950303398493243319963549015420938130',MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMMPYI ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 87
      CALL IMST2M('-37179',MA)
      CALL IMDIVI(MA,129,ME)
      CALL IMEQ(ME,MA)
      CALL IMST2M('-288',MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMDIVI',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 88
      ST1 = '8267538919383255454483790743961990401918726073065738'
      CALL IMST2M(ST1,MA)
      CALL IMDIVI(MA,1729,ME)
      CALL IMEQ(ME,MA)
      ST2 = '4781688212483085861471249707323302719444028960708'
      CALL IMST2M(ST2,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMDIVI',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 89
      CALL IMST2M('-71792',MA)
      CALL IMDVIR(MA,65,MC,IREM)
      CALL IMEQ(MC,MA)
      CALL IMST2M('-1104',MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMDVIR',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF
      CALL IMI2M(IREM,MB)
      CALL IMI2M(-32,MC)
      IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
          CALL ERRPRTIM('IMDVIR',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 90
      ST1 = '97813261647284266997658972239417958580120170263408655'
      CALL IMST2M(ST1,MA)
      CALL IMDVIR(MA,826,MC,IREM)
      CALL IMEQ(MC,MA)
      ST2 = '118417992309060855929369215786220288837917881674828'
      CALL IMST2M(ST2,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMDVIR',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF
      CALL IMI2M(IREM,MB)
      CALL IMI2M(727,MC)
      IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
          CALL ERRPRTIM('IMDVIR',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 91
      CALL IMST2M('538',MA)
      CALL IMSQR(MA,ME)
      CALL IMEQ(ME,MA)
      CALL IMST2M('289444',MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMSQR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 92
      CALL IMST2M('-47818191879814587168242632',MA)
      CALL IMSQR(MA,ME)
      CALL IMEQ(ME,MA)
      ST2 = '2286579474654765721668058416662636606051551222287424'
      CALL IMST2M(ST2,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMSQR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST12

      SUBROUTINE TEST13(NCASE,NERROR,KLOG)

!  Test conversions between FM and IM format.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP,IMCOMP

      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing conversions between FM and IM format.')")

      NCASE = 93
      CALL IMST2M('123',MA)
      CALL IMI2FM(MA,MB)
      CALL FMI2M(123,MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('0',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('IMI2FM',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 94
      CALL IMST2M('979282999076598337488362000995916',MA)
      CALL IMI2FM(MA,MB)
      CALL FMST2M('979282999076598337488362000995916',MC)
      CALL FMSUB(MA,MC,MD)
      CALL FMABS(MD,ME)
      CALL FMEQ(ME,MD)
      CALL FMST2M('0',MB)
      IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
          CALL ERRPRTFM('IMI2FM',MA,'MA',MC,'MC',MD,'MD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 95
      CALL FMST2M('123.4',MA)
      CALL IMFM2I(MA,MB)
      CALL IMI2M(123,MC)
      IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
          CALL ERRPRTIM('IMFM2I',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 96
      CALL FMST2M('979282999076598337488362000995916',MA)
      CALL IMFM2I(MA,MB)
      CALL IMST2M('979282999076598337488362000995916',MC)
      IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
          CALL ERRPRTIM('IMFM2I',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST13

      SUBROUTINE TEST14(ST1,ST2,NCASE,NERROR,KLOG)

!  Test integer power and GCD functions.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL IMCOMP

      CHARACTER(80) :: ST1,ST2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing integer GCD and power routines.')")

      NCASE = 97
      CALL IMST2M('123',MA)
      CALL IMST2M('789',MB)
      CALL IMGCD(MA,MB,ME)
      CALL IMEQ(ME,MA)
      CALL IMI2M(3,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMGCD ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 98
      ST1 = '431134020618556701030927835051546391752577319587628885'
      CALL IMST2M(ST1,MA)
      ST1 = '900309278350515463917525773195876288659793814432989640'
      CALL IMST2M(ST1,MB)
      CALL IMGCD(MA,MB,ME)
      CALL IMEQ(ME,MA)
      CALL IMST2M('615',MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMGCD ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 99
      ST1 = '5877631675869176172956662762822298812326084745145447940'
      CALL IMST2M(ST1,MA)
      ST1 = '10379997509886032090765062511740075746391432253007667'
      CALL IMST2M(ST1,MB)
      CALL IMGCD(MA,MB,ME)
      CALL IMEQ(ME,MA)
      CALL IMST2M('1',MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMGCD ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 100
      CALL IMST2M('47',MA)
      CALL IMST2M('34',MB)
      CALL IMPWR(MA,MB,ME)
      CALL IMEQ(ME,MA)
      ST2 = '710112520079088427392020925014421733344154169313556279969'
      CALL IMST2M(ST2,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMPWR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 101
      CALL IMST2M('2',MA)
      CALL IMST2M('187',MB)
      CALL IMPWR(MA,MB,ME)
      CALL IMEQ(ME,MA)
      ST2 = '196159429230833773869868419475239575503198607639501078528'
      CALL IMST2M(ST2,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMPWR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 102
      CALL IMST2M('-3',MA)
      CALL IMST2M('101',MB)
      CALL IMPWR(MA,MB,ME)
      CALL IMEQ(ME,MA)
      ST2 = '-1546132562196033993109383389296863818106322566003'
      CALL IMST2M(ST2,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMPWR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST14

      SUBROUTINE TEST15(ST1,ST2,NCASE,NERROR,KLOG)

!  Test integer modular functions.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL IMCOMP

      CHARACTER(80) :: ST1,ST2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing integer modular routines.')")

      NCASE = 103
      CALL IMST2M('123',MA)
      CALL IMST2M('789',MB)
      CALL IMST2M('997',MC)
      CALL IMMPYM(MA,MB,MC,ME)
      CALL IMEQ(ME,MA)
      CALL IMI2M(338,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMMPYM',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 104
      ST1 = '431134020618556701030927835051546391752577319587628885'
      CALL IMST2M(ST1,MA)
      ST1 = '36346366019557973241042306587666640486264616086971724'
      CALL IMST2M(ST1,MB)
      ST1 = '900309278350515463917525773195876288659793814432989640'
      CALL IMST2M(ST1,MC)
      CALL IMMPYM(MA,MB,MC,ME)
      CALL IMEQ(ME,MA)
      ST2 = '458279704440780378752997531208983184411293504187816380'
      CALL IMST2M(ST2,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMMPYM',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 105
      ST1 = '914726194238000125985765939883182'
      CALL IMST2M(ST1,MA)
      ST1 = '-75505764717193044779376979508186553225192'
      CALL IMST2M(ST1,MB)
      ST1 = '18678872625055834600521936'
      CALL IMST2M(ST1,MC)
      CALL IMMPYM(MA,MB,MC,ME)
      CALL IMEQ(ME,MA)
      ST2 = '-7769745969769966093344960'
      CALL IMST2M(ST2,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMMPYM',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 106
      CALL IMST2M('123',MA)
      CALL IMST2M('789',MB)
      CALL IMST2M('997',MC)
      CALL IMPMOD(MA,MB,MC,ME)
      CALL IMEQ(ME,MA)
      CALL IMI2M(240,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMPMOD',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 107
      ST1 = '431134020618556701030927835051546391752577319587628885'
      CALL IMST2M(ST1,MA)
      ST1 = '36346366019557973241042306587666640486264616086971724'
      CALL IMST2M(ST1,MB)
      ST1 = '900309278350515463917525773195876288659793814432989640'
      CALL IMST2M(ST1,MC)
      CALL IMPMOD(MA,MB,MC,ME)
      CALL IMEQ(ME,MA)
      ST2 = '755107893576299697276281907390144058060594744720442385'
      CALL IMST2M(ST2,MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMPMOD',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 108
      CALL IMST2M('314159',MA)
      CALL IMST2M('1411695892374393248272691827763664225585897550',MB)
      CALL IMST2M('1411695892374393248272691827763664225585897551',MC)
      CALL IMPMOD(MA,MB,MC,ME)
      CALL IMEQ(ME,MA)
      CALL IMST2M('1',MC)
      IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
          CALL ERRPRTIM('IMPMOD',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST15

      SUBROUTINE TEST16(STZ1,STZ2,NCASE,NERROR,KLOG)

!  Complex input and output testing.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

!             Logical function for comparing FM numbers.

      LOGICAL FMCOMP

      CHARACTER(160) :: STZ1,STZ2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing complex input and output routines.')")

      NCASE = 109
      CALL ZMST2M('123 + 456 i',ZA)
      CALL ZM2I2M(123,456,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-48,ME)
      CALL FMEQ(ME,MB)

!             Use the .NOT. because FMCOMP returns FALSE for special
!             cases like ZD = UNKNOWN, and these should be treated
!             as errors for these tests.

      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMST2M',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 110
      STZ1 = '0.3505154639175257731958762886597938144329896907216495 + '  &
         // '0.7319587628865979381443298969072164948453608247422680 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZM2I2M(34,71,ZC)
      CALL ZMDIVI(ZC,97,ZE)
      CALL ZMEQ(ZE,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMST2M',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 111
      STZ1 = '0.3505154639175257731958762886597938144329896907216495E-5 '  &
       //'+ 0.7319587628865979381443298969072164948453608247422680D-5 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZM2I2M(34,71,ZC)
      CALL ZMDIVI(ZC,9700000,ZE)
      CALL ZMEQ(ZE,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-55,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMST2M',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 112
      STZ1 = '7.699115044247787610619469026548672566371681415929204e 03 '  &
       //'- 5.221238938053097345132743362831858407079646017699115M 03 I'
      CALL ZMST2M(STZ1,ZA)
      CALL ZM2I2M(87,-59,ZC)
      CALL ZMDIVI(ZC,113,ZE)
      CALL ZMEQ(ZE,ZC)
      CALL ZMMPYI(ZC,10000,ZE)
      CALL ZMEQ(ZE,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-47,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMST2M',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 113
      STZ1 = '7.699115044247787610619469026548672566371681415929204e+3 '  &
       //'- 5.221238938053097345132743362831858407079646017699115M+3 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMFORM('F53.33','F50.30',ZA,STZ2)
      CALL ZMST2M(STZ2,ZA)
      STZ1 = '7699.115044247787610619469026548673 '  &
       // '-5221.238938053097345132743362831858 i'
      CALL ZMST2M(STZ1,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-30,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMFORM',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 114
      STZ1 = '7.699115044247787610619469026548672566371681415929204e+3 '  &
       //'- 5.221238938053097345132743362831858407079646017699115M+3 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMFORM('I9','I7',ZA,STZ2)
      CALL ZMST2M(STZ2,ZA)
      STZ1 = '7699 -5221 i'
      CALL ZMST2M(STZ1,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(0,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMFORM',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 115
      STZ1 = '7.699115044247787610619469026548672566371681415929204e+3 '  &
       //'- 5.221238938053097345132743362831858407079646017699115M+3 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMFORM('E59.50','E58.49',ZA,STZ2)
      CALL ZMST2M(STZ2,ZA)
      STZ1 = '7.6991150442477876106194690265486725663716814159292E3'  &
       //'- 5.221238938053097345132743362831858407079646017699E3 i'
      CALL ZMST2M(STZ1,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-48,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMFORM',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 116
      STZ1 = '7.699115044247787610619469026548672566371681415929204e+3 '  &
       //'- 5.221238938053097345132743362831858407079646017699115M+3 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMFORM('1PE59.50','1PE58.49',ZA,STZ2)
      CALL ZMST2M(STZ2,ZA)
      CALL ZMST2M(STZ1,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-44,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMFORM',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST16

      SUBROUTINE TEST17(STZ1,STZ2,NCASE,NERROR,KLOG)

!  Test complex add and subtract.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP

      CHARACTER(160) :: STZ1,STZ2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing complex add and subtract routines.')")

      NCASE = 117
      CALL ZMST2M('123 + 456 i',ZA)
      CALL ZMST2M('789 - 543 i',ZB)
      CALL ZMADD(ZA,ZB,ZE)
      CALL ZMEQ(ZE,ZA)
      CALL ZM2I2M(912,-87,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(0,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMADD ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 118
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      STZ1 = '.3505154639175257731958762886597938144329896907216495 '  &
       //'+ .7319587628865979381443298969072164948453608247422680 i'
      CALL ZMST2M(STZ1,ZB)
      CALL ZMADD(ZA,ZB,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '1.1204269683423045342578231913146610710701578323145698 '  &
       //'+ 0.2098348690812882036310555606240306541373962229723565 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-49,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMADD ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 119
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      STZ1 = '.3505154639175257731958762886597938144329896907216495 '  &
       //'+ .7319587628865979381443298969072164948453608247422680 i'
      CALL ZMST2M(STZ1,ZB)
      CALL ZMSUB(ZA,ZB,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.4193960405072529878660706139950734422041784508712709 '  &
       //'- 1.2540826566919076726576042331904023355533254265121795 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-49,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMSUB ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 120
      STZ1 = '.7699115044247787610619469026548672566371681415929204E3 '  &
       //'- .5221238938053097345132743362831858407079646017699115E3 i'
      CALL ZMST2M(STZ1,ZA)
      STZ1 = '.3505154639175257731958762886597938144329896907216495 '  &
       //'+ .7319587628865979381443298969072164948453608247422680 i'
      CALL ZMST2M(STZ1,ZB)
      CALL ZMSUB(ZA,ZB,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '769.5609889608612352887510263662074628227351519021987045 '  &
       //'- 522.8558525681963324514186661800930572028099625946537725 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-47,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMSUB ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST17

      SUBROUTINE TEST18(STZ1,STZ2,NCASE,NERROR,KLOG)

!  Test complex multiply, divide and square root.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP

      CHARACTER(160) :: STZ1,STZ2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,  &
            "(/' Testing complex multiply, divide and square root routines.')")

      NCASE = 121
      CALL ZMST2M('123 + 456 i',ZA)
      CALL ZMST2M('789 - 543 i',ZB)
      CALL ZMMPY(ZA,ZB,ZE)
      CALL ZMEQ(ZE,ZA)
      CALL ZM2I2M(344655,292995,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(0,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMMPY ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 122
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      STZ1 = '.3505154639175257731958762886597938144329896907216495 '  &
       //'+ .7319587628865979381443298969072164948453608247422680 i'
      CALL ZMST2M(STZ1,ZB)
      CALL ZMMPY(ZA,ZB,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.6520390475321594745005017790347596022260742632971444 '  &
       //'+ 0.3805309734513274336283185840707964601769911504424779 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMMPY ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 123
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      STZ1 = '.3505154639175257731958762886597938144329896907216495 '  &
       //'+ .7319587628865979381443298969072164948453608247422680 i'
      CALL ZMST2M(STZ1,ZB)
      CALL ZMDIV(ZA,ZB,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '-.1705178497731560089737969128653459210208765017614861 '  &
       //'- 1.1335073636829696356072949942949842987114804337239972 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-49,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMDIV ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 124
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMMPYI(ZA,36,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '27.7168141592920353982300884955752212389380530973451327 '  &
       //'- 18.7964601769911504424778761061946902654867256637168142 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-48,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMMPYI',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 125
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMDIVI(ZA,37,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '2.080841903850753408275532169337479071992346328629514E-2 '  &
       //'- 1.411145658933269552738579287251853623535039464243004E-2 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-52,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMDIVI',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 126
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMSQR(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.3201503641632077688150990680554467851828647505677813 '  &
       //'- 0.8039783851515388832328295089670295246299631921058814 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMSQR ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 127
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMSQRT(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.9219999909012323458336720551458583330580388434229845 '  &
       //'- 0.2831474506279259570386845864488094697732718981999941 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMSQRT',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST18

      SUBROUTINE TEST19(STZ1,STZ2,NCASE,NERROR,KLOG)

!  Test complex exponentials.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP

      CHARACTER(160) :: STZ1,STZ2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing complex exponential routines.')")

      NCASE = 128
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMEXP(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '1.8718374504057787925867989348073888855260008469310002 '  &
       //'- 1.0770279996847678711699041910427261417963102075889234 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-49,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMEXP ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 129
      STZ1 = '5.7699115044247787610619469026548672566371681415929204 '  &
       //'- 4.5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMEXP(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '-60.6144766542152809520229386164396710991242264070603612 '  &
       //'+ 314.7254994809539691403004121118801578835669635535466592 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-47,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMEXP ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 130
      STZ1 = '1.7699115044247787610619469026548672566371681415929204 '  &
       //'- 1.5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMIPWR(ZA,45,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '31595668743300099.70429472191424818167262151605608585179 '  &
       //'- 19209634448276799.67717448173630165852744930837930753788 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-33,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMIPWR',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 131
      STZ1 = '1.7699115044247787610619469026548672566371681415929204 '  &
       //'- 1.5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMIPWR(ZA,-122,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '3.1000215641022021714480000129414241564868699479432E-46 '  &
       //'- 1.1687846789859477815450163510927243367234863123667E-45 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-93,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMIPWR',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 132
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      STZ1 = '.3505154639175257731958762886597938144329896907216495 '  &
       //'+ .7319587628865979381443298969072164948453608247422680 i'
      CALL ZMST2M(STZ1,ZB)
      CALL ZMPWR(ZA,ZB,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '1.4567089343012352449621841355636496276866203747888724 '  &
       //'- 0.3903177712261966292764255714390622205129978923650749 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-49,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMPWR ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 133
      STZ1 = '.3505154639175257731958762886597938144329896907216495 '  &
       //'+ .7319587628865979381443298969072164948453608247422680 i'
      CALL ZMST2M(STZ1,ZA)
      STZ1 = '2.7699115044247787610619469026548672566371681415929204 '  &
       //'- 0.5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZB)
      CALL ZMPWR(ZA,ZB,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '-1.0053105716678380336247948739245187868180079734997482 '  &
       // '- 0.0819537653234704467729051473979237153087038930127116 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-49,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMPWR ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 134
      STZ1 = '0.7699115044247787610619469026548672566371681415929204 '  &
       //'- 0.5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMRPWR(ZA,2,7,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.9653921326136512316639621651337975772631340364271270 '  &
       //'- 0.1659768285667051396562270035411852432430188906482848 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMRPWR',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 135
      STZ1 = '0.7699115044247787610619469026548672566371681415929204 '  &
       //'- 0.5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMRPWR(ZA,-19,7,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '-0.0567985880053556315170006800325686036902111276420647 '  &
       // '+ 1.2154793972711356706410882510363594270389067962568571 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-49,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMRPWR',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST19

      SUBROUTINE TEST20(STZ1,STZ2,NCASE,NERROR,KLOG)

!  Test complex logarithms.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP

      CHARACTER(160) :: STZ1,STZ2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing complex logarithm routines.')")

      NCASE = 136
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMLN(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '-0.0722949652393911311212450699415231782692434885813725 '  &
       //'-  0.5959180055163009910007765127008371205749515965219804 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMLN  ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 137
      STZ1 = '.7699115044247787610619469026548672566371681415929204E28 '  &
       //'- .5221238938053097345132743362831858407079646017699115E28 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMLN(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '64.4000876385938880213825156612206746345615981930242708 '  &
       //'-  0.5959180055163009910007765127008371205749515965219804 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-48,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMLN  ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 138
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMLG10(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '-0.0313973044728549715287589498363619677438302809470943 '  &
       //'-  0.2588039014625211035392823012785304771809982053965284 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMLG10',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 139
      STZ1 = '.7699115044247787610619469026548672566371681415929204E82 '  &
       //'- .5221238938053097345132743362831858407079646017699115E82 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMLG10(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '81.9686026955271450284712410501636380322561697190529057 '  &
       //'-  0.2588039014625211035392823012785304771809982053965284 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-48,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMLG10',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST20

      SUBROUTINE TEST21(STZ1,STZ2,NCASE,NERROR,KLOG)

!  Test complex trigonometric functions.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP

      CHARACTER(160) :: STZ1,STZ2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing complex trigonometric routines.')")

      NCASE = 140
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMCOS(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.8180802525254482451348613286211514555816444253416895 '  &
       //'+  0.3801751200076938035500853542125525088505055292851393 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMCOS ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 141
      STZ1 = '34.7699115044247787610619469026548672566371681415929204 '  &
       //'- 42.5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMCOS(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '-1432925478410268113.5816466154230974355002592549420099 '  &
       //'-  309002816679456015.00151246245263842483282458519462258 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-31,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMCOS ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 142
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMSIN(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.7931260548991613428648822413402447097755865697557818 '  &
       //'-  0.3921366045897070762848927655743167937790944353110710 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMSIN ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 143
      STZ1 = '34.7699115044247787610619469026548672566371681415929204 '  &
       //'- 42.5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMSIN(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '-3.090028166794560150015124624526384249047272360765358E17 '  &
       //'+  1.432925478410268113581646615423097435166828182950161E18 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-31,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMSIN ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 144
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMTAN(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.6141156219447569167198437040270236055089243090199979 '  &
       //'-  0.7647270337230070156308196055474639461102792169274526 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMTAN ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 145
      STZ1 = '35.7699115044247787610619469026548672566371681415929204 '  &
       //'- 43.5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMTAN(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '2.068934241218867332441292427642153175237611151321340E-38 '  &
       //'-  1.000000000000000000000000000000000000023741659169354 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-49,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMTAN ',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 146
      STZ1 = '0.3505154639175257731958762886597938144329896907216495 '  &
       //'+  0.7319587628865979381443298969072164948453608247422680 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMCSSN(ZA,ZE,ZC)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '1.2022247452809115256533054407001508718694617802593324 '  &
       //'-  0.2743936538120352873902095801531325075994392065668943 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-49,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMCSSN',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 147
      STZ1 = '0.3505154639175257731958762886597938144329896907216495 '  &
       //'+  0.7319587628865979381443298969072164948453608247422680 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMCSSN(ZA,ZC,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.4395486978082638069281369170831952476351663772871008 '  &
       //'+  0.7505035100906417134864779281080728222900154610025883 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMCSSN',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST21

      SUBROUTINE TEST22(STZ1,STZ2,NCASE,NERROR,KLOG)

!  Test complex inverse trigonometric functions.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP

      CHARACTER(160) :: STZ1,STZ2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing complex inverse trigonometric routines.')")

      NCASE = 148
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMACOS(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.8797127900868121872960714368309657795959216549012347 '  &
       //'+  0.6342141347945396859119941874681961111936156338608130 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMACOS',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 149
      STZ1 = '.7699115044247787610619469026548672566371681415929204E12 '  &
       //'- .5221238938053097345132743362831858407079646017699115E12 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMACOS(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.5959180055163009910007767810953294528367807973983794 '  &
       //'+28.2518733312491023865118844008522768856672089946951468 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-48,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMACOS',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 150
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMASIN(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.6910835367080844319352502548087856625026630447863182 '  &
       //'-  0.6342141347945396859119941874681961111936156338608130 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMASIN',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 151
      STZ1 = '.7699115044247787610619469026548672566371681415929204E13 '  &
       //'- .5221238938053097345132743362831858407079646017699115E13 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMASIN(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.9748783212785956282305451762549693982010148111568094 '  &
       //'-30.5544584242431480705298759613446206186670533428066404 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-48,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMASIN',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 152
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMATAN(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.7417952692265900376512911713942700568648670953521258 '  &
       //'- 0.3162747143126729004878357203292329539837025170484857 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMATAN',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 153
      STZ1 = '.7699115044247787610619469026548672566371681415929204E13 '  &
       //'- .5221238938053097345132743362831858407079646017699115E13 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMATAN(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '   1.570796326794807650905529836436131532596233124329403 '  &
       //'-6.033484162895927601809954710695221401671437742867605E-14 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-49,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMATAN',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST22

      SUBROUTINE TEST23(STZ1,STZ2,NCASE,NERROR,KLOG)

!  Test complex hyperbolic functions.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      LOGICAL FMCOMP

      CHARACTER(160) :: STZ1,STZ2
      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing complex hyperbolic routines.')")

      NCASE = 154
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMCOSH(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '1.1365975275870879962259716562608779977957563621412079 '  &
       //'-  0.4230463404769118342540441830446134405410543954181579 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-49,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMCOSH',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 155
      STZ1 = '34.7699115044247787610619469026548672566371681415929204 '  &
       //'- 42.5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMCOSH(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '69552104658681.7558589320148420094288419217262200765435 '  &
       //'+ 626163773308016.884007302915197616300902876551542156676 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-35,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMCOSH',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 156
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMSINH(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.7352399228186907963608272785465108877302444847897922 '  &
       //'-  0.6539816592078560369158600079981127012552558121707655 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMSINH',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 157
      STZ1 = '34.7699115044247787610619469026548672566371681415929204 '  &
       //'- 42.5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMSINH(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '6.955210465868175585893201484192181376093291191637290E 13 '  &
       //'+ 6.261637733080168840073029151984050820616907795167046E 14 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-35,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMSINH',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 158
      STZ1 = '.7699115044247787610619469026548672566371681415929204 '  &
       //'- .5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMTANH(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.7562684782933185240709480231996041186654551038993505 '  &
       //'-  0.2938991498221693198532255749292372853685311106820169 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMTANH',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 159
      STZ1 = '35.7699115044247787610619469026548672566371681415929204 '  &
       //'- 43.5221238938053097345132743362831858407079646017699115 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMTANH(ZA,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '9.999999999999999999999999999998967653135180689424497E-01 '  &
       //'+ 1.356718776492102400812550018433337461876455254467192E-31 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMTANH',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 160
      STZ1 = '0.3505154639175257731958762886597938144329896907216495 '  &
       //'+  0.7319587628865979381443298969072164948453608247422680 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMCHSH(ZA,ZE,ZC)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.7900326499280864816444807620997665088044412803737969 '  &
       //'+ 0.2390857359988804105051429301542214823277594407302781 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMCHSH',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 161
      STZ1 = '0.3505154639175257731958762886597938144329896907216495 '  &
       //'+  0.7319587628865979381443298969072164948453608247422680 i'
      CALL ZMST2M(STZ1,ZA)
      CALL ZMCHSH(ZA,ZC,ZE)
      CALL ZMEQ(ZE,ZA)
      STZ2 = '0.2661087555034471983220879532235334422670297141428191 '  &
       //'+  0.7098057980612199357870532628105009808447460332437714 i'
      CALL ZMST2M(STZ2,ZC)
      CALL ZMSUB(ZA,ZC,ZD)
      CALL ZMABS(ZD,MA)
      CALL FMI2M(10,MB)
      CALL FMIPWR(MB,-50,ME)
      CALL FMEQ(ME,MB)
      IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
          CALL ERRPRTZM('ZMCHSH',ZA,'ZA',ZC,'ZC',ZD,'ZD',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST23

      SUBROUTINE TEST24(NCASE,NERROR,KLOG)

!             Test the = assignment interface.

      USE FMVALS
      USE FMZM
      USE TEST_VARS
      IMPLICIT NONE

      INTEGER NERROR,NCASE,KLOG
      LOGICAL FM_COMP,IM_COMP

      WRITE (KW,"(/' Testing the derived type = interface.')")

      RSMALL = EPSILON(1.0)*100.0
      DSMALL = EPSILON(1.0D0)*100.0
      MSMALL = EPSILON(TO_FM(1))*10000.0
      NCASE = 162
      J4 = MFM1
      IF (J4 /= 581) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 163
      J4 = MIM1
      IF (J4 /= 661) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 164
      J4 = MZM1
      IF (J4 /= 731) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 165
      R4 = MFM1
      IF (ABS((R4-581.21)/581.21) > RSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 166
      R4 = MIM1
      IF (ABS((R4-661.0)/661.0) > RSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 167
      R4 = MZM1
      IF (ABS((R4-731.51)/731.51) > RSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 168
      D4 = MFM1
      IF (ABS((D4-581.21D0)/581.21D0) > DSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 169
      D4 = MIM1
      IF (ABS((D4-661.0D0)/661.0D0) > DSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 170
      D4 = MZM1
      IF (ABS((D4-731.51D0)/731.51D0) > DSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 171
      C4 = MFM1
      IF (ABS((C4-581.21)/581.21) > RSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 172
      C4 = MIM1
      IF (ABS((C4-661.0)/661.0) > RSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 173
      C4 = MZM1
      IF (ABS((C4-(731.51,711.41))/(731.51,711.41)) > RSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 174
      CD4 = MFM1
      IF (ABS((CD4-581.21D0)/581.21D0) > DSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 175
      CD4 = MIM1
      IF (ABS((CD4-661.0D0)/661.0D0) > DSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 176
      CD4 = MZM1
      IF (ABS((CD4-(731.51D0,711.41D0))/(731.51D0,711.41D0)) > DSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 177
      MFM3 = J2
      CALL FM_I2M(131,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ST2M('0',MFM3)
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 178
      MFM3 = R2
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = RSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 179
      MFM3 = D2
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = DSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 180
      MFM3 = C2
      CALL FM_ST2M('411.11',MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = RSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 181
      MFM3 = CD2
      CALL FM_ST2M('431.11',MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = DSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 182
      MFM3 = MFM1
      CALL FM_ST2M('581.21',MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_EQ(MSMALL,MFM3)
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 183
      MFM3 = MIM1
      CALL FM_ST2M('661',MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ST2M('0',MFM3)
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 184
      MFM3 = MZM1
      CALL FM_ST2M('731.51',MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = MSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 185
      MIM3 = J2
      CALL IM_I2M(131,MIM4)
      CALL IM_SUB(MIM3,MIM4,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      CALL IM_ST2M('0',MIM3)
      IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 186
      MIM3 = R2
      CALL IM_ST2M('241',MIM4)
      CALL IM_SUB(MIM3,MIM4,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      CALL IM_ST2M('0',MIM3)
      IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 187
      MIM3 = D2
      CALL IM_ST2M('391',MIM4)
      CALL IM_SUB(MIM3,MIM4,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      CALL IM_ST2M('0',MIM3)
      IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 188
      MIM3 = C2
      CALL IM_ST2M('411',MIM4)
      CALL IM_SUB(MIM3,MIM4,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      CALL IM_ST2M('0',MIM3)
      IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 189
      MIM3 = CD2
      CALL IM_ST2M('431',MIM4)
      CALL IM_SUB(MIM3,MIM4,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      CALL IM_ST2M('0',MIM3)
      IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 190
      MIM3 = MFM1
      CALL IM_ST2M('581',MIM4)
      CALL IM_SUB(MIM3,MIM4,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      CALL IM_ST2M('0',MIM3)
      IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 191
      MIM3 = MIM1
      CALL IM_ST2M('661',MIM4)
      CALL IM_SUB(MIM3,MIM4,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      CALL IM_ST2M('0',MIM3)
      IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 192
      MIM3 = MZM1
      CALL IM_ST2M('731',MIM4)
      CALL IM_SUB(MIM3,MIM4,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      CALL IM_ST2M('0',MIM3)
      IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 193
      MZM3 = J2
      CALL ZM_I2M(131,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      CALL FM_ST2M('0',MFM3)
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 194
      MZM3 = R2
      CALL ZM_ST2M('241.21',MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      MFM3 = RSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 195
      MZM3 = D2
      CALL ZM_ST2M('391.61',MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      MFM3 = DSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 196
      MZM3 = C2
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      MFM3 = RSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 197
      MZM3 = CD2
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      MFM3 = DSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 198
      MZM3 = MFM1
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      MFM3 = MSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 199
      MZM3 = MIM1
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      CALL FM_ST2M('0',MFM3)
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 200
      MZM3 = MZM1
      CALL ZM_ST2M('731.51 + 711.41 i',MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      MFM3 = MSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      END SUBROUTINE TEST24

      SUBROUTINE TEST25(NCASE,NERROR,KLOG)

!  Test the derived type == interface.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      INTEGER KLOG,NCASE,NERROR
      LOGICAL FM_COMP

      WRITE (KW,"(/' Testing the derived type == interface.')")

      NCASE = 201
      M_A = 123
      M_B = M_A
      IF (.NOT.FM_COMP(M_A,'==',M_B)) THEN
          CALL ERRPRT_FM('  ==  ',M_A,'M_A',M_B,'M_B',M_B,'M_B',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 202
      M_A = 123
      M_B = M_A
      IF (.NOT.FM_COMP(M_A,'EQ',M_B)) THEN
          CALL ERRPRT_FM('  ==  ',M_A,'M_A',M_B,'M_B',M_B,'M_B',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 203
      J1 = 123
      M_A = J1
      IF (.NOT.(M_A == J1)) THEN
          CALL ERRPRT_FM('  ==  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 204
      J1 = 123
      M_A = J1
      IF (.NOT.(J1 == M_A)) THEN
          CALL ERRPRT_FM('  ==  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 205
      J1 = 123
      M_J = J1
      IF (.NOT.(M_J == J1)) THEN
          CALL ERRPRT_IM('  ==  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 206
      J1 = 123
      M_J = J1
      IF (.NOT.(J1 == M_J)) THEN
          CALL ERRPRT_IM('  ==  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 207
      J1 = 123
      M_Z = J1
      IF (.NOT.(M_Z == J1)) THEN
          CALL ERRPRT_ZM('  ==  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 208
      J1 = 123
      M_Z = J1
      IF (.NOT.(J1 == M_Z)) THEN
          CALL ERRPRT_ZM('  ==  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 209
      R1 = 12.3
      M_A = R1
      IF (.NOT.(M_A == R1)) THEN
          CALL ERRPRT_FM('  ==  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 210
      R1 = 12.3
      M_A = R1
      IF (.NOT.(R1 == M_A)) THEN
          CALL ERRPRT_FM('  ==  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 211
      R1 = 123
      M_J = R1
      IF (.NOT.(M_J == R1)) THEN
          CALL ERRPRT_IM('  ==  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 212
      R1 = 123
      M_J = R1
      IF (.NOT.(R1 == M_J)) THEN
          CALL ERRPRT_IM('  ==  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 213
      R1 = 12.3
      M_Z = R1
      IF (.NOT.(M_Z == R1)) THEN
          CALL ERRPRT_ZM('  ==  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 214
      R1 = 12.3
      M_Z = R1
      IF (.NOT.(R1 == M_Z)) THEN
          CALL ERRPRT_ZM('  ==  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 215
      D1 = 12.3
      M_A = D1
      IF (.NOT.(M_A == D1)) THEN
          CALL ERRPRT_FM('  ==  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 216
      D1 = 12.3
      M_A = D1
      IF (.NOT.(D1 == M_A)) THEN
          CALL ERRPRT_FM('  ==  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 217
      D1 = 123
      M_J = D1
      IF (.NOT.(M_J == D1)) THEN
          CALL ERRPRT_IM('  ==  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 218
      D1 = 123
      M_J = D1
      IF (.NOT.(D1 == M_J)) THEN
          CALL ERRPRT_IM('  ==  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 219
      D1 = 12.3
      M_Z = D1
      IF (.NOT.(M_Z == D1)) THEN
          CALL ERRPRT_ZM('  ==  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 220
      D1 = 12.3
      M_Z = D1
      IF (.NOT.(D1 == M_Z)) THEN
          CALL ERRPRT_ZM('  ==  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 221
      C1 = 12.3
      M_A = C1
      IF (.NOT.(M_A == C1)) THEN
          CALL ERRPRT_FM('  ==  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 222
      C1 = 12.3
      M_A = C1
      IF (.NOT.(C1 == M_A)) THEN
          CALL ERRPRT_FM('  ==  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 223
      C1 = 123
      M_J = C1
      IF (.NOT.(M_J == C1)) THEN
          CALL ERRPRT_IM('  ==  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 224
      C1 = 123
      M_J = C1
      IF (.NOT.(C1 == M_J)) THEN
          CALL ERRPRT_IM('  ==  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 225
      C1 = (12.3 , 45.6)
      M_Z = C1
      IF (.NOT.(M_Z == C1)) THEN
          CALL ERRPRT_ZM('  ==  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 226
      C1 = (12.3 , 45.6)
      M_Z = C1
      IF (.NOT.(C1 == M_Z)) THEN
          CALL ERRPRT_ZM('  ==  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 227
      CD1 = 12.3
      M_A = CD1
      IF (.NOT.(M_A == CD1)) THEN
          CALL ERRPRT_FM('  ==  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 228
      CD1 = 12.3
      M_A = CD1
      IF (.NOT.(CD1 == M_A)) THEN
          CALL ERRPRT_FM('  ==  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 229
      CD1 = 123
      M_J = CD1
      IF (.NOT.(M_J == CD1)) THEN
          CALL ERRPRT_IM('  ==  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 230
      CD1 = 123
      M_J = CD1
      IF (.NOT.(CD1 == M_J)) THEN
          CALL ERRPRT_IM('  ==  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 231
      CD1 = (12.3 , 45.6)
      M_Z = CD1
      IF (.NOT.(M_Z == CD1)) THEN
          CALL ERRPRT_ZM('  ==  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 232
      CD1 = (12.3 , 45.6)
      M_Z = CD1
      IF (.NOT.(CD1 == M_Z)) THEN
          CALL ERRPRT_ZM('  ==  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 233
      M_B = 12.3
      M_A = M_B
      IF (.NOT.(M_A == M_B)) THEN
          CALL ERRPRT_FM('  ==  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 234
      M_B = 123
      M_J = M_B
      IF (.NOT.(M_J == M_B)) THEN
          CALL ERRPRT_IM('  ==  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 235
      M_B = 123
      M_J = M_B
      IF (.NOT.(M_B == M_J)) THEN
          CALL ERRPRT_IM('  ==  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 236
      M_B = (12.3 , 45.6)
      M_Z = M_B
      IF (.NOT.(M_Z == M_B)) THEN
          CALL ERRPRT_ZM('  ==  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 237
      M_B = (12.3 , 45.6)
      M_Z = M_B
      IF (.NOT.(M_B == M_Z)) THEN
          CALL ERRPRT_ZM('  ==  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 238
      M_K = 123
      M_J = M_K
      IF (.NOT.(M_J == M_K)) THEN
          CALL ERRPRT_IM('  ==  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 239
      M_K = (12.3 , 45.6)
      M_Z = M_K
      IF (.NOT.(M_Z == M_K)) THEN
          CALL ERRPRT_ZM('  ==  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 240
      M_K = (12.3 , 45.6)
      M_Z = M_K
      IF (.NOT.(M_K == M_Z)) THEN
          CALL ERRPRT_ZM('  ==  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 241
      M_Y = (12.3 , 45.6)
      M_Z = M_Y
      IF (.NOT.(M_Y == M_Z)) THEN
          CALL ERRPRT_ZM('  ==  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST25

      SUBROUTINE TEST26(NCASE,NERROR,KLOG)

!  Test the derived type /= interface.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      INTEGER KLOG,NCASE,NERROR
      LOGICAL FM_COMP

      WRITE (KW,"(/' Testing the derived type /= interface.')")

      NCASE = 242
      M_A = 123
      M_B = 124
      IF (.NOT.FM_COMP(M_A,'/=',M_B)) THEN
          CALL ERRPRT_FM('  ==  ',M_A,'M_A',M_B,'M_B',M_B,'M_B',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 243
      M_A = 123
      M_B = 124
      IF (.NOT.FM_COMP(M_A,'NE',M_B)) THEN
          CALL ERRPRT_FM('  ==  ',M_A,'M_A',M_B,'M_B',M_B,'M_B',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 244
      J1 = 123
      M_A = 1 + J1
      IF (.NOT.(M_A /= J1)) THEN
          CALL ERRPRT_FM('  /=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 245
      J1 = 123
      M_A = 1 + J1
      IF (.NOT.(J1 /= M_A)) THEN
          CALL ERRPRT_FM('  /=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 246
      J1 = 123
      M_J = 1 + J1
      IF (.NOT.(M_J /= J1)) THEN
          CALL ERRPRT_IM('  /=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 247
      J1 = 123
      M_J = 1 + J1
      IF (.NOT.(J1 /= M_J)) THEN
          CALL ERRPRT_IM('  /=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 248
      J1 = 123
      M_Z = 1 + J1
      IF (.NOT.(M_Z /= J1)) THEN
          CALL ERRPRT_ZM('  /=  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 249
      J1 = 123
      M_Z = 1 + J1
      IF (.NOT.(J1 /= M_Z)) THEN
          CALL ERRPRT_ZM('  /=  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 250
      R1 = 12.3
      M_A = 1 + R1
      IF (.NOT.(M_A /= R1)) THEN
          CALL ERRPRT_FM('  /=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 251
      R1 = 12.3
      M_A = 1 + R1
      IF (.NOT.(R1 /= M_A)) THEN
          CALL ERRPRT_FM('  /=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 252
      R1 = 123
      M_J = 1 + R1
      IF (.NOT.(M_J /= R1)) THEN
          CALL ERRPRT_IM('  /=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 253
      R1 = 123
      M_J = 1 + R1
      IF (.NOT.(R1 /= M_J)) THEN
          CALL ERRPRT_IM('  /=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 254
      R1 = 12.3
      M_Z = 1 + R1
      IF (.NOT.(M_Z /= R1)) THEN
          CALL ERRPRT_ZM('  /=  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 255
      R1 = 12.3
      M_Z = 1 + R1
      IF (.NOT.(R1 /= M_Z)) THEN
          CALL ERRPRT_ZM('  /=  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 256
      D1 = 12.3
      M_A = 1 + D1
      IF (.NOT.(M_A /= D1)) THEN
          CALL ERRPRT_FM('  /=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 257
      D1 = 12.3
      M_A = 1 + D1
      IF (.NOT.(D1 /= M_A)) THEN
          CALL ERRPRT_FM('  /=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 258
      D1 = 123
      M_J = 1 + D1
      IF (.NOT.(M_J /= D1)) THEN
          CALL ERRPRT_IM('  /=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 259
      D1 = 123
      M_J = 1 + D1
      IF (.NOT.(D1 /= M_J)) THEN
          CALL ERRPRT_IM('  /=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 260
      D1 = 12.3
      M_Z = 1 + D1
      IF (.NOT.(M_Z /= D1)) THEN
          CALL ERRPRT_ZM('  /=  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 261
      D1 = 12.3
      M_Z = 1 + D1
      IF (.NOT.(D1 /= M_Z)) THEN
          CALL ERRPRT_ZM('  /=  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 262
      C1 = 12.3
      M_A = 1 + C1
      IF (.NOT.(M_A /= C1)) THEN
          CALL ERRPRT_FM('  /=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 263
      C1 = 12.3
      M_A = 1 + C1
      IF (.NOT.(C1 /= M_A)) THEN
          CALL ERRPRT_FM('  /=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 264
      C1 = 123
      M_J = 1 + C1
      IF (.NOT.(M_J /= C1)) THEN
          CALL ERRPRT_IM('  /=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 265
      C1 = 123
      M_J = 1 + C1
      IF (.NOT.(C1 /= M_J)) THEN
          CALL ERRPRT_IM('  /=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 266
      C1 = (12.3 , 45.6)
      M_Z = 1 + C1
      IF (.NOT.(M_Z /= C1)) THEN
          CALL ERRPRT_ZM('  /=  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 267
      C1 = (12.3 , 45.6)
      M_Z = 1 + C1
      IF (.NOT.(C1 /= M_Z)) THEN
          CALL ERRPRT_ZM('  /=  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 268
      CD1 = 12.3
      M_A = 1 + CD1
      IF (.NOT.(M_A /= CD1)) THEN
          CALL ERRPRT_FM('  /=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 269
      CD1 = 12.3
      M_A = 1 + CD1
      IF (.NOT.(CD1 /= M_A)) THEN
          CALL ERRPRT_FM('  /=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 270
      CD1 = 123
      M_J = 1 + CD1
      IF (.NOT.(M_J /= CD1)) THEN
          CALL ERRPRT_IM('  /=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 271
      CD1 = 123
      M_J = 1 + CD1
      IF (.NOT.(CD1 /= M_J)) THEN
          CALL ERRPRT_IM('  /=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 272
      CD1 = (12.3 , 45.6)
      M_Z = 1 + CD1
      IF (.NOT.(M_Z /= CD1)) THEN
          CALL ERRPRT_ZM('  /=  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 273
      CD1 = (12.3 , 45.6)
      M_Z = 1 + CD1
      IF (.NOT.(CD1 /= M_Z)) THEN
          CALL ERRPRT_ZM('  /=  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 274
      M_B = 12.3
      M_A = 1 + M_B
      IF (.NOT.(M_A /= M_B)) THEN
          CALL ERRPRT_FM('  /=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 275
      M_B = 123
      M_J = 1 + M_B
      IF (.NOT.(M_J /= M_B)) THEN
          CALL ERRPRT_IM('  /=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 276
      M_B = 123
      M_J = 1 + M_B
      IF (.NOT.(M_B /= M_J)) THEN
          CALL ERRPRT_IM('  /=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 277
      M_B = (12.3 , 45.6)
      M_Z = 1 + M_B
      IF (.NOT.(M_Z /= M_B)) THEN
          CALL ERRPRT_ZM('  /=  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 278
      M_B = (12.3 , 45.6)
      M_Z = 1 + M_B
      IF (.NOT.(M_B /= M_Z)) THEN
          CALL ERRPRT_ZM('  /=  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 279
      M_K = 123
      M_J = 1 + M_K
      IF (.NOT.(M_J /= M_K)) THEN
          CALL ERRPRT_IM('  /=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 280
      M_K = (12.3 , 45.6)
      M_Z = 1 + M_K
      IF (.NOT.(M_Z /= M_K)) THEN
          CALL ERRPRT_ZM('  /=  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 281
      M_K = (12.3 , 45.6)
      M_Z = 1 + M_K
      IF (.NOT.(M_K /= M_Z)) THEN
          CALL ERRPRT_ZM('  /=  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 282
      M_Y = (12.3 , 45.6)
      M_Z = 1 + M_Y
      IF (.NOT.(M_Y /= M_Z)) THEN
          CALL ERRPRT_ZM('  /=  ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST26

      SUBROUTINE TEST27(NCASE,NERROR,KLOG)

!  Test the derived type > interface.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      INTEGER KLOG,NCASE,NERROR
      LOGICAL FM_COMP

      WRITE (KW,"(/' Testing the derived type > interface.')")

      NCASE = 283
      M_A = 125
      M_B = 124
      IF (.NOT.FM_COMP(M_A,'>',M_B)) THEN
          CALL ERRPRT_FM('   >  ',M_A,'M_A',M_B,'M_B',M_B,'M_B',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 284
      M_A = 125
      M_B = 124
      IF (.NOT.FM_COMP(M_A,'GT',M_B)) THEN
          CALL ERRPRT_FM('   >  ',M_A,'M_A',M_B,'M_B',M_B,'M_B',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 285
      J1 = 123
      M_A = J1 + 1
      IF (.NOT.(M_A > J1)) THEN
          CALL ERRPRT_FM('   >  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 286
      J1 = 123
      M_A = J1 - 1
      IF (.NOT.(J1 > M_A)) THEN
          CALL ERRPRT_FM('   >  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 287
      J1 = 123
      M_J = J1 + 1
      IF (.NOT.(M_J > J1)) THEN
          CALL ERRPRT_IM('   >  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 288
      J1 = 123
      M_J = J1 - 1
      IF (.NOT.(J1 > M_J)) THEN
          CALL ERRPRT_IM('   >  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 289
      R1 = 12.3
      M_A = R1 + 1
      IF (.NOT.(M_A > R1)) THEN
          CALL ERRPRT_FM('   >  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 290
      R1 = 12.3
      M_A = R1 - 1
      IF (.NOT.(R1 > M_A)) THEN
          CALL ERRPRT_FM('   >  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 291
      R1 = 123
      M_J = R1 + 1
      IF (.NOT.(M_J > R1)) THEN
          CALL ERRPRT_IM('   >  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 292
      R1 = 123
      M_J = R1 - 1
      IF (.NOT.(R1 > M_J)) THEN
          CALL ERRPRT_IM('   >  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 293
      D1 = 12.3
      M_A = D1 + 1
      IF (.NOT.(M_A > D1)) THEN
          CALL ERRPRT_FM('   >  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 294
      D1 = 12.3
      M_A = D1 - 1
      IF (.NOT.(D1 > M_A)) THEN
          CALL ERRPRT_FM('   >  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 295
      D1 = 123
      M_J = D1 + 1
      IF (.NOT.(M_J > D1)) THEN
          CALL ERRPRT_IM('   >  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 296
      D1 = 123
      M_J = D1 - 1
      IF (.NOT.(D1 > M_J)) THEN
          CALL ERRPRT_IM('   >  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 297
      M_B = 12.3
      M_A = M_B + 1
      IF (.NOT.(M_A > M_B)) THEN
          CALL ERRPRT_FM('   >  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 298
      M_B = 123
      M_J = M_B + 1
      IF (.NOT.(M_J > M_B)) THEN
          CALL ERRPRT_IM('   >  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 299
      M_B = 123
      M_J = M_B - 1
      IF (.NOT.(M_B > M_J)) THEN
          CALL ERRPRT_IM('   >  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 300
      M_K = 123
      M_J = M_K + 1
      IF (.NOT.(M_J > M_K)) THEN
          CALL ERRPRT_IM('   >  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST27

      SUBROUTINE TEST28(NCASE,NERROR,KLOG)

!  Test the derived type >= interface.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      INTEGER KLOG,NCASE,NERROR
      LOGICAL FM_COMP

      WRITE (KW,"(/' Testing the derived type >= interface.')")

      NCASE = 301
      M_A = 125
      M_B = 124
      IF (.NOT.FM_COMP(M_A,'>=',M_B)) THEN
          CALL ERRPRT_FM('  >=  ',M_A,'M_A',M_B,'M_B',M_B,'M_B',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 302
      M_A = 125
      M_B = 124
      IF (.NOT.FM_COMP(M_A,'GE',M_B)) THEN
          CALL ERRPRT_FM('  >=  ',M_A,'M_A',M_B,'M_B',M_B,'M_B',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 303
      J1 = 123
      M_A = J1 + 1
      IF (.NOT.(M_A >= J1)) THEN
          CALL ERRPRT_FM('  >=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 304
      J1 = 123
      M_A = J1 - 1
      IF (.NOT.(J1 >= M_A)) THEN
          CALL ERRPRT_FM('  >=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 305
      J1 = 123
      M_J = J1 + 1
      IF (.NOT.(M_J >= J1)) THEN
          CALL ERRPRT_IM('  >=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 306
      J1 = 123
      M_J = J1 - 1
      IF (.NOT.(J1 >= M_J)) THEN
          CALL ERRPRT_IM('  >=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 307
      R1 = 12.3
      M_A = R1 + 1
      IF (.NOT.(M_A >= R1)) THEN
          CALL ERRPRT_FM('  >=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 308
      R1 = 12.3
      M_A = R1 - 1
      IF (.NOT.(R1 >= M_A)) THEN
          CALL ERRPRT_FM('  >=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 309
      R1 = 123
      M_J = R1 + 1
      IF (.NOT.(M_J >= R1)) THEN
          CALL ERRPRT_IM('  >=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 310
      R1 = 123
      M_J = R1 - 1
      IF (.NOT.(R1 >= M_J)) THEN
          CALL ERRPRT_IM('  >=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 311
      D1 = 12.3
      M_A = D1 + 1
      IF (.NOT.(M_A >= D1)) THEN
          CALL ERRPRT_FM('  >=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 312
      D1 = 12.3
      M_A = D1 - 1
      IF (.NOT.(D1 >= M_A)) THEN
          CALL ERRPRT_FM('  >=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 313
      D1 = 123
      M_J = D1 + 1
      IF (.NOT.(M_J >= D1)) THEN
          CALL ERRPRT_IM('  >=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 314
      D1 = 123
      M_J = D1 - 1
      IF (.NOT.(D1 >= M_J)) THEN
          CALL ERRPRT_IM('  >=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 315
      M_B = 12.3
      M_A = M_B + 1
      IF (.NOT.(M_A >= M_B)) THEN
          CALL ERRPRT_FM('  >=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 316
      M_B = 123
      M_J = M_B + 1
      IF (.NOT.(M_J >= M_B)) THEN
          CALL ERRPRT_IM('  >=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 317
      M_B = 123
      M_J = M_B - 1
      IF (.NOT.(M_B >= M_J)) THEN
          CALL ERRPRT_IM('  >=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 318
      M_K = 123
      M_J = M_K + 1
      IF (.NOT.(M_J >= M_K)) THEN
          CALL ERRPRT_IM('  >=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST28

      SUBROUTINE TEST29(NCASE,NERROR,KLOG)

!  Test the derived type < interface.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      INTEGER KLOG,NCASE,NERROR
      LOGICAL FM_COMP

      WRITE (KW,"(/' Testing the derived type < interface.')")

      NCASE = 319
      M_A = 123
      M_B = 124
      IF (.NOT.FM_COMP(M_A,'<',M_B)) THEN
          CALL ERRPRT_FM('   <  ',M_A,'M_A',M_B,'M_B',M_B,'M_B',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 320
      M_A = 123
      M_B = 124
      IF (.NOT.FM_COMP(M_A,'LT',M_B)) THEN
          CALL ERRPRT_FM('   <  ',M_A,'M_A',M_B,'M_B',M_B,'M_B',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 321
      J1 = 123
      M_A = J1 - 2
      IF (.NOT.(M_A < J1)) THEN
          CALL ERRPRT_FM('   <  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 322
      J1 = 123
      M_A = J1 + 2
      IF (.NOT.(J1 < M_A)) THEN
          CALL ERRPRT_FM('   <  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 323
      J1 = 123
      M_J = J1 - 2
      IF (.NOT.(M_J < J1)) THEN
          CALL ERRPRT_IM('   <  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 324
      J1 = 123
      M_J = J1 + 2
      IF (.NOT.(J1 < M_J)) THEN
          CALL ERRPRT_IM('   <  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 325
      R1 = 12.3
      M_A = R1 - 2
      IF (.NOT.(M_A < R1)) THEN
          CALL ERRPRT_FM('   <  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 326
      R1 = 12.3
      M_A = R1 + 2
      IF (.NOT.(R1 < M_A)) THEN
          CALL ERRPRT_FM('   <  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 327
      R1 = 123
      M_J = R1 - 2
      IF (.NOT.(M_J < R1)) THEN
          CALL ERRPRT_IM('   <  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 328
      R1 = 123
      M_J = R1 + 2
      IF (.NOT.(R1 < M_J)) THEN
          CALL ERRPRT_IM('   <  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 329
      D1 = 12.3
      M_A = D1 - 2
      IF (.NOT.(M_A < D1)) THEN
          CALL ERRPRT_FM('   <  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 330
      D1 = 12.3
      M_A = D1 + 2
      IF (.NOT.(D1 < M_A)) THEN
          CALL ERRPRT_FM('   <  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 331
      D1 = 123
      M_J = D1 - 2
      IF (.NOT.(M_J < D1)) THEN
          CALL ERRPRT_IM('   <  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 332
      D1 = 123
      M_J = D1 + 2
      IF (.NOT.(D1 < M_J)) THEN
          CALL ERRPRT_IM('   <  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 333
      M_B = 12.3
      M_A = M_B - 2
      IF (.NOT.(M_A < M_B)) THEN
          CALL ERRPRT_FM('   <  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 334
      M_B = 123
      M_J = M_B - 2
      IF (.NOT.(M_J < M_B)) THEN
          CALL ERRPRT_IM('   <  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 335
      M_B = 123
      M_J = M_B + 2
      IF (.NOT.(M_B < M_J)) THEN
          CALL ERRPRT_IM('   <  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 336
      M_K = 123
      M_J = M_K - 2
      IF (.NOT.(M_J < M_K)) THEN
          CALL ERRPRT_IM('   <  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST29

      SUBROUTINE TEST30(NCASE,NERROR,KLOG)

!  Test the derived type <= interface.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      INTEGER KLOG,NCASE,NERROR
      LOGICAL FM_COMP

      WRITE (KW,"(/' Testing the derived type <= interface.')")

      NCASE = 337
      M_A = 123
      M_B = 124
      IF (.NOT.FM_COMP(M_A,'<=',M_B)) THEN
          CALL ERRPRT_FM('  <=  ',M_A,'M_A',M_B,'M_B',M_B,'M_B',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 338
      M_A = 123
      M_B = 124
      IF (.NOT.FM_COMP(M_A,'LE',M_B)) THEN
          CALL ERRPRT_FM('  <=  ',M_A,'M_A',M_B,'M_B',M_B,'M_B',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 339
      J1 = 123
      M_A = J1 - 2
      IF (.NOT.(M_A <= J1)) THEN
          CALL ERRPRT_FM('  <=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 340
      J1 = 123
      M_A = J1 + 2
      IF (.NOT.(J1 <= M_A)) THEN
          CALL ERRPRT_FM('  <=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 341
      J1 = 123
      M_J = J1 - 2
      IF (.NOT.(M_J <= J1)) THEN
          CALL ERRPRT_IM('  <=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 342
      J1 = 123
      M_J = J1 + 2
      IF (.NOT.(J1 <= M_J)) THEN
          CALL ERRPRT_IM('  <=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 343
      R1 = 12.3
      M_A = R1 - 2
      IF (.NOT.(M_A <= R1)) THEN
          CALL ERRPRT_FM('  <=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 344
      R1 = 12.3
      M_A = R1 + 2
      IF (.NOT.(R1 <= M_A)) THEN
          CALL ERRPRT_FM('  <=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 345
      R1 = 123
      M_J = R1 - 2
      IF (.NOT.(M_J <= R1)) THEN
          CALL ERRPRT_IM('  <=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 346
      R1 = 123
      M_J = R1 + 2
      IF (.NOT.(R1 <= M_J)) THEN
          CALL ERRPRT_IM('  <=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 347
      D1 = 12.3
      M_A = D1 - 2
      IF (.NOT.(M_A <= D1)) THEN
          CALL ERRPRT_FM('  <=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 348
      D1 = 12.3
      M_A = D1 + 2
      IF (.NOT.(D1 <= M_A)) THEN
          CALL ERRPRT_FM('  <=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 349
      D1 = 123
      M_J = D1 - 2
      IF (.NOT.(M_J <= D1)) THEN
          CALL ERRPRT_IM('  <=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 350
      D1 = 123
      M_J = D1 + 2
      IF (.NOT.(D1 <= M_J)) THEN
          CALL ERRPRT_IM('  <=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 351
      M_B = 12.3
      M_A = M_B - 2
      IF (.NOT.(M_A <= M_B)) THEN
          CALL ERRPRT_FM('  <=  ',M_A,'M_A',M_A,'M_A',M_A,'M_A',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 352
      M_B = 123
      M_J = M_B - 2
      IF (.NOT.(M_J <= M_B)) THEN
          CALL ERRPRT_IM('  <=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 353
      M_B = 123
      M_J = M_B + 2
      IF (.NOT.(M_B <= M_J)) THEN
          CALL ERRPRT_IM('  <=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 354
      M_K = 123
      M_J = M_K - 2
      IF (.NOT.(M_J <= M_K)) THEN
          CALL ERRPRT_IM('  <=  ',M_J,'M_J',M_J,'M_J',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST30

      SUBROUTINE TEST31(NCASE,NERROR,KLOG)

!             Test the '+' arithmetic operator.

      USE FMVALS
      USE FMZM
      USE TEST_VARS
      IMPLICIT NONE

      INTEGER KLOG,NERROR,NCASE

      WRITE (KW,"(/' Testing the derived type + interface.')")

      RSMALL = EPSILON(1.0)*100.0
      DSMALL = EPSILON(1.0D0)*100.0

      NCASE = 355
      MFM3 = J2 + MFM1
      CALL FM_ST2M('131',MFM4)
      CALL FM_ADD(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 356
      MIM3 = J2 + MIM1
      CALL IM_ST2M('131',MIM4)
      CALL IM_ADD(MIM4,MIM1,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 357
      MZM3 = J2 + MZM1
      CALL ZM_ST2M('131',MZM4)
      CALL ZM_ADD(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 358
      MFM3 = R2 + MFM1
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_ADD(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 359
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_ST2M('661',MFM3)
      CALL FM_ADD(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = R2 + MIM1
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 360
      MZM3 = R2 + MZM1
      CALL ZM_ST2M('241.21',MZM4)
      CALL ZM_ADD(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 361
      MFM3 = D2 + MFM1
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_ADD(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 362
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_ST2M('661',MFM3)
      CALL FM_ADD(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = D2 + MIM1
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 363
      MZM3 = D2 + MZM1
      CALL ZM_ST2M('391.61',MZM4)
      CALL ZM_ADD(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 364
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_ST2M('581.21',MZM3)
      CALL ZM_ADD(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = C2 + MFM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 365
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_ST2M('661',MZM3)
      CALL ZM_ADD(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = C2 + MIM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 366
      MZM3 = C2 + MZM1
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_ADD(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 367
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_ST2M('581.21',MZM3)
      CALL ZM_ADD(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = CD2 + MFM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 368
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_ST2M('661',MZM3)
      CALL ZM_ADD(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = CD2 + MIM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 369
      MZM3 = CD2 + MZM1
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_ADD(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 370
      MFM3 = MFM1 + J2
      CALL FM_ST2M('131',MFM4)
      CALL FM_ADD(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 371
      MFM3 = MFM1 + R2
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_ADD(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 372
      MFM3 = MFM1 + D2
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_ADD(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 373
      CALL ZM_ST2M('581.21',MZM3)
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_ADD(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MFM1 + C2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 374
      CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_ADD(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MFM1 + CD2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 375
      MFM3 = MFM1 + MFM2
      CALL FM_ADD(MFM1,MFM2,MFM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 376
      MFM3 = MFM1 + MIM1
      CALL FM_ST2M('661',MFM4)
      CALL FM_ADD(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 377
      MZM3 = MFM1 + MZM1
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_ADD(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 378
      MIM3 = MIM1 + J2
      CALL IM_ST2M('131',MIM4)
      CALL IM_ADD(MIM1,MIM4,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 379
      CALL FM_ST2M('241.21',MFM3)
      CALL FM_ST2M('661',MFM4)
      CALL FM_ADD(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = MIM1 + R2
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 380
      CALL FM_ST2M('391.61',MFM3)
      CALL FM_ST2M('661',MFM4)
      CALL FM_ADD(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = MIM1 + D2
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 381
      CALL ZM_ST2M('411.11 + 421.21 i',MZM3)
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_ADD(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MIM1 + C2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 382
      CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_ADD(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MIM1 + CD2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 383
      MFM3 = MIM1 + MFM1
      CALL FM_ST2M('661',MFM4)
      CALL FM_ADD(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 384
      MIM3 = MIM1 + MIM2
      CALL IM_ADD(MIM1,MIM2,MIM4)
      IF (MIM4 /= MIM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 385
      MZM3 = MIM1 + MZM1
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_ADD(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 386
      MZM3 = MZM1 + J2
      CALL ZM_ST2M('131',MZM4)
      CALL ZM_ADD(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 387
      MZM3 = MZM1 + R2
      CALL ZM_ST2M('241.21',MZM4)
      CALL ZM_ADD(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 388
      MZM3 = MZM1 + D2
      CALL ZM_ST2M('391.61',MZM4)
      CALL ZM_ADD(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 389
      MZM3 = MZM1 + C2
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_ADD(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 390
      MZM3 = MZM1 + CD2
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_ADD(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 391
      MZM3 = MZM1 + MFM1
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_ADD(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 392
      MZM3 = MZM1 + MIM1
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_ADD(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 393
      MZM3 = MZM1 + MZM2
      CALL ZM_ADD(MZM1,MZM2,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 394
      MFM3 = +MFM1
      CALL FM_EQ(MFM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 395
      MIM3 = +MIM1
      CALL IM_EQ(MIM1,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 396
      MZM3 = +MZM1
      CALL ZM_EQ(MZM1,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      END SUBROUTINE TEST31

      SUBROUTINE TEST32(NCASE,NERROR,KLOG)

!             Test the '-' arithmetic operator.

      USE FMVALS
      USE FMZM
      USE TEST_VARS
      IMPLICIT NONE

      INTEGER KLOG,NERROR,NCASE

      WRITE (KW,"(/' Testing the derived type - interface.')")

      RSMALL = EPSILON(1.0)*100.0
      DSMALL = EPSILON(1.0D0)*100.0

      NCASE = 397
      MFM3 = J2 - MFM1
      CALL FM_ST2M('131',MFM4)
      CALL FM_SUB(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 398
      MIM3 = J2 - MIM1
      CALL IM_ST2M('131',MIM4)
      CALL IM_SUB(MIM4,MIM1,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 399
      MZM3 = J2 - MZM1
      CALL ZM_ST2M('131',MZM4)
      CALL ZM_SUB(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 400
      MFM3 = R2 - MFM1
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_SUB(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 401
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_ST2M('661',MFM3)
      CALL FM_SUB(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = R2 - MIM1
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 402
      MZM3 = R2 - MZM1
      CALL ZM_ST2M('241.21',MZM4)
      CALL ZM_SUB(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 403
      MFM3 = D2 - MFM1
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_SUB(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 404
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_ST2M('661',MFM3)
      CALL FM_SUB(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = D2 - MIM1
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 405
      MZM3 = D2 - MZM1
      CALL ZM_ST2M('391.61',MZM4)
      CALL ZM_SUB(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 406
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_ST2M('581.21',MZM3)
      CALL ZM_SUB(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = C2 - MFM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 407
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_ST2M('661',MZM3)
      CALL ZM_SUB(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = C2 - MIM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 408
      MZM3 = C2 - MZM1
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_SUB(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 409
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_ST2M('581.21',MZM3)
      CALL ZM_SUB(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = CD2 - MFM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 410
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_ST2M('661',MZM3)
      CALL ZM_SUB(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = CD2 - MIM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 411
      MZM3 = CD2 - MZM1
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_SUB(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 412
      MFM3 = MFM1 - J2
      CALL FM_ST2M('131',MFM4)
      CALL FM_SUB(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 413
      MFM3 = MFM1 - R2
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_SUB(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 414
      MFM3 = MFM1 - D2
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_SUB(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 415
      CALL ZM_ST2M('581.21',MZM3)
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MFM1 - C2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 416
      CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_SUB(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MFM1 - CD2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 417
      MFM3 = MFM1 - MFM2
      CALL FM_SUB(MFM1,MFM2,MFM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 418
      MFM3 = MFM1 - MIM1
      CALL FM_ST2M('661',MFM4)
      CALL FM_SUB(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 419
      MZM3 = MFM1 - MZM1
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_SUB(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 420
      MIM3 = MIM1 - J2
      CALL IM_ST2M('131',MIM4)
      CALL IM_SUB(MIM1,MIM4,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 421
      CALL FM_ST2M('241.21',MFM3)
      CALL FM_ST2M('661',MFM4)
      CALL FM_SUB(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = MIM1 - R2
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 422
      CALL FM_ST2M('391.61',MFM3)
      CALL FM_ST2M('661',MFM4)
      CALL FM_SUB(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = MIM1 - D2
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 423
      CALL ZM_ST2M('411.11 + 421.21 i',MZM3)
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_SUB(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MIM1 - C2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 424
      CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_SUB(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MIM1 - CD2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 425
      MFM3 = MIM1 - MFM1
      CALL FM_ST2M('661',MFM4)
      CALL FM_SUB(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 426
      MIM3 = MIM1 - MIM2
      CALL IM_SUB(MIM1,MIM2,MIM4)
      IF (MIM4 /= MIM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 427
      MZM3 = MIM1 - MZM1
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_SUB(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 428
      MZM3 = MZM1 - J2
      CALL ZM_ST2M('131',MZM4)
      CALL ZM_SUB(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 429
      MZM3 = MZM1 - R2
      CALL ZM_ST2M('241.21',MZM4)
      CALL ZM_SUB(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 430
      MZM3 = MZM1 - D2
      CALL ZM_ST2M('391.61',MZM4)
      CALL ZM_SUB(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 431
      MZM3 = MZM1 - C2
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_SUB(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 432
      MZM3 = MZM1 - CD2
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_SUB(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 433
      MZM3 = MZM1 - MFM1
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_SUB(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 434
      MZM3 = MZM1 - MIM1
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_SUB(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 435
      MZM3 = MZM1 - MZM2
      CALL ZM_SUB(MZM1,MZM2,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 436
      MFM3 = -MFM1
      CALL FM_I2M(0,MFM4)
      CALL FM_SUB(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 437
      MIM3 = -MIM1
      CALL IM_I2M(0,MIM4)
      CALL IM_SUB(MIM4,MIM1,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 438
      MZM3 = -MZM1
      CALL ZM_I2M(0,MZM4)
      CALL ZM_SUB(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      END SUBROUTINE TEST32

      SUBROUTINE TEST33(NCASE,NERROR,KLOG)

!             Test the '*' arithmetic operator.

      USE FMVALS
      USE FMZM
      USE TEST_VARS
      IMPLICIT NONE

      INTEGER KLOG,NERROR,NCASE

      WRITE (KW,"(/' Testing the derived type * interface.')")

      RSMALL = EPSILON(1.0)*100.0
      DSMALL = EPSILON(1.0D0)*100.0

      NCASE = 439
      MFM3 = J2 * MFM1
      CALL FM_ST2M('131',MFM4)
      CALL FM_MPY(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 440
      MIM3 = J2 * MIM1
      CALL IM_ST2M('131',MIM4)
      CALL IM_MPY(MIM4,MIM1,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 441
      MZM3 = J2 * MZM1
      CALL ZM_ST2M('131',MZM4)
      CALL ZM_MPY(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 442
      MFM3 = R2 * MFM1
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_MPY(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 443
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_ST2M('661',MFM3)
      CALL FM_MPY(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = R2 * MIM1
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 444
      MZM3 = R2 * MZM1
      CALL ZM_ST2M('241.21',MZM4)
      CALL ZM_MPY(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 445
      MFM3 = D2 * MFM1
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_MPY(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 446
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_ST2M('661',MFM3)
      CALL FM_MPY(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = D2 * MIM1
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 447
      MZM3 = D2 * MZM1
      CALL ZM_ST2M('391.61',MZM4)
      CALL ZM_MPY(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 448
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_ST2M('581.21',MZM3)
      CALL ZM_MPY(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = C2 * MFM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 449
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_ST2M('661',MZM3)
      CALL ZM_MPY(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = C2 * MIM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 450
      MZM3 = C2 * MZM1
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_MPY(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 451
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_ST2M('581.21',MZM3)
      CALL ZM_MPY(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = CD2 * MFM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 452
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_ST2M('661',MZM3)
      CALL ZM_MPY(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = CD2 * MIM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 453
      MZM3 = CD2 * MZM1
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_MPY(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 454
      MFM3 = MFM1 * J2
      CALL FM_ST2M('131',MFM4)
      CALL FM_MPY(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 455
      MFM3 = MFM1 * R2
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_MPY(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 456
      MFM3 = MFM1 * D2
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_MPY(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 457
      CALL ZM_ST2M('581.21',MZM3)
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_MPY(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MFM1 * C2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 458
      CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_MPY(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MFM1 * CD2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 459
      MFM3 = MFM1 * MFM2
      CALL FM_MPY(MFM1,MFM2,MFM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 460
      MFM3 = MFM1 * MIM1
      CALL FM_ST2M('661',MFM4)
      CALL FM_MPY(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 461
      MZM3 = MFM1 * MZM1
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_MPY(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 462
      MIM3 = MIM1 * J2
      CALL IM_ST2M('131',MIM4)
      CALL IM_MPY(MIM1,MIM4,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 463
      CALL FM_ST2M('241.21',MFM3)
      CALL FM_ST2M('661',MFM4)
      CALL FM_MPY(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = MIM1 * R2
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 464
      CALL FM_ST2M('391.61',MFM3)
      CALL FM_ST2M('661',MFM4)
      CALL FM_MPY(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = MIM1 * D2
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 465
      CALL ZM_ST2M('411.11 + 421.21 i',MZM3)
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_MPY(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MIM1 * C2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 466
      CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_MPY(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MIM1 * CD2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 467
      MFM3 = MIM1 * MFM1
      CALL FM_ST2M('661',MFM4)
      CALL FM_MPY(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 468
      MIM3 = MIM1 * MIM2
      CALL IM_MPY(MIM1,MIM2,MIM4)
      IF (MIM4 /= MIM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 469
      MZM3 = MIM1 * MZM1
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_MPY(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 470
      MZM3 = MZM1 * J2
      CALL ZM_ST2M('131',MZM4)
      CALL ZM_MPY(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 471
      MZM3 = MZM1 * R2
      CALL ZM_ST2M('241.21',MZM4)
      CALL ZM_MPY(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 472
      MZM3 = MZM1 * D2
      CALL ZM_ST2M('391.61',MZM4)
      CALL ZM_MPY(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 473
      MZM3 = MZM1 * C2
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_MPY(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 474
      MZM3 = MZM1 * CD2
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_MPY(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 475
      MZM3 = MZM1 * MFM1
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_MPY(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 476
      MZM3 = MZM1 * MIM1
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_MPY(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 477
      MZM3 = MZM1 * MZM2
      CALL ZM_MPY(MZM1,MZM2,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      END SUBROUTINE TEST33

      SUBROUTINE TEST34(NCASE,NERROR,KLOG)

!             Test the '/' arithmetic operator.

      USE FMVALS
      USE FMZM
      USE TEST_VARS
      IMPLICIT NONE

      INTEGER KLOG,NERROR,NCASE

      WRITE (KW,"(/' Testing the derived type / interface.')")

      RSMALL = EPSILON(1.0)*100.0
      DSMALL = EPSILON(1.0D0)*100.0

      NCASE = 478
      MFM3 = J2 / MFM1
      CALL FM_ST2M('131',MFM4)
      CALL FM_DIV(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 479
      MIM3 = J2 / MIM1
      CALL IM_ST2M('131',MIM4)
      CALL IM_DIV(MIM4,MIM1,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 480
      MZM3 = J2 / MZM1
      CALL ZM_ST2M('131',MZM4)
      CALL ZM_DIV(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 481
      MFM3 = R2 / MFM1
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_DIV(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 482
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_ST2M('661',MFM3)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = R2 / MIM1
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 483
      MZM3 = R2 / MZM1
      CALL ZM_ST2M('241.21',MZM4)
      CALL ZM_DIV(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 484
      MFM3 = D2 / MFM1
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_DIV(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 485
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_ST2M('661',MFM3)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = D2 / MIM1
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 486
      MZM3 = D2 / MZM1
      CALL ZM_ST2M('391.61',MZM4)
      CALL ZM_DIV(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 487
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_ST2M('581.21',MZM3)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = C2 / MFM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 488
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_ST2M('661',MZM3)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = C2 / MIM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 489
      MZM3 = C2 / MZM1
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_DIV(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 490
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_ST2M('581.21',MZM3)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = CD2 / MFM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 491
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_ST2M('661',MZM3)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = CD2 / MIM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 492
      MZM3 = CD2 / MZM1
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_DIV(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 493
      MFM3 = MFM1 / J2
      CALL FM_ST2M('131',MFM4)
      CALL FM_DIV(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 494
      MFM3 = MFM1 / R2
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_DIV(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 495
      MFM3 = MFM1 / D2
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_DIV(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 496
      CALL ZM_ST2M('581.21',MZM3)
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_DIV(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MFM1 / C2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 497
      CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MFM1 / CD2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 498
      MFM3 = MFM1 / MFM2
      CALL FM_DIV(MFM1,MFM2,MFM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 499
      MFM3 = MFM1 / MIM1
      CALL FM_ST2M('661',MFM4)
      CALL FM_DIV(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 500
      MZM3 = MFM1 / MZM1
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_DIV(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 501
      MIM3 = MIM1 / J2
      CALL IM_ST2M('131',MIM4)
      CALL IM_DIV(MIM1,MIM4,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 502
      CALL FM_ST2M('241.21',MFM3)
      CALL FM_ST2M('661',MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = MIM1 / R2
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 503
      CALL FM_ST2M('391.61',MFM3)
      CALL FM_ST2M('661',MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = MIM1 / D2
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 504
      CALL ZM_ST2M('411.11 + 421.21 i',MZM3)
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MIM1 / C2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 505
      CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MIM1 / CD2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 506
      MFM3 = MIM1 / MFM1
      CALL FM_ST2M('661',MFM4)
      CALL FM_DIV(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 507
      MIM3 = MIM1 / MIM2
      CALL IM_DIV(MIM1,MIM2,MIM4)
      IF (MIM4 /= MIM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 508
      MZM3 = MIM1 / MZM1
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_DIV(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 509
      MZM3 = MZM1 / J2
      CALL ZM_ST2M('131',MZM4)
      CALL ZM_DIV(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 510
      MZM3 = MZM1 / R2
      CALL ZM_ST2M('241.21',MZM4)
      CALL ZM_DIV(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 511
      MZM3 = MZM1 / D2
      CALL ZM_ST2M('391.61',MZM4)
      CALL ZM_DIV(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 512
      MZM3 = MZM1 / C2
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_DIV(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 513
      MZM3 = MZM1 / CD2
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_DIV(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 514
      MZM3 = MZM1 / MFM1
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_DIV(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 515
      MZM3 = MZM1 / MIM1
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_DIV(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 516
      MZM3 = MZM1 / MZM2
      CALL ZM_DIV(MZM1,MZM2,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      END SUBROUTINE TEST34

      SUBROUTINE TEST35(NCASE,NERROR,KLOG)

!             Test the '**' arithmetic operator.

      USE FMVALS
      USE FMZM
      USE TEST_VARS
      IMPLICIT NONE

      INTEGER KLOG,NERROR,NCASE

      WRITE (KW,"(/' Testing the derived type ** interface.')")

!             Use a larger error tolerance for large exponents.

      RSMALL = EPSILON(1.0)*10000.0
      DSMALL = EPSILON(1.0D0)*10000.0

      NCASE = 517
      MFM3 = J2 ** MFM1
      CALL FM_ST2M('131',MFM4)
      CALL FM_PWR(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 518
      J4 = 2
      MIM3 = J4 ** MIM1
      CALL IM_ST2M('2',MIM4)
      CALL IM_PWR(MIM4,MIM1,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 519
      MZM3 = J2 ** MZM1
      CALL ZM_ST2M('131',MZM4)
      CALL ZM_PWR(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 520
      MFM3 = R2 ** MFM1
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_PWR(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)


      NCASE = 521
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_ST2M('661',MFM3)
      CALL FM_PWR(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = R2 ** MIM1
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 522
      MZM3 = R2 ** MZM1
      CALL ZM_ST2M('241.21',MZM4)
      CALL ZM_PWR(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 523
      MFM3 = D2 ** MFM1
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_PWR(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 524
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_ST2M('661',MFM3)
      CALL FM_PWR(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = D2 ** MIM1
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 525
      MZM3 = D2 ** MZM1
      CALL ZM_ST2M('391.61',MZM4)
      CALL ZM_PWR(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 526
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_ST2M('581.21',MZM3)
      CALL ZM_PWR(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = C2 ** MFM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 527
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_ST2M('661',MZM3)
      CALL ZM_PWR(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = C2 ** MIM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 528
      MZM3 = C2 ** MZM1
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_PWR(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 529
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_ST2M('581.21',MZM3)
      CALL ZM_PWR(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = CD2 ** MFM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 530
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_ST2M('661',MZM3)
      CALL ZM_PWR(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = CD2 ** MIM1
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 531
      MZM3 = CD2 ** MZM1
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_PWR(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 532
      MFM3 = MFM1 ** J2
      CALL FM_ST2M('131',MFM4)
      CALL FM_PWR(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 533
      MFM3 = MFM1 ** R2
      CALL FM_ST2M('241.21',MFM4)
      CALL FM_PWR(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 534
      MFM3 = MFM1 ** D2
      CALL FM_ST2M('391.61',MFM4)
      CALL FM_PWR(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 535
      CALL ZM_ST2M('581.21',MZM3)
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_PWR(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MFM1 ** C2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 536
      CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_PWR(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MFM1 ** CD2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 537
      MFM3 = MFM1 ** MFM2
      CALL FM_PWR(MFM1,MFM2,MFM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 538
      MFM3 = MFM1 ** MIM1
      CALL FM_ST2M('661',MFM4)
      CALL FM_PWR(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 539
      MZM3 = MFM1 ** MZM1
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_PWR(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 540
      J4 = 17
      MIM3 = MIM1 ** J4
      CALL IM_ST2M('17',MIM4)
      CALL IM_PWR(MIM1,MIM4,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 541
      CALL FM_ST2M('241.21',MFM3)
      CALL FM_ST2M('661',MFM4)
      CALL FM_PWR(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = MIM1 ** R2
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 542
      CALL FM_ST2M('391.61',MFM3)
      CALL FM_ST2M('661',MFM4)
      CALL FM_PWR(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = MIM1 ** D2
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 543
      CALL ZM_ST2M('411.11 + 421.21 i',MZM3)
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_PWR(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MIM1 ** C2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 544
      CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_PWR(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      MZM3 = MIM1 ** CD2
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 545
      MFM3 = MIM1 ** MFM1
      CALL FM_ST2M('661',MFM4)
      CALL FM_PWR(MFM4,MFM1,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 546
      MIM4 = 19
      MIM3 = MIM1 ** MIM4
      CALL IM_PWR(MIM1,MIM4,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      IF (MIM4 /= MIM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 547
      MZM3 = MIM1 ** MZM1
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_PWR(MZM4,MZM1,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 548
      MZM3 = MZM1 ** J2
      CALL ZM_ST2M('131',MZM4)
      CALL ZM_PWR(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 549
      MZM3 = MZM1 ** R2
      CALL ZM_ST2M('241.21',MZM4)
      CALL ZM_PWR(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 550
      MZM3 = MZM1 ** D2
      CALL ZM_ST2M('391.61',MZM4)
      CALL ZM_PWR(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 551
      MZM3 = MZM1 ** C2
      CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
      CALL ZM_PWR(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 552
      MZM3 = MZM1 ** CD2
      CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
      CALL ZM_PWR(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 553
      MZM3 = MZM1 ** MFM1
      CALL ZM_ST2M('581.21',MZM4)
      CALL ZM_PWR(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 554
      MZM3 = MZM1 ** MIM1
      CALL ZM_ST2M('661',MZM4)
      CALL ZM_PWR(MZM1,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 555
      MZM3 = MZM1 ** MZM2
      CALL ZM_PWR(MZM1,MZM2,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      END SUBROUTINE TEST35

      SUBROUTINE TEST36(NCASE,NERROR,KLOG)

!             Test functions ABS, ..., CEILING.

      USE FMVALS
      USE FMZM
      USE TEST_VARS
      IMPLICIT NONE

      INTEGER J,JERR,KLOG,NERROR,NCASE

      WRITE (KW,"(/' Testing the derived type ABS, ..., CEILING interfaces.')")

      NCASE = 556
      MFM3 = ABS(MFM1)
      CALL FM_ABS(MFM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 557
      MIM3 = ABS(MIM1)
      CALL IM_ABS(MIM1,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 558
      MFM3 = ABS(MZM1)
      CALL ZM_ABS(MZM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 559
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = ACOS(MFM4)
      CALL FM_ACOS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 560
      CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
      MZM3 = ACOS(MZM4)
      CALL ZM_ACOS(MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 561
      CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
      MFM3 = AIMAG(MZM4)
      CALL ZM_IMAG(MZM4,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 562
      MFM3 = AINT(MFM1)
      CALL FM_INT(MFM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 563
      MZM3 = AINT(MZM1)
      CALL ZM_INT(MZM1,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 564
      MFM3 = ANINT(MFM1)
      CALL FM_NINT(MFM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 565
      MZM3 = ANINT(MZM1)
      CALL ZM_NINT(MZM1,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 566
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = ASIN(MFM4)
      CALL FM_ASIN(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 567
      CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
      MZM3 = ASIN(MZM4)
      CALL ZM_ASIN(MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 568
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = ATAN(MFM4)
      CALL FM_ATAN(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 569
      CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
      MZM3 = ATAN(MZM4)
      CALL ZM_ATAN(MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 570
      MFM3 = ATAN2(MFM1,MFM2)
      CALL FM_ATN2(MFM1,MFM2,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 571
      JERR = -1
      DO J = 0, 10
         IF (BTEST(661,J)) THEN
             IF (.NOT.BTEST(MIM1,J)) JERR = J
         ELSE
             IF (BTEST(MIM1,J)) JERR = J
         ENDIF
      ENDDO
      IF (JERR >= 0) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 572
      CALL FM_ST2M('12.37654',MFM4)
      MFM3 = CEILING(MFM4)
      CALL FM_ST2M('13',MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 573
      CALL FM_ST2M('-12.7654',MFM4)
      MFM3 = CEILING(MFM4)
      CALL FM_ST2M('-12',MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 574
      CALL ZM_ST2M('12.37654 - 22.54 i',MZM4)
      MZM3 = CEILING(MZM4)
      CALL ZM_ST2M('13 - 22 i',MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 575
      CALL ZM_ST2M('-12.7654 + 22.31 i',MZM4)
      MZM3 = CEILING(MZM4)
      CALL ZM_ST2M('-12 + 23 i',MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      END SUBROUTINE TEST36

      SUBROUTINE TEST37(NCASE,NERROR,KLOG)

!             Test functions CMPLX, ..., EXPONENT.

      USE FMVALS
      USE FMZM
      USE TEST_VARS
      IMPLICIT NONE

      INTEGER J,KLOG,NERROR,NCASE

      WRITE (KW,"(/"//  &
      "' Testing the derived type CMPLX, ..., EXPONENT interfaces.')")

      NCASE = 576
      MZM3 = CMPLX(MFM1,MFM2)
      CALL ZM_CMPX(MFM1,MFM2,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 577
      MZM3 = CMPLX(MIM1,MIM2)
      CALL IM_I2FM(MIM1,MFM3)
      CALL IM_I2FM(MIM2,MFM4)
      CALL ZM_CMPX(MFM3,MFM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 578
      MZM3 = CMPLX(MFM1)
      CALL FM_I2M(0,MFM4)
      CALL ZM_CMPX(MFM1,MFM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 579
      MZM3 = CMPLX(MIM1)
      CALL IM_I2FM(MIM1,MFM3)
      CALL FM_I2M(0,MFM4)
      CALL ZM_CMPX(MFM3,MFM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 580
      MZM3 = CONJG(MZM1)
      CALL ZM_CONJ(MZM1,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 581
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = COS(MFM4)
      CALL FM_COS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 582
      CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
      MZM3 = COS(MZM4)
      CALL ZM_COS(MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 583
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = COSH(MFM4)
      CALL FM_COSH(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 584
      CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
      MZM3 = COSH(MZM4)
      CALL ZM_COSH(MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 585
      MFM3 = DBLE(MFM1)
      CALL FM_EQ(MFM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 586
      MFM3 = DBLE(MIM1)
      CALL IM_I2FM(MIM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 587
      MFM3 = DBLE(MZM1)
      CALL ZM_REAL(MZM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 588
      J = DIGITS(MFM1)
      IF (J /= NDIG) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 589
      J = DIGITS(MIM1)
      IF (J /= NDIGMX) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 590
      J = DIGITS(MZM1)
      IF (J /= NDIG) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 591
      MFM3 = DIM(MFM1,MFM2)
      CALL FM_DIM(MFM1,MFM2,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 592
      MIM3 = DIM(MIM1,MIM2)
      CALL IM_DIM(MIM1,MIM2,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 593
      MFM3 = DINT (MFM1)
      CALL FM_INT(MFM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 594
      MZM3 = DINT (MZM1)
      CALL ZM_INT(MZM1,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 595
      CALL FM_ST2M('1.23',MFMV1(1))
      CALL FM_ST2M('2.23',MFMV1(2))
      CALL FM_ST2M('3.23',MFMV1(3))
      CALL FM_ST2M('4.23',MFMV2(1))
      CALL FM_ST2M('5.23',MFMV2(2))
      CALL FM_ST2M('6.23',MFMV2(3))
      MFM3 = DOTPRODUCT(MFMV1,MFMV2)
      MFM4 = 0
      DO J = 1, 3
         MFM4 = MFM4 + MFMV1(J)*MFMV2(J)
      ENDDO
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 596
      CALL IM_ST2M('12',MIMV1(1))
      CALL IM_ST2M('23',MIMV1(2))
      CALL IM_ST2M('34',MIMV1(3))
      CALL IM_ST2M('-14',MIMV2(1))
      CALL IM_ST2M('-5',MIMV2(2))
      CALL IM_ST2M('16',MIMV2(3))
      MIM3 = DOTPRODUCT(MIMV1,MIMV2)
      MIM4 = 0
      DO J = 1, 3
         MIM4 = MIM4 + MIMV1(J)*MIMV2(J)
      ENDDO
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 597
      CALL ZM_ST2M('1.23 + 1.67 i',MZMV1(1))
      CALL ZM_ST2M('2.23 - 2.56 i',MZMV1(2))
      CALL ZM_ST2M('3.23 + 3.45 i',MZMV1(3))
      CALL ZM_ST2M('4.23 - 4.34 i',MZMV2(1))
      CALL ZM_ST2M('5.23 + 5.23 i',MZMV2(2))
      CALL ZM_ST2M('6.23 - 6.12 i',MZMV2(3))
      MZM3 = DOTPRODUCT(MZMV1,MZMV2)
      MZM4 = 0
      DO J = 1, 3
         MZM4 = MZM4 + MZMV1(J)*MZMV2(J)
      ENDDO
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 598
      MFM3 = EPSILON(MFM1)
      CALL FM_I2M(1,MFM4)
      CALL FM_ULP(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 599
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = EXP(MFM4)
      CALL FM_EXP(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 600
      CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
      MZM3 = EXP(MZM4)
      CALL ZM_EXP(MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 601
      J = EXPONENT(MFM1)
      IF (J /= INT(MFM1%MFM(1))) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      END SUBROUTINE TEST37

      SUBROUTINE TEST38(NCASE,NERROR,KLOG)

!             Test functions FLOOR, ..., MIN.

      USE FMVALS
      USE FMZM
      USE TEST_VARS
      IMPLICIT NONE

      INTEGER I,J,KLOG,NERROR,NCASE

      WRITE (KW,"(/"//  &
      "' Testing the derived type FLOOR, ..., MIN interfaces.')")

      NCASE = 602
      CALL FM_ST2M('12.37654',MFM4)
      MFM3 = FLOOR(MFM4)
      CALL FM_ST2M('12',MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 603
      CALL FM_ST2M('-12.7654',MFM4)
      MFM3 = FLOOR(MFM4)
      CALL FM_ST2M('-13',MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 604
      CALL IM_ST2M('12',MIM4)
      MIM3 = FLOOR(MIM4)
      CALL IM_ST2M('12',MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 605
      CALL IM_ST2M('-123',MIM4)
      MIM3 = FLOOR(MIM4)
      CALL IM_ST2M('-123',MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 606
      CALL ZM_ST2M('12.37654 - 22.54 i',MZM4)
      MZM3 = FLOOR(MZM4)
      CALL ZM_ST2M('12 - 23 i',MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 607
      CALL ZM_ST2M('-12.7654 + 22.31 i',MZM4)
      MZM3 = FLOOR(MZM4)
      CALL ZM_ST2M('-13 + 22 i',MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 608
      CALL FM_ST2M('12.37654',MFM4)
      MFM3 = FRACTION(MFM4)
      MFM4%MFM(1) = 0
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 609
      CALL ZM_ST2M('12.37654 - 22.54',MZM4)
      MZM3 = FRACTION(MZM4)
      MZM4%MZM(1) = 0
      MZM4%MZM(KPTIMU+01) = 0
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 610
      MFM3 = HUGE(MFM1)
      CALL FM_BIG(MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 611
      MIM3 = HUGE(MIM1)
      CALL IM_BIG(MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 612
      MZM3 = HUGE(MZM1)
      CALL FM_BIG(MFM4)
      CALL ZM_CMPX(MFM4,MFM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 613
      MIM3 = INT(MFM1)
      CALL FM_INT(MFM1,MFM4)
      CALL IM_FM2I(MFM4,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 614
      MIM3 = INT(MIM1)
      CALL IM_EQ(MIM1,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 615
      MIM3 = INT(MZM1)
      CALL ZM_INT(MZM1,MZM4)
      CALL ZM_REAL(MZM4,MFM4)
      CALL IM_FM2I(MFM4,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 616
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = LOG(MFM4)
      CALL FM_LN(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 617
      CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
      MZM3 = LOG(MZM4)
      CALL ZM_LN(MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 618
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = LOG10(MFM4)
      CALL FM_LG10(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 619
      CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
      MZM3 = LOG10(MZM4)
      CALL ZM_LG10(MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 620
      DO I = 1, 3
         DO J = 1, 3
            MFMA(I,J) = 3*(J-1) + I
            MFMB(I,J) = 3*(I-1) + J + 10
         ENDDO
      ENDDO
      MFMC = MATMUL(MFMA,MFMB)
      MFM3 = ABS(MFMC(1,1)-186)+ABS(MFMC(1,2)-198)+ABS(MFMC(1,3)-210)+ &
             ABS(MFMC(2,1)-228)+ABS(MFMC(2,2)-243)+ABS(MFMC(2,3)-258)+ &
             ABS(MFMC(3,1)-270)+ABS(MFMC(3,2)-288)+ABS(MFMC(3,3)-306)
      IF (MFM3 /= 0) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 621
      DO I = 1, 2
         DO J = 1, 2
            MIMA(I,J) = 2*(J-1) + I + 20
            MIMB(I,J) = 2*(I-1) + J + 30
         ENDDO
      ENDDO
      MIMC = MATMUL(MIMA,MIMB)
      MIM3 = ABS(MIMC(1,1)-1410) + ABS(MIMC(1,2)-1454) + &
             ABS(MIMC(2,1)-1474) + ABS(MIMC(2,2)-1520)
      IF (MIM3 /= 0) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 622
      DO I = 1, 2
         DO J = 1, 3
            MZMA(I,J) = CMPLX(TO_FM(2*(J-1)+I+10),TO_FM(2*(J-1)+I+20))
         ENDDO
      ENDDO
      DO I = 1, 3
         DO J = 1, 4
            MZMB(I,J) = CMPLX(TO_FM(4*(I-1)+J+50),TO_FM(4*(I-1)+J+30))
         ENDDO
      ENDDO
      MZMC = MATMUL(MZMA,MZMB)
      MFM3 = ABS(MZMC(1,1)-TO_ZM('-270 + 5192 i')) + &
             ABS(MZMC(1,2)-TO_ZM('-300 + 5300 i')) + &
             ABS(MZMC(1,3)-TO_ZM('-330 + 5408 i')) + &
             ABS(MZMC(1,4)-TO_ZM('-360 + 5516 i')) + &
             ABS(MZMC(2,1)-TO_ZM('-210 + 5462 i')) + &
             ABS(MZMC(2,2)-TO_ZM('-240 + 5576 i')) + &
             ABS(MZMC(2,3)-TO_ZM('-270 + 5690 i')) + &
             ABS(MZMC(2,4)-TO_ZM('-300 + 5804 i'))
      IF (MFM3 /= 0) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 623
      MFM3 = MAX(MFM1,MFM2)
      CALL FM_MAX(MFM1,MFM2,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 624
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = MAX(MFM2,MFM1,MFM4)
      CALL FM_MAX(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_MAX(MFM2,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 625
      MIM3 = MAX(MIM1,MIM2)
      CALL IM_MAX(MIM1,MIM2,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 626
      CALL IM_ST2M('7654',MIM4)
      CALL IM_ST2M('-1654',MIM3)
      MIM3 = MAX(MIM2,MIM1,MIM3,MIM4)
      CALL IM_ST2M('7654',MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 627
      J = MAXEXPONENT(MFM1)
      IF (J /= INT(MXEXP)+1) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 628
      MFM3 = MIN(MFM1,MFM2)
      CALL FM_MIN(MFM1,MFM2,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 629
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = MIN(MFM2,MFM1,MFM4)
      CALL FM_MIN(MFM1,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_MIN(MFM2,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 630
      MIM3 = MIN(MIM1,MIM2)
      CALL IM_MIN(MIM1,MIM2,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 631
      CALL IM_ST2M('7654',MIM4)
      CALL IM_ST2M('-1654',MIM3)
      MIM3 = MIN(MIM2,MIM1,MIM3,MIM4)
      CALL IM_ST2M('-1654',MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      END SUBROUTINE TEST38

      SUBROUTINE TEST39(NCASE,NERROR,KLOG)

!             Test functions MINEXPONENT, ..., RRSPACING.

      USE FMVALS
      USE FMZM
      USE TEST_VARS
      IMPLICIT NONE

      INTEGER J,KLOG,NERROR,NCASE

      WRITE (KW,"(/"//  &
      "' Testing the derived type MINEXPONENT, ..., RRSPACING interfaces.')")

      NCASE = 632
      J = MINEXPONENT(MFM1)
      IF (J /= -INT(MXEXP)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 633
      CALL FM_ST2M('8',MFM3)
      CALL FM_ST2M('5',MFM4)
      MFM3 = MOD(MFM3,MFM4)
      CALL FM_ST2M('3',MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 634
      CALL FM_ST2M('-8',MFM3)
      CALL FM_ST2M('5',MFM4)
      MFM3 = MOD(MFM3,MFM4)
      CALL FM_ST2M('-3',MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 635
      CALL FM_ST2M('8',MFM3)
      CALL FM_ST2M('-5',MFM4)
      MFM3 = MOD(MFM3,MFM4)
      CALL FM_ST2M('3',MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 636
      CALL FM_ST2M('-8',MFM3)
      CALL FM_ST2M('-5',MFM4)
      MFM3 = MOD(MFM3,MFM4)
      CALL FM_ST2M('-3',MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 637
      CALL IM_ST2M('8',MIM3)
      CALL IM_ST2M('5',MIM4)
      MIM3 = MOD(MIM3,MIM4)
      CALL IM_ST2M('3',MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 638
      CALL IM_ST2M('-8',MIM3)
      CALL IM_ST2M('5',MIM4)
      MIM3 = MOD(MIM3,MIM4)
      CALL IM_ST2M('-3',MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 639
      CALL IM_ST2M('8',MIM3)
      CALL IM_ST2M('-5',MIM4)
      MIM3 = MOD(MIM3,MIM4)
      CALL IM_ST2M('3',MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 640
      CALL IM_ST2M('-8',MIM3)
      CALL IM_ST2M('-5',MIM4)
      MIM3 = MOD(MIM3,MIM4)
      CALL IM_ST2M('-3',MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 641
      CALL FM_ST2M('8',MFM3)
      CALL FM_ST2M('5',MFM4)
      MFM3 = MODULO(MFM3,MFM4)
      CALL FM_ST2M('3',MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 642
      CALL FM_ST2M('-8',MFM3)
      CALL FM_ST2M('5',MFM4)
      MFM3 = MODULO(MFM3,MFM4)
      CALL FM_ST2M('2',MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 643
      CALL FM_ST2M('8',MFM3)
      CALL FM_ST2M('-5',MFM4)
      MFM3 = MODULO(MFM3,MFM4)
      CALL FM_ST2M('-2',MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 644
      CALL FM_ST2M('-8',MFM3)
      CALL FM_ST2M('-5',MFM4)
      MFM3 = MODULO(MFM3,MFM4)
      CALL FM_ST2M('-3',MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 645
      CALL IM_ST2M('8',MIM3)
      CALL IM_ST2M('5',MIM4)
      MIM3 = MODULO(MIM3,MIM4)
      CALL IM_ST2M('3',MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 646
      CALL IM_ST2M('-8',MIM3)
      CALL IM_ST2M('5',MIM4)
      MIM3 = MODULO(MIM3,MIM4)
      CALL IM_ST2M('2',MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 647
      CALL IM_ST2M('8',MIM3)
      CALL IM_ST2M('-5',MIM4)
      MIM3 = MODULO(MIM3,MIM4)
      CALL IM_ST2M('-2',MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 648
      CALL IM_ST2M('-8',MIM3)
      CALL IM_ST2M('-5',MIM4)
      MIM3 = MODULO(MIM3,MIM4)
      CALL IM_ST2M('-3',MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 649
      CALL FM_ST2M('0',MFM4)
      CALL FM_ST2M('1',MFM3)
      CALL FM_BIG(MFM5)
      CALL FM_DIV(MFM3,MFM5,MFM6)
      CALL FM_EQ(MFM6,MFM5)
      MFM3 = NEAREST(MFM4,MFM3)
      IF (MFM3 /= MFM5) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 650
      CALL FM_ST2M('0',MFM4)
      CALL FM_ST2M('-1',MFM3)
      CALL FM_BIG(MFM5)
      CALL FM_DIV(MFM3,MFM5,MFM6)
      CALL FM_EQ(MFM6,MFM5)
      MFM3 = NEAREST(MFM4,MFM3)
      IF (MFM3 /= MFM5) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 651
      CALL FM_ST2M('2.345',MFM4)
      CALL FM_ST2M('1',MFM3)
      MFM3 = NEAREST(MFM4,MFM3)
      CALL FM_ULP(MFM4,MFM5)
      CALL FM_ADD(MFM4,MFM5,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 652
      CALL FM_ST2M('2.345',MFM4)
      CALL FM_ST2M('-1',MFM3)
      MFM3 = NEAREST(MFM4,MFM3)
      CALL FM_ULP(MFM4,MFM5)
      CALL FM_SUB(MFM4,MFM5,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 653
      CALL FM_ST2M('1',MFM4)
      CALL FM_ST2M('-1',MFM3)
      MFM3 = NEAREST(MFM4,MFM3)
      CALL FM_ST2M('0.99',MFM5)
      CALL FM_ULP(MFM5,MFM6)
      CALL FM_EQ(MFM6,MFM5)
      CALL FM_SUB(MFM4,MFM5,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 654
      CALL FM_ST2M('-1',MFM4)
      CALL FM_ST2M('12',MFM3)
      MFM3 = NEAREST(MFM4,MFM3)
      CALL FM_ST2M('-0.99',MFM5)
      CALL FM_ULP(MFM5,MFM6)
      CALL FM_EQ(MFM6,MFM5)
      CALL FM_SUB(MFM4,MFM5,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 655
      MIM3 = NINT(MFM1)
      CALL FM_NINT(MFM1,MFM4)
      CALL IM_FM2I(MFM4,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 656
      MIM3 = NINT(MIM1)
      CALL IM_EQ(MIM1,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 657
      MIM3 = NINT(MZM1)
      CALL ZM_NINT(MZM1,MZM4)
      CALL ZM_REAL(MZM4,MFM4)
      CALL IM_FM2I(MFM4,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 658
      J = PRECISION(MFM1)
      IF (J /= INT(LOG10(REAL(MBASE))*(NDIG-1) + 1)) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 659
      J = PRECISION(MZM1)
      IF (J /= INT(LOG10(REAL(MBASE))*(NDIG-1) + 1)) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 660
      J = RADIX(MFM1)
      IF (J /= INT(MBASE)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 661
      J = RADIX(MIM1)
      IF (J /= INT(MBASE)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 662
      J = RADIX(MZM1)
      IF (J /= INT(MBASE)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 663
      J = RANGE(MFM1)
      IF (J /= INT(MXEXP*LOG10(REAL(MBASE)))) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 664
      J = RANGE(MIM1)
      IF (J /= INT(NDIGMX*LOG10(REAL(MBASE)))) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 665
      J = RANGE(MZM1)
      IF (J /= INT(MXEXP*LOG10(REAL(MBASE)))) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 666
      MFM3 = REAL(MFM1)
      CALL FM_EQ(MFM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 667
      MFM3 = REAL(MIM1)
      CALL IM_I2FM(MIM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 668
      MFM3 = REAL(MZM1)
      CALL ZM_REAL(MZM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 669
      MFM3 = RRSPACING(MFM1)
      CALL FM_ABS(MFM1,MFM4)
      MFM4%MFM(1) = NDIG
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      END SUBROUTINE TEST39

      SUBROUTINE TEST40(NCASE,NERROR,KLOG)

!             Test functions SCALE, ..., TINY.

      USE FMVALS
      USE FMZM
      USE TEST_VARS
      IMPLICIT NONE

      INTEGER KLOG,NERROR,NCASE

      WRITE (KW,"(/"//  &
      "' Testing the derived type SCALE, ..., TINY interfaces.')")

      NCASE = 670
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = SCALE(MFM4,1)
      CALL FM_MPYI(MFM4,INT(MBASE),MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 671
      CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
      MZM3 = SCALE(MZM4,-2)
      CALL ZM_DIVI(MZM4,INT(MBASE),MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIVI(MZM4,INT(MBASE),MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 672
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = SETEXPONENT(MFM4,1)
      CALL FM_MPYI(MFM4,INT(MBASE),MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 673
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = SIGN(MFM4,MFM2)
      CALL FM_SIGN(MFM4,MFM2,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 674
      CALL IM_ST2M('231',MIM4)
      MIM3 = SIGN(MIM4,MIM2)
      CALL IM_SIGN(MIM4,MIM2,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 675
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = SIN(MFM4)
      CALL FM_SIN(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 676
      CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
      MZM3 = SIN(MZM4)
      CALL ZM_SIN(MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 677
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = SINH(MFM4)
      CALL FM_SINH(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 678
      CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
      MZM3 = SINH(MZM4)
      CALL ZM_SINH(MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 679
      CALL FM_ST2M('-0.7654',MFM4)
      MFM3 = SPACING(MFM4)
      CALL FM_ULP(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 680
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = SQRT(MFM4)
      CALL FM_SQRT(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 681
      CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
      MZM3 = SQRT(MZM4)
      CALL ZM_SQRT(MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 682
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = TAN(MFM4)
      CALL FM_TAN(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 683
      CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
      MZM3 = TAN(MZM4)
      CALL ZM_TAN(MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 684
      CALL FM_ST2M('0.7654',MFM4)
      MFM3 = TANH(MFM4)
      CALL FM_TANH(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 685
      CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
      MZM3 = TANH(MZM4)
      CALL ZM_TANH(MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 686
      CALL FM_BIG(MFM4)
      CALL FM_I2M(1,MFM3)
      CALL FM_DIV(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = TINY(MFM1)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 687
      MIM3 = TINY(MIM1)
      CALL IM_I2M(1,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 688
      CALL FM_BIG(MFM4)
      CALL FM_I2M(1,MFM3)
      CALL FM_DIV(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL ZM_CMPX(MFM4,MFM4,MZM4)
      MZM3 = TINY(MZM1)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      END SUBROUTINE TEST40

      SUBROUTINE TEST41(NCASE,NERROR,KLOG)

!             Test functions TO_FM, TO_IM, TO_ZM, ..., TO_DPZ.

      USE FMVALS
      USE FMZM
      USE TEST_VARS
      IMPLICIT NONE

      INTEGER KLOG,NERROR,NCASE
      LOGICAL FM_COMP

      WRITE (KW,"(/"//  &
      "' Testing the derived type TO_FM,  ..., TO_DPZ interfaces.')")

      RSMALL = EPSILON(1.0)*100.0
      DSMALL = EPSILON(1.0D0)*100.0

      NCASE = 689
      MFM3 = TO_FM(123)
      CALL FM_I2M(123,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 690
      MFM3 = TO_FM(123.4)
      CALL FM_SP2M(123.4,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = RSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 691
      MFM3 = TO_FM(123.45D0)
      CALL FM_DP2M(123.45D0,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = DSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)


      NCASE = 692
      MFM3 = TO_FM(CMPLX(123.4,567.8))
      CALL FM_SP2M(123.4,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = RSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 693
      MFM3 = TO_FM(CMPLX(123.4D0,567.8D0,KIND(1.0D0)))
      CALL FM_DP2M(123.4D0,MFM4)
      CALL FM_SUB(MFM3,MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_DIV(MFM4,MFM3,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      CALL FM_ABS(MFM4,MFM6)
      CALL FM_EQ(MFM6,MFM4)
      MFM3 = DSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 694
      MFM3 = TO_FM(MFM1)
      CALL FM_EQ(MFM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 695
      MFM3 = TO_FM(MIM1)
      CALL IM_I2FM(MIM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 696
      MFM3 = TO_FM(MZM1)
      CALL ZM_REAL(MZM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 697
      MFM3 = TO_FM('-123.654')
      CALL FM_ST2M('-123.654',MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 698
      MIM3 = TO_IM(123)
      CALL IM_I2M(123,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 699
      MIM3 = TO_IM(123.4)
      CALL FM_SP2M(123.4,MFM4)
      CALL IM_FM2I(MFM4,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 700
      MIM3 = TO_IM(123.45D0)
      CALL FM_DP2M(123.45D0,MFM4)
      CALL IM_FM2I(MFM4,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 701
      MIM3 = TO_IM(CMPLX(123.4,567.8))
      CALL FM_SP2M(123.4,MFM4)
      CALL IM_FM2I(MFM4,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 702
      MIM3 = TO_IM(CMPLX(123.4D0,567.8D0,KIND(1.0D0)))
      CALL FM_DP2M(123.4D0,MFM4)
      CALL IM_FM2I(MFM4,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 703
      MIM3 = TO_IM(MFM1)
      CALL FM_EQ(MFM1,MFM4)
      CALL IM_FM2I(MFM4,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 704
      MIM3 = TO_IM(MIM1)
      CALL IM_I2FM(MIM1,MFM4)
      CALL IM_FM2I(MFM4,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 705
      MIM3 = TO_IM(MZM1)
      CALL ZM_REAL(MZM1,MFM4)
      CALL IM_FM2I(MFM4,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 706
      MIM3 = TO_IM('-123654')
      CALL IM_ST2M('-123654',MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 707
      MZM3 = TO_ZM(123)
      CALL ZM_I2M(123,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 708
      MZM3 = TO_ZM(123.4)
      CALL FM_SP2M(123.4,MFM4)
      CALL FM_I2M(0,MFM5)
      CALL ZM_CMPX(MFM4,MFM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      MFM3 = RSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 709
      MZM3 = TO_ZM(123.45D0)
      CALL FM_DP2M(123.45D0,MFM4)
      CALL FM_I2M(0,MFM5)
      CALL ZM_CMPX(MFM4,MFM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      MFM3 = DSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 710
      MZM3 = TO_ZM(CMPLX(123.4,567.8))
      CALL FM_SP2M(123.4,MFM4)
      CALL FM_SP2M(567.8,MFM5)
      CALL ZM_CMPX(MFM4,MFM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      MFM3 = RSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 711
      MZM3 = TO_ZM(CMPLX(123.4D0,567.8D0,KIND(1.0D0)))
      CALL FM_DP2M(123.4D0,MFM4)
      CALL FM_DP2M(567.8D0,MFM5)
      CALL ZM_CMPX(MFM4,MFM5,MZM4)
      CALL ZM_SUB(MZM3,MZM4,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_DIV(MZM4,MZM3,MZM5)
      CALL ZM_EQ(MZM5,MZM4)
      CALL ZM_ABS(MZM4,MFM4)
      MFM3 = DSMALL
      IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 712
      MZM3 = TO_ZM(MFM1)
      CALL FM_EQ(MFM1,MFM4)
      CALL FM_I2M(0,MFM5)
      CALL ZM_CMPX(MFM4,MFM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 713
      MZM3 = TO_ZM(MIM1)
      CALL IM_I2FM(MIM1,MFM4)
      CALL FM_I2M(0,MFM5)
      CALL ZM_CMPX(MFM4,MFM5,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 714
      MZM3 = TO_ZM(MZM1)
      CALL ZM_EQ(MZM1,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 715
      MZM3 = TO_ZM('-123.654 + 98.7 i')
      CALL ZM_ST2M('-123.654 + 98.7 i',MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 716
      CALL FM_M2I(MFM1,J3)
      IF (TO_INT(MFM1) /= J3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 717
      CALL IM_M2I(MIM1,J3)
      IF (TO_INT(MIM1) /= J3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 718
      CALL ZM_M2I(MZM1,J3)
      IF (TO_INT(MZM1) /= J3) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 719
      CALL FM_M2SP(MFM1,R3)
      IF (ABS((TO_SP(MFM1)-R3)/R3) > RSMALL) THEN
          CALL PRTERR(KW,KLOG,NCASE,NERROR)
      ENDIF

      NCASE = 720
      CALL IM_M2DP(MIM1,D3)
      R3 = D3
      IF (ABS((TO_SP(MIM1)-R3)/R3) > RSMALL) THEN
          CALL PRTERR(KW,KLOG,NCASE,NERROR)
      ENDIF

      NCASE = 721
      CALL ZM_REAL(MZM1,MFM4)
      CALL FM_M2SP(MFM4,R3)
      IF (ABS((TO_SP(MZM1)-R3)/R3) > RSMALL) THEN
          CALL PRTERR(KW,KLOG,NCASE,NERROR)
      ENDIF

      NCASE = 722
      CALL FM_M2DP(MFM1,D3)
      IF (ABS((TO_DP(MFM1)-D3)/D3) > DSMALL) THEN
          CALL PRTERR(KW,KLOG,NCASE,NERROR)
      ENDIF

      NCASE = 723
      CALL IM_M2DP(MIM1,D3)
      IF (ABS((TO_DP(MIM1)-D3)/D3) > DSMALL) THEN
          CALL PRTERR(KW,KLOG,NCASE,NERROR)
      ENDIF

      NCASE = 724
      CALL ZM_REAL(MZM1,MFM4)
      CALL FM_M2DP(MFM4,D3)
      IF (ABS((TO_DP(MZM1)-D3)/D3) > DSMALL) THEN
          CALL PRTERR(KW,KLOG,NCASE,NERROR)
      ENDIF

      NCASE = 725
      CALL FM_M2SP(MFM1,R3)
      C3 = R3
      IF (ABS((TO_SPZ(MFM1)-C3)/C3) > RSMALL) THEN
          CALL PRTERR(KW,KLOG,NCASE,NERROR)
      ENDIF

      NCASE = 726
      CALL IM_M2DP(MIM1,D3)
      C3 = D3
      IF (ABS((TO_SPZ(MIM1)-C3)/C3) > RSMALL) THEN
          CALL PRTERR(KW,KLOG,NCASE,NERROR)
      ENDIF

      NCASE = 727
      CALL ZM_M2Z(MZM1,C3)
      IF (ABS((TO_SPZ(MZM1)-C3)/C3) > RSMALL) THEN
          CALL PRTERR(KW,KLOG,NCASE,NERROR)
      ENDIF

      NCASE = 728
      CALL FM_M2DP(MFM1,D3)
      CD3 = D3
      IF (ABS((TO_DPZ(MFM1)-CD3)/CD3) > DSMALL) THEN
          CALL PRTERR(KW,KLOG,NCASE,NERROR)
      ENDIF

      NCASE = 729
      CALL IM_M2DP(MIM1,D3)
      CD3 = D3
      IF (ABS((TO_DPZ(MIM1)-CD3)/CD3) > DSMALL) THEN
          CALL PRTERR(KW,KLOG,NCASE,NERROR)
      ENDIF

      NCASE = 730
      CALL ZM_REAL(MZM1,MFM4)
      CALL FM_M2DP(MFM4,D3)
      CALL ZM_IMAG(MZM1,MFM4)
      CALL FM_M2DP(MFM4,D4)
      CD3 = CMPLX( D3 , D4 , KIND(0.0D0) )
      IF (ABS((TO_DPZ(MZM1)-CD3)/CD3) > DSMALL) THEN
          CALL PRTERR(KW,KLOG,NCASE,NERROR)
      ENDIF

      END SUBROUTINE TEST41

      SUBROUTINE TEST42(NCASE,NERROR,KLOG)

!             Test the derived-type interface routines that are not
!             used elsewhere in this program.

      USE FMVALS
      USE FMZM
      USE TEST_VARS
      IMPLICIT NONE

      CHARACTER(80) :: STRING
      INTEGER KLOG,NERROR,NCASE

      WRITE (KW,"(/"//  &
      "' Testing the derived type ADDI, ..., Z2M interfaces.')")

      RSMALL = EPSILON(1.0)*100.0
      DSMALL = EPSILON(1.0D0)*100.0
      MSMALL = EPSILON(TO_FM(1))*10000.0

      NCASE = 731
      MFM3 = MFM1 + 123
      MFM4 = MFM1
      CALL FM_ADDI(MFM4,123)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 732
      CALL FM_CHSH(MFM1,MFM4,MFM3)
      MFM3 = COSH(MFM1)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 733
      CALL FM_CHSH(MFM1,MFM3,MFM4)
      MFM3 = SINH(MFM1)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 734
      CALL FM_CSSN(MFM1,MFM4,MFM3)
      MFM3 = COS(MFM1)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 735
      CALL FM_CSSN(MFM1,MFM3,MFM4)
      MFM3 = SIN(MFM1)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 736
      MFM3 = MFM1 / 123
      CALL FM_DIVI(MFM1,123,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 737
      MFM3 = 123.45D0
      CALL FM_DPM(123.45D0,MFM4)
      IF (ABS((MFM3-MFM4)/MFM4) > DSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 738
      CALL FM_FORM('F70.56',MFM1,STRING)
      CALL FM_ST2M(STRING(1:70),MFM4)
      IF (ABS((MFM1-MFM4)/MFM4) > MSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 739
      STRING = FM_FORMAT('F70.56',MFM1)
      CALL FM_ST2M(STRING(1:70),MFM4)
      IF (ABS((MFM1-MFM4)/MFM4) > MSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 740
      MFM3 = MFM1 ** 123
      CALL FM_IPWR(MFM1,123,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 741
      MFM3 = LOG(TO_FM(123))
      CALL FM_LNI(123,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 742
      D4 = MFM1
      CALL FM_M2DP(MFM1,D5)
      IF (ABS((D4-D5)/D4) > DSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 743
      J4 = MFM1
      CALL FM_M2I(MFM1,J5)
      IF (J4 /= J5) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 744
      R4 = MFM1
      CALL FM_M2SP(MFM1,R5)
      IF (ABS((R4-R5)/R4) > RSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 745
      MFM3 = 2.67
      CALL FM_MOD(MFM1,MFM3,MFM4)
      MFM3 = MOD(MFM1,MFM3)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 746
      CALL FM_PI(MFM4)
      MFM3 = 4*ATAN(TO_FM(1))
      IF (ABS((MFM3-MFM4)/MFM4) > MSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 747
      MFM3 = MFM1 ** (TO_FM(1)/TO_FM(3))
      CALL FM_RPWR(MFM1,1,3,MFM4)
      IF (ABS((MFM3-MFM4)/MFM4) > MSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 748
      CALL FM_SQR(MFM1,MFM4)
      MFM3 = MFM1*MFM1
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 749
      MIM3 = MIM1 / 13
      CALL IM_DIVI(MIM1,13,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 750
      MIM3 = 13
      CALL IM_DIVR(MIM1,MIM3,MIM5,MIM4)
      MIM3 = MOD(MIM1,MIM3)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 751
      MIM3 = 13
      CALL IM_DIVR(MIM1,MIM3,MIM5,MIM4)
      CALL IM_EQ(MIM5,MIM3)
      MIM4 = MIM1 / 13
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 752
      MIM3 = MIM1 / 13
      CALL IM_DVIR(MIM1,13,MIM4,J5)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 753
      J4 = MOD(MIM1,TO_IM(13))
      CALL IM_DVIR(MIM1,13,MIM4,J5)
      IF (J4 /= J5) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 754
      CALL IM_FORM('I70',MIM1,STRING)
      CALL IM_ST2M(STRING(1:70),MIM4)
      IF (MIM1 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 755
      STRING = IM_FORMAT('I70',MIM1)
      CALL IM_ST2M(STRING(1:70),MIM4)
      IF (MIM1 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 756
      MIM3 = 40833
      MIM4 = 16042
      CALL IM_GCD(MIM3,MIM4,MIM5)
      CALL IM_EQ(MIM5,MIM4)
      IF (MIM4 /= 13) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 757
      MIM3 = 40833
      MIM4 = 16042
      MIM4 = GCD(MIM3,MIM4)
      IF (MIM4 /= 13) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 758
      D4 = MIM1
      CALL IM_M2DP(MIM1,D5)
      IF (ABS((D4-D5)/D4) > DSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 759
      J4 = MIM1
      CALL IM_M2I(MIM1,J5)
      IF (J4 /= J5) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 760
      MIM3 = 6
      CALL IM_MOD(MIM1,MIM3,MIM4)
      MIM3 = MOD(MIM1,MIM3)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 761
      MIM3 = MIM1 * 123
      CALL IM_MPYI(MIM1,123,MIM4)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 762
      MIM2 = 3141
      MIM3 = 133
      CALL IM_MPYM(MIM1,MIM2,MIM3,MIM4)
      MIM3 = MOD(MIM1*MIM2,MIM3)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 763
      MIM2 = 3141
      MIM3 = 133
      MIM4 = MULTIPLY_MOD(MIM1,MIM2,MIM3)
      MIM3 = MOD(MIM1*MIM2,MIM3)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 764
      MIM2 = 31
      MIM3 = 147
      CALL IM_PMOD(MIM1,MIM2,MIM3,MIM4)
      MIM3 = MOD(MIM1**MIM2,MIM3)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 765
      MIM2 = 31
      MIM3 = 147
      MIM4 = POWER_MOD(MIM1,MIM2,MIM3)
      MIM3 = MOD(MIM1**MIM2,MIM3)
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 766
      CALL IM_SQR(MIM1,MIM4)
      MIM3 = MIM1*MIM1
      IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 767
      MZM3 = MZM1 + 123
      MZM4 = MZM1
      CALL ZM_ADDI(MZM4,123)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 768
      MFM3 = ATAN2(AIMAG(MZM1),REAL(MZM1))
      CALL ZM_ARG(MZM1,MFM4)
      IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 769
      CALL ZM_CHSH(MZM1,MZM4,MZM3)
      MZM3 = COSH(MZM1)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 770
      CALL ZM_CHSH(MZM1,MZM3,MZM4)
      MZM3 = SINH(MZM1)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 771
      CALL ZM_CSSN(MZM1,MZM4,MZM3)
      MZM3 = COS(MZM1)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 772
      CALL ZM_CSSN(MZM1,MZM3,MZM4)
      MZM3 = SIN(MZM1)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 773
      CALL ZM_FORM('F35.26','F35.26',MZM1,STRING)
      CALL ZM_ST2M(STRING(1:75),MZM4)
      IF (ABS((MZM1-MZM4)/MZM4) > MSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 774
      STRING = ZM_FORMAT('F35.26','F35.26',MZM1)
      CALL ZM_ST2M(STRING(1:75),MZM4)
      IF (ABS((MZM1-MZM4)/MZM4) > MSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 775
      MZM3 = TO_ZM('123-456i')
      CALL ZM_2I2M(123,-456,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 776
      MZM3 = MZM1 ** 123
      CALL ZM_IPWR(MZM1,123,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 777
      J4 = MZM1
      CALL ZM_M2I(MZM1,J5)
      IF (J4 /= J5) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 778
      C4 = MZM1
      CALL ZM_M2Z(MZM1,C5)
      IF (ABS((C4-C5)/C4) > RSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 779
      MZM3 = MZM1 * 123
      CALL ZM_MPYI(MZM1,123,MZM4)
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 780
      MZM3 = MZM1 ** (TO_ZM(1)/TO_ZM(3))
      CALL ZM_RPWR(MZM1,1,3,MZM4)
      IF (ABS((MZM3-MZM4)/MZM4) > MSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 781
      CALL ZM_SQR(MZM1,MZM4)
      MZM3 = MZM1*MZM1
      IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)

      NCASE = 782
      MZM3 = C2
      CALL ZM_Z2M(C2,MZM4)
      IF (ABS((MZM3-MZM4)/MZM3) > RSMALL) &
          CALL PRTERR(KW,KLOG,NCASE,NERROR)

      END SUBROUTINE TEST42

      SUBROUTINE TEST43(NCASE,NERROR,KLOG)

!  Test Bernoulli numbers, Pochhammer's function, Euler's constant.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      INTEGER KLOG,NCASE,NERROR,NDGSAV

      WRITE (KW,"(/' Testing Bernoulli, Pochhammer, Euler.')")

      NCASE = 783
      M_A = 1
      CALL FM_BERN(10,M_A,M_C)
      M_D = TO_FM('7.5757575757575757575757575757575757575757575757575758M-2')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 784
      M_A = 1
      CALL FM_BERN(0,M_A,M_C)
      M_D = TO_FM('1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 785
      M_A = 1
      CALL FM_BERN(1,M_A,M_C)
      M_D = TO_FM('-0.5')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 786
      M_A = 1
      CALL FM_BERN(41,M_A,M_C)
      M_D = TO_FM('0')
      M_D = ABS(M_C - M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 787
      M_A = 0
      CALL FM_BERN(52,M_A,M_C)
      M_D = TO_FM('0')
      M_D = ABS(M_C - M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 788
      M_A = TO_FM('.7699115044247787610619469026548672566371681415929204')
      CALL FM_BERN(102,M_A,M_C)
      M_D = TO_FM('5.7022917356035929245914353639470138260075545712953255M+80')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 789
      M_A = TO_FM('.7699115044247787610619469026548672566371681415929204')
      CALL FM_BERN(76,M_A,M_C)
      M_D = TO_FM('-6.3274121765674850311763600458139008604123253720098077M+50')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 790
      M_A = TO_FM('.7699115044247787610619469026548672566371681415929204')
      M_C = BERNOULLI(76)*M_A
      M_D = TO_FM('-6.3274121765674850311763600458139008604123253720098077M+50')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 791
      M_A = TO_FM('769.9115044247787610619469026548672566371681415929204')
      CALL FM_POCH(M_A,10,M_C)
      M_D = TO_FM('7.7568981408767238023000514593534249181767332686451635M+28')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 792
      M_A = TO_FM('7699.115044247787610619469026548672566371681415929204')
      CALL FM_POCH(M_A,2222,M_C)
      M_D = TO_FM('1.3306321985792900130409652455318897459921360351317942M+8763')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 793
      M_A = TO_FM('-7')
      CALL FM_POCH(M_A,12,M_C)
      M_D = TO_FM('0')
      M_D = ABS(M_C - M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 794
      M_A = TO_FM('7.7568981408767238023000514593534249181767332686451635M+281')
      CALL FM_POCH(M_A,6,M_C)
      M_D = TO_FM('2.1783543710019819738631136312604490177244818356538937M+1691')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 795
      M_A = TO_FM('7.7568981408767238023000514593534249181767332686451635M-281')
      CALL FM_POCH(M_A,8,M_C)
      M_D = TO_FM('3.9094766630018687963592259355141261587610735673971624M-277')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 796
      M_A = TO_FM('7.7568981408767238023000514593534249181767332686451635M-281')
      CALL FM_POCH(M_A,1,M_C)
      M_D = TO_FM('7.7568981408767238023000514593534249181767332686451635M-281')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 797
      M_A = TO_FM('7.7568981408767238023000514593534249181767332686451635M-281')
      CALL FM_POCH(M_A,0,M_C)
      M_D = TO_FM('1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 798
      M_A = TO_FM('0')
      CALL FM_POCH(M_A,8,M_C)
      M_D = TO_FM('0')
      M_D = ABS(M_C - M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 799
      M_A = TO_FM('769.9115044247787610619469026548672566371681415929204')
      M_C = POCHHAMMER(M_A,10)
      M_D = TO_FM('7.7568981408767238023000514593534249181767332686451635M+28')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 800
      CALL FM_EULR(M_C)
      M_D = TO_FM('.5772156649015328606065120900824024310421593359399236')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' EULR ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 801
      NDGSAV = NDIG
      NDIG = MIN(NDIGMX,INT(1785*DLOGTN/DLOGMB)+2)
      CALL FM_EULR(M_C)
      M_D = TO_FM(  &
      ' .5772156649015328606065120900824024310421593359399235988057672348848677267'// &
      '776646709369470632917467495146314472498070824809605040144865428362241739976'// &
      '449235362535003337429373377376739427925952582470949160087352039481656708532'// &
      '331517766115286211995015079847937450857057400299213547861466940296043254215'// &
      '190587755352673313992540129674205137541395491116851028079842348775872050384'// &
      '310939973613725530608893312676001724795378367592713515772261027349291394079'// &
      '843010341777177808815495706610750101619166334015227893586796549725203621287'// &
      '922655595366962817638879272680132431010476505963703947394957638906572967929'// &
      '601009015125195950922243501409349871228247949747195646976318506676129063811'// &
      '051824197444867836380861749455169892792301877391072945781554316005002182844'// &
      '096053772434203285478367015177394398700302370339518328690001558193988042707'// &
      '411542227819716523011073565833967348717650491941812300040654693142999297779'// &
      '569303100503086303418569803231083691640025892970890985486825777364288253954'// &
      '925873629596133298574739302373438847070370284412920166417850248733379080562'// &
      '754998434590761643167103146710722370021810745044418664759134803669025532458'// &
      '625442225345181387912434573501361297782278288148945909863846006293169471887'// &
      '149587525492366493520473243641097268276160877595088095126208404544477992299'// &
      '157248292516251278427659657083214610298214617951957959095922704208989627971'// &
      '255363217948873764210660607065982561990102880756125199137511678217643619057'// &
      '058440783573501580056077457934213144988500786415171615194565706170432450750'// &
      '081687052307890937046143066848179164968425491504967243121837838753564894950'// &
      '868454102340601622508515583867234944187880440940770106883795111307872023426'// &
      '395226920971608856908382511378712836820491178925944784861991185293910293099'// &
      '059255266917274468920443869711147174571574573203935209122316085086828')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= MAX(TO_FM('1.0E-1785'),10*EPSILON(M_C)))) THEN
          CALL ERRPRT_FM(' EULR ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF
      NDIG = NDGSAV

      RETURN
      END SUBROUTINE TEST43

      SUBROUTINE TEST44(NCASE,NERROR,KLOG)

!  Test Gamma, Factorial, Log(Gamma), Beta, Binomial.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing Gamma, Factorial, Log(Gamma), Beta, Binomial.')")

      NCASE = 802
      M_A = 19
      CALL FM_GAM(M_A,M_C)
      M_D = TO_FM('6.402373705728M+15')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM('  GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 803
      M_A = TO_FM('.7699115044247787610619469026548672566371681415929204')
      CALL FM_GAM(M_A,M_C)
      M_D = TO_FM('1.1998023858495967876496039855917100290498970370440326')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM('  GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 804
      M_A = TO_FM('.7699115044247787610619469026548672566371681415929204')
      CALL FM_GAM(M_A,M_C)
      M_D = TO_FM('1.1998023858495967876496039855917100290498970370440326')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM('  GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 805
      M_A = TO_FM('5.7699115044247787610619469026548672566371681415929204')
      CALL FM_GAM(M_A,M_C)
      M_D = TO_FM('8.1434691207877806133071511233406796488474685081500979M+1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM('  GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 806
      M_A = TO_FM('7.7568981408767238023000514593534249181767332686451635M-281')
      CALL FM_GAM(M_A,M_C)
      M_D = TO_FM('1.2891751081921193691625844770542239587773115818085396M+280')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM('  GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 807
      M_A = TO_FM('2')
      CALL FM_GAM(M_A,M_C)
      M_D = TO_FM('1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM('  GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 808
      M_A = TO_FM('5.7699115044247787610619469026548672566371681415929204')
      M_C = GAMMA(M_A)
      M_D = TO_FM('8.1434691207877806133071511233406796488474685081500979M+1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM('  GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 809
      M_A = 33
      CALL FM_FACT(M_A,M_C)
      M_D = TO_FM('8.68331761881188649551819440128M+36')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' FACT ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 810
      M_A = TO_FM('769.9115044247787610619469026548672566371681415929204')
      CALL FM_FACT(M_A,M_C)
      M_D = TO_FM('5.9982590033571347622193071279165294725603013413394492M+1889')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' FACT ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 811
      M_A = TO_FM('769.9115044247787610619469026548672566371681415929204')
      M_C = FACTORIAL(M_A)
      M_D = TO_FM('5.9982590033571347622193071279165294725603013413394492M+1889')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' FACT ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 812
      M_A = TO_FM('1.0M-222')
      CALL FM_LNGM(M_A,M_C)
      M_D = TO_FM('5.1117389064467814185199410293992885408744453047558760M+2')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' LNGM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 813
      M_A = TO_FM('2')
      CALL FM_LNGM(M_A,M_C)
      M_D = TO_FM('0')
      M_D = ABS(M_C - M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' LNGM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 814
      M_A = TO_FM('33')
      CALL FM_LNGM(M_A,M_C)
      M_D = TO_FM('8.1557959456115037178502968666011206687099284403417368M+1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' LNGM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 815
      M_A = TO_FM('2.00000000000000000001')
      CALL FM_LNGM(M_A,M_C)
      M_D = TO_FM('4.2278433509846713939671258025183870114019600466320121M-21')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' LNGM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 816
      M_C = LOG_GAMMA(TO_FM('33'))
      M_D = TO_FM('8.1557959456115037178502968666011206687099284403417368M+1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' LNGM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 817
      M_A = TO_FM('2.0706137739520290320140007735608464643737932737070189M-223')
      M_B = TO_FM('.78')
      CALL FM_BETA(M_A,M_B,M_C)
      M_D = TO_FM('4.8294858876137637017880452468052846823385248996130407M+222')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 818
      M_A = TO_FM('.78')
      M_B = TO_FM('2.0706137739520290320140007735608464643737932737070189M-223')
      CALL FM_BETA(M_A,M_B,M_C)
      M_D = TO_FM('4.8294858876137637017880452468052846823385248996130407M+222')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 819
      M_A = TO_FM('-4.5')
      M_B = TO_FM('4.5')
      CALL FM_BETA(M_A,M_B,M_C)
      M_D = TO_FM('0')
      M_D = ABS(M_C - M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 820
      M_A = TO_FM('-5.5')
      M_B = TO_FM('4.5')
      CALL FM_BETA(M_A,M_B,M_C)
      M_D = TO_FM('0')
      M_D = ABS(M_C - M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 821
      M_A = TO_FM('10')
      M_B = TO_FM('4')
      CALL FM_BETA(M_A,M_B,M_C)
      M_D = TO_FM('3.4965034965034965034965034965034965034965034965034965M-4')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 822
      M_A = TO_FM('1.0M+1234')
      M_B = TO_FM('2.2')
      CALL FM_BETA(M_A,M_B,M_C)
      M_D = TO_FM('1.7462392672319547876554292922652110015806932440139209M-2715')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 823
      M_A = TO_FM('10')
      M_B = TO_FM('5.3')
      CALL FM_BETA(M_A,M_B,M_C)
      M_D = TO_FM('7.0836036771097107530120640698518155187687458162734679M-5')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 824
      M_A = TO_FM('10.3')
      M_B = TO_FM('5')
      CALL FM_BETA(M_A,M_B,M_C)
      M_D = TO_FM('8.8146035423244390793072072569173028531206477712519934M-5')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 825
      M_A = TO_FM('10.3')
      M_B = TO_FM('5')
      M_C = BETA(M_A,M_B)
      M_D = TO_FM('8.8146035423244390793072072569173028531206477712519934M-5')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 826
      M_A = TO_FM('12.5')
      M_B = TO_FM('0')
      CALL FM_COMB(M_A,M_B,M_C)
      M_D = TO_FM('1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 827
      M_A = TO_FM('5')
      M_B = TO_FM('-2')
      CALL FM_COMB(M_A,M_B,M_C)
      M_D = TO_FM('0')
      M_D = ABS(M_C - M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 828
      M_A = TO_FM('12.5')
      M_B = TO_FM('12.5')
      CALL FM_COMB(M_A,M_B,M_C)
      M_D = TO_FM('1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 829
      M_A = TO_FM('-4.5')
      M_B = TO_FM('4.5')
      CALL FM_COMB(M_A,M_B,M_C)
      M_D = TO_FM('0')
      M_D = ABS(M_C - M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 830
      M_A = TO_FM('-4.5')
      M_B = TO_FM('4.5')
      CALL FM_COMB(M_A,M_B,M_C)
      M_D = TO_FM('0')
      M_D = ABS(M_C - M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 831
      M_A = TO_FM('-10')
      M_B = TO_FM('3')
      CALL FM_COMB(M_A,M_B,M_C)
      M_D = TO_FM('-220')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 832
      M_A = TO_FM('52')
      M_B = TO_FM('5')
      CALL FM_COMB(M_A,M_B,M_C)
      M_D = TO_FM('2.59896M+6')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 833
      M_A = TO_FM('1.0M+1234')
      M_B = TO_FM('7')
      CALL FM_COMB(M_A,M_B,M_C)
      M_D = TO_FM('1.9841269841269841269841269841269841269841269841269841M+8634')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 834
      M_A = TO_FM('1.0M+123')
      M_B = TO_FM('2.2')
      CALL FM_COMB(M_A,M_B,M_C)
      M_D = TO_FM('1.6423797032130683531106846289429264567307029528308099M+270')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 835
      M_A = TO_FM('1.0M-100')
      M_B = TO_FM('4')
      CALL FM_COMB(M_A,M_B,M_C)
      M_D = TO_FM('-2.5M-101')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 836
      M_A = TO_FM('1.0M+123')
      M_B = TO_FM('2.2')
      M_C = BINOMIAL(M_A,M_B)
      M_D = TO_FM('1.6423797032130683531106846289429264567307029528308099M+270')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST44

      SUBROUTINE TEST45(NCASE,NERROR,KLOG)

!  Test Incomplete Gamma, Incomplete Beta.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing Incomplete Gamma, Incomplete Beta.')")

      NCASE = 837
      M_A = TO_FM('2.0706137739520290320140007735608464643737932737070189M-145')
      M_B = TO_FM('.34')
      CALL FM_IGM1(M_A,M_B,M_C)
      M_D = TO_FM('4.8294858876137637017880452468052846823385248996130407M+144')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 838
      M_A = TO_FM('1.0E-50')
      M_B = TO_FM('1.0E+555')
      CALL FM_IGM1(M_A,M_B,M_C)
      M_D = TO_FM('9.9999999999999999999999999999999999999999999999999423M+49')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 839
      M_A = TO_FM('1.2')
      M_B = TO_FM('2.3')
      CALL FM_IGM1(M_A,M_B,M_C)
      M_D = TO_FM('7.9163089830797686672658085698101181778608009481363580M-1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 840
      M_A = TO_FM('23.4')
      M_B = TO_FM('456.7')
      CALL FM_IGM1(M_A,M_B,M_C)
      M_D = TO_FM('3.9191215305400046110416169991395759293572844563673750M+21')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 841
      M_A = TO_FM('1.2')
      M_B = TO_FM('0')
      CALL FM_IGM1(M_A,M_B,M_C)
      M_D = TO_FM('0')
      M_D = ABS(M_C - M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 842
      M_A = TO_FM('-1234.5')
      M_B = TO_FM('3.4')
      CALL FM_IGM1(M_A,M_B,M_C)
      M_D = TO_FM('-2.0892439131810030556730824779643382797767198269736235M-661')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 843
      M_A = TO_FM('10.3')
      M_B = TO_FM('230.7')
      CALL FM_IGM1(M_A,M_B,M_C)
      M_D = TO_FM('7.1643068906237524454762965471616445342244699109269471M+5')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 844
      M_A = TO_FM('1.2')
      M_B = TO_FM('2.3')
      M_C = INCOMPLETE_GAMMA1(M_A,M_B)
      M_D = TO_FM('7.9163089830797686672658085698101181778608009481363580M-1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 845
      M_A = TO_FM('0')
      M_B = TO_FM('4.5')
      CALL FM_IGM2(M_A,M_B,M_C)
      M_D = TO_FM('2.0734007547146144328855938695797884889319725701443004M-3')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 846
      M_A = TO_FM('4.5')
      M_B = TO_FM('0')
      CALL FM_IGM2(M_A,M_B,M_C)
      M_D = TO_FM('1.1631728396567448929144224109426265262108918305803166M+1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 847
      M_A = TO_FM('1.2')
      M_B = TO_FM('2.3')
      CALL FM_IGM2(M_A,M_B,M_C)
      M_D = TO_FM('1.2653784409178374391437079820481858290074190484504480M-1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 848
      M_A = TO_FM('3.4')
      M_B = TO_FM('456.7')
      CALL FM_IGM2(M_A,M_B,M_C)
      M_D = TO_FM('1.1043526800164195407100289367720949121507981651704628M-192')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 849
      M_A = TO_FM('1.0E-30')
      M_B = TO_FM('40.7')
      CALL FM_IGM2(M_A,M_B,M_C)
      M_D = TO_FM('5.0619447546123889551107110735110897294460083487536391M-20')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 850
      M_A = TO_FM('-8000.3')
      M_B = TO_FM('1.0e-10')
      CALL FM_IGM2(M_A,M_B,M_C)
      M_D = TO_FM('1.2499531266327356460522174653022492899665091451890036M+79999')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 851
      M_A = TO_FM('1')
      M_B = TO_FM('-10.7')
      CALL FM_IGM2(M_A,M_B,M_C)
      M_D = TO_FM('4.4355855130297866938628363428602120081387560278336788M+4')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 852
      M_A = TO_FM('1.2')
      M_B = TO_FM('2.3')
      M_C = INCOMPLETE_GAMMA2(M_A,M_B)
      M_D = TO_FM('1.2653784409178374391437079820481858290074190484504480M-1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 853
      M_A = TO_FM('0.1')
      M_B = TO_FM('23.4')
      M_C = TO_FM('34.5')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('5.8731980918960730463350151650813268739874201571164800M-27')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 854
      M_A = TO_FM('8.115640517330775M-1')
      M_B = TO_FM('2.00853601446773')
      M_C = TO_FM('1.59735792202923')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('2.0112520048150164306467955877563719782378767062440103M-1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 855
      M_A = TO_FM('9.01737835258975M-1')
      M_B = TO_FM('2.00853601446773')
      M_C = TO_FM('1.59735792202923')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('2.2512248738228585976753517954889151150428002974819213M-1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 856
      M_A = TO_FM('9.6097615596216720E-01')
      M_B = TO_FM('1.970425178583792')
      M_C = TO_FM('5.5680052333367')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('2.8619456987740165364092968281459448023932520843535423M-2')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 857
      M_A = TO_FM('4.764360371097952E-01')
      M_B = TO_FM('1.161514683661584E+01')
      M_C = TO_FM('2.937801562768354E-01')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('2.3604503996731113868791517339909092506365724801689105M-5')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 858
      M_A = TO_FM('0.9')
      M_B = TO_FM('23.4')
      M_C = TO_FM('34.5')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('7.3148127865937299821246829407023943740949130742928268M-18')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 859
      M_A = TO_FM('9.99496253868099M-1')
      M_B = TO_FM('2.47067979368109M+6')
      M_C = TO_FM('6.09475681774953M-100')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('1.7681753021411259894614747665450637683755190050365931M-544')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 860
      M_A = TO_FM('6.213433771653724M-1')
      M_B = TO_FM('8.854622686031200M-1')
      M_C = TO_FM('5.00000854049816M-121')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('1.1281271573737080091147788530326864610276172049831497M+0')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 861
      M_A = TO_FM('5.304391676698501M-15')
      M_B = TO_FM('4.870186358377400M+2')
      M_C = TO_FM('4.999955247889730M-98')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('8.7892314482956847896604128106803662527479433068750459M-6956')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 862
      M_A = TO_FM('1.882803169800314M-7')
      M_B = TO_FM('1.591547060066600M-169')
      M_C = TO_FM('3.521822614438970M+6')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('6.2831946669434576663925763649227277100409122269443137M+168')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 863
      M_A = TO_FM('.9999999999999')
      M_B = TO_FM('8.591098092677430M+2')
      M_C = TO_FM('1.863210949748253M+1')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('3.9062929191651064065641350979581425238442928803700306M-40')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 864
      M_A = TO_FM('2.531772074701081M-99')
      M_B = TO_FM('3.547571261801072M+2')
      M_C = TO_FM('1.974896958876250M+6')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('4.0957237103166196693191012056689839835950377114705018M-34981')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 865
      M_A = TO_FM('.99999999999999')
      M_B = TO_FM('1.0E-123')
      M_C = TO_FM('1.0E-134')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('1.0M+123')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 866
      M_A = TO_FM('1')
      M_B = TO_FM('2.65')
      M_C = TO_FM('4.88')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('1.5020204575152306127604878970920601604169827852591720M-2')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 867
      M_A = TO_FM('0')
      M_B = TO_FM('2.65')
      M_C = TO_FM('4.88')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('0')
      M_D = ABS(M_C - M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 868
      M_A = TO_FM('.998')
      M_B = TO_FM('759.6')
      M_C = TO_FM('4.95e-57')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('9.7133692099062434492386763673434080317019087637060970M-2')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 869
      M_A = TO_FM('4.764360371097952E-01')
      M_B = TO_FM('1.161514683661584E+01')
      M_C = TO_FM('2.937801562768354E-01')
      M_C = INCOMPLETE_BETA(M_A,M_B,M_C)
      M_D = TO_FM('2.3604503996731113868791517339909092506365724801689105M-5')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST45

      SUBROUTINE TEST46(NCASE,NERROR,KLOG)

!  Test the Polygamma, Psi functions.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      INTEGER KLOG,NCASE,NERROR

      WRITE (KW,"(/' Testing Polygamma, Psi.')")


      NCASE = 870
      M_A = TO_FM('4.5')
      CALL FM_PGAM(0,M_A,M_C)
      M_D = TO_FM('1.3888709263595289015114046193821968137592213477205183M+0')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 871
      M_A = TO_FM('1.0E-123')
      CALL FM_PGAM(1,M_A,M_C)
      M_D = TO_FM('1.0M+246')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 872
      M_A = TO_FM('1.0E-123')
      CALL FM_PGAM(2,M_A,M_C)
      M_D = TO_FM('-2.0M+369')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 873
      M_A = TO_FM('2.0706137739520290320140007735608464643737932737070189M-1')
      CALL FM_PGAM(1,M_A,M_C)
      M_D = TO_FM('2.4580954480899934124966756607870377560864828849100481M+1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 874
      M_A = TO_FM('2.0706137739520290320140007735608464643737932737070189M-1')
      CALL FM_PGAM(6,M_A,M_C)
      M_D = TO_FM('-4.4120531379423056741117517146346730469682094212273241M+7')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 875
      M_A = TO_FM('2.0706137739520290320140007735608464643737932737070189M-1')
      CALL FM_PGAM(23,M_A,M_C)
      M_D = TO_FM('6.7006365293376930742991440911935017694098601683947073M+38')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 876
      M_A = TO_FM('1.0E+123')
      CALL FM_PGAM(4,M_A,M_C)
      M_D = TO_FM('-6.0M-492')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 877
      M_A = TO_FM('-6.499999840238790109')
      CALL FM_PGAM(4,M_A,M_C)
      M_D = TO_FM('1.0135142464863270830609416082237513111216512170936928M-16')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 878
      M_C = POLYGAMMA(2,TO_FM('1.0E-123'))
      M_D = TO_FM('-2.0M+369')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 879
      M_A = TO_FM('1.0E-135')
      CALL FM_PSI(M_A,M_C)
      M_D = TO_FM('-1.0M+135')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PSI  ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 880
      M_A = TO_FM('1.2')
      CALL FM_PSI(M_A,M_C)
      M_D = TO_FM('-2.8903989659218829554720796244995210482558827420664281M-1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PSI  ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 881
      M_A = TO_FM('-3.4')
      CALL FM_PSI(M_A,M_C)
      M_D = TO_FM('2.3844508141180140670320531380285019520468887144980679M+0')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PSI  ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 882
      M_A = TO_FM('57')
      CALL FM_PSI(M_A,M_C)
      M_D = TO_FM('4.0342536898816977739559850955847848905386809772893269M+0')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PSI  ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 883
      M_A = TO_FM('1.0E+56')
      CALL FM_PSI(M_A,M_C)
      M_D = TO_FM('1.2894476520766655830500752146232439562566168336321129M+2')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PSI  ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 884
      M_A = TO_FM('1.0')
      CALL FM_PSI(M_A,M_C)
      M_D = TO_FM('-5.7721566490153286060651209008240243104215933593992360M-1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PSI  ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 885
      M_A = TO_FM('1.0E+23456')
      CALL FM_PSI(M_A,M_C)
      M_D = TO_FM('5.4009435941268335564326007561076446853491436517276499M+4')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PSI  ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 886
      M_A = TO_FM('1.46163214496836234126266')
      CALL FM_PSI(M_A,M_C)
      M_D = TO_FM('4.4287869692570149446165609601581442013784186419176534M-25')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PSI  ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 887
      M_C = PSI(TO_FM('1.2'))
      M_D = TO_FM('-2.8903989659218829554720796244995210482558827420664281M-1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
          CALL ERRPRT_FM(' PSI  ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST46

      SUBROUTINE TEST47(NCASE,NERROR,KLOG)

!  Test the different rounding modes.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      INTEGER KLOG,NCASE,NERROR
      INTEGER SEED(7)

      WRITE (KW,"(/' Testing the different rounding modes.')")


      CALL FMSETVAR(' MBASE = 10 ')
      CALL FMSETVAR(' NDIG = 20 ')
      M_A = 0

      NCASE = 888
      CALL FMSETVAR(' KROUND = 1 ')
      M_C = TO_FM('2')/TO_FM('3')
      M_D = TO_FM('.66666666666666666667')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 889
      CALL FMSETVAR(' KROUND = -1 ')
      M_C = TO_FM('2')/TO_FM('3')
      M_D = TO_FM('.66666666666666666666')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 890
      CALL FMSETVAR(' KROUND = 0 ')
      M_C = TO_FM('2')/TO_FM('3')
      M_D = TO_FM('.66666666666666666666')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 891
      CALL FMSETVAR(' KROUND = 2 ')
      M_C = TO_FM('2')/TO_FM('3')
      M_D = TO_FM('.66666666666666666667')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 892
      CALL FMSETVAR(' KROUND = 1 ')
      M_C = TO_FM('1')/TO_FM('3')
      M_D = TO_FM('.33333333333333333333')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 893
      CALL FMSETVAR(' KROUND = -1 ')
      M_C = TO_FM('1')/TO_FM('3')
      M_D = TO_FM('.33333333333333333333')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 894
      CALL FMSETVAR(' KROUND = 0 ')
      M_C = TO_FM('1')/TO_FM('3')
      M_D = TO_FM('.33333333333333333333')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 895
      CALL FMSETVAR(' KROUND = 2 ')
      M_C = TO_FM('1')/TO_FM('3')
      M_D = TO_FM('.33333333333333333334')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 896
      CALL FMSETVAR(' KROUND = 1 ')
      M_C = TO_FM('-1')/TO_FM('3')
      M_D = TO_FM('-.33333333333333333333')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 897
      CALL FMSETVAR(' KROUND = -1 ')
      M_C = TO_FM('-1')/TO_FM('3')
      M_D = TO_FM('-.33333333333333333334')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 898
      CALL FMSETVAR(' KROUND = 0 ')
      M_C = TO_FM('-1')/TO_FM('3')
      M_D = TO_FM('-.33333333333333333333')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 899
      CALL FMSETVAR(' KROUND = 2 ')
      M_C = TO_FM('-1')/TO_FM('3')
      M_D = TO_FM('-.33333333333333333333')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 900
      CALL FMSETVAR(' KROUND = 1 ')
      M_C = TO_FM('-2')/TO_FM('3')
      M_D = TO_FM('-.66666666666666666667')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 901
      CALL FMSETVAR(' KROUND = -1 ')
      M_C = TO_FM('-2')/TO_FM('3')
      M_D = TO_FM('-.66666666666666666667')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 902
      CALL FMSETVAR(' KROUND = 0 ')
      M_C = TO_FM('-2')/TO_FM('3')
      M_D = TO_FM('-.66666666666666666666')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 903
      CALL FMSETVAR(' KROUND = 2 ')
      M_C = TO_FM('-2')/TO_FM('3')
      M_D = TO_FM('-.66666666666666666666')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 904
      CALL FMSETVAR(' KROUND = 1 ')
      M_C = TO_FM('1') + TO_FM('3E-555')
      M_D = TO_FM('1.0000000000000000000')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 905
      CALL FMSETVAR(' KROUND = -1 ')
      M_C = TO_FM('1') + TO_FM('3E-555')
      M_D = TO_FM('1.0000000000000000000')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 906
      CALL FMSETVAR(' KROUND = 0 ')
      M_C = TO_FM('1') + TO_FM('3E-555')
      M_D = TO_FM('1.0000000000000000000')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 907
      CALL FMSETVAR(' KROUND = 2 ')
      M_C = TO_FM('1') + TO_FM('3E-555')
      M_D = TO_FM('1.0000000000000000001')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 908
      CALL FMSETVAR(' KROUND = 1 ')
      M_C = TO_FM('1') - TO_FM('3E-555')
      M_D = TO_FM('1.0000000000000000000')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 909
      CALL FMSETVAR(' KROUND = -1 ')
      M_C = TO_FM('1') - TO_FM('3E-555')
      M_D = TO_FM('.99999999999999999999')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 910
      CALL FMSETVAR(' KROUND = 0 ')
      M_C = TO_FM('1') - TO_FM('3E-555')
      M_D = TO_FM('.99999999999999999999')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 911
      CALL FMSETVAR(' KROUND = 2 ')
      M_C = TO_FM('1') - TO_FM('3E-555')
      M_D = TO_FM('1.0000000000000000000')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 912
      CALL FMSETVAR(' KROUND = 1 ')
      M_C = TO_FM('-1') + TO_FM('3E-555')
      M_D = TO_FM('-1.0000000000000000000')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 913
      CALL FMSETVAR(' KROUND = -1 ')
      M_C = TO_FM('-1') + TO_FM('3E-555')
      M_D = TO_FM('-1.0000000000000000000')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 914
      CALL FMSETVAR(' KROUND = 0 ')
      M_C = TO_FM('-1') + TO_FM('3E-555')
      M_D = TO_FM('-.99999999999999999999')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 915
      CALL FMSETVAR(' KROUND = 2 ')
      M_C = TO_FM('-1') + TO_FM('3E-555')
      M_D = TO_FM('-.99999999999999999999')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 916
      CALL FMSETVAR(' KROUND = 1 ')
      M_C = TO_FM('-1') - TO_FM('3E-555')
      M_D = TO_FM('-1.0000000000000000000')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 917
      CALL FMSETVAR(' KROUND = -1 ')
      M_C = TO_FM('-1') - TO_FM('3E-555')
      M_D = TO_FM('-1.0000000000000000001')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 918
      CALL FMSETVAR(' KROUND = 0 ')
      M_C = TO_FM('-1') - TO_FM('3E-555')
      M_D = TO_FM('-1.0000000000000000000')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 919
      CALL FMSETVAR(' KROUND = 2 ')
      M_C = TO_FM('-1') - TO_FM('3E-555')
      M_D = TO_FM('-1.0000000000000000000')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      CALL FMSETVAR(' MBASE = 2 ')
      CALL FMSETVAR(' NDIG = 53 ')
      NCASE = 920
      M_A = TO_FM('0.125')
      M_B = TO_FM('23.25')
      M_C = TO_FM('34.5')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('6.1345805065305141873M-25')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 921
      M_A = TO_FM('0.52')
      M_B = TO_FM('2.01')
      M_C = TO_FM('1.6')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('1.0304844627978347604M-1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 922
      M_A = TO_FM('9.01737835258975M-1')
      M_B = TO_FM('2.00853601446773')
      M_C = TO_FM('1.59735792202923')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('2.2512248738228585986M-1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 923
      M_A = TO_FM('9.6097615596216720E-01')
      M_B = TO_FM('1.970425178583792')
      M_C = TO_FM('5.5680052333367')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('2.8619456987740165927M-2')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 924
      M_A = TO_FM('4.764360371097952E-01')
      M_B = TO_FM('1.161514683661584E+01')
      M_C = TO_FM('2.937801562768354E-01')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('2.3604503996731113869M-5')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 925
      M_A = TO_FM('0.9')
      M_B = TO_FM('23.4')
      M_C = TO_FM('34.5')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('7.3148127865937395334M-18')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      CALL FMSETVAR(' MBASE = 3 ')
      CALL FMSETVAR(' NDIG = 55 ')
      NCASE = 926
      M_A = TO_FM('0.1')
      M_B = TO_FM('23.4')
      M_C = TO_FM('34.5')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('5.87319809189607304633501593392681M-27')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 927
      M_A = TO_FM('0.52')
      M_B = TO_FM('2.1')
      M_C = TO_FM('1.6')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('9.25745341552810210762563659429375M-2')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 928
      M_A = TO_FM('9.01737835258975M-1')
      M_B = TO_FM('2.00853601446773')
      M_C = TO_FM('1.59735792202923')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('2.25122487382285859767535178829535M-1')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 929
      M_A = TO_FM('9.6097615596216720E-01')
      M_B = TO_FM('1.970425178583792')
      M_C = TO_FM('5.5680052333367')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('2.861945698774016536409296855493M-2')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 930
      M_A = TO_FM('4.764360371097952E-01')
      M_B = TO_FM('1.161514683661584E+01')
      M_C = TO_FM('2.937801562768354E-01')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('2.36045039967311138687915158221269M-5')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 931
      M_A = TO_FM('0.9')
      M_B = TO_FM('23.4')
      M_C = TO_FM('34.5')
      CALL FM_IBTA(M_A,M_B,M_C,MFM6)
      CALL FM_EQ(MFM6,M_C)
      M_D = TO_FM('7.31481278659372998212468424608367M-18')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN
          CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 932
      CALL FPST2M('1.67',MP1)
      CALL FPST2M('2.64',MP2)
      CALL FPADD(MP1,MP2,MP3)
      CALL FPEQ(MP3,MP1)
      CALL FPST2M('-3.91',MP2)
      CALL FPSUB(MP1,MP2,MP3)
      CALL FPEQ(MP3,MP1)
      CALL FPST2M('4.58',MP2)
      CALL FPMPY(MP1,MP2,MP3)
      CALL FPEQ(MP3,MP1)
      CALL FPST2M('0.27',MP2)
      CALL FPDIV(MP1,MP2,MP3)
      CALL FPEQ(MP3,MP1)
      CALL FPADDI(MP1,2)
      CALL FPMPYI(MP1,13,MP3)
      CALL FPEQ(MP3,MP1)
      CALL FPDIVI(MP1,11,MP3)
      CALL FPEQ(MP3,MP1)
      CALL FPLN(MP1,MP3)
      CALL FPEQ(MP3,MP1)
      CALL FPSIN(MP1,MP3)
      CALL FPEQ(MP3,MP1)
      CALL FPCOS(MP1,MP3)
      CALL FPEQ(MP3,MP1)
      CALL FPEXP(MP1,MP3)
      CALL FPEQ(MP3,MP1)
      CALL FPGAM(MP1,MP3)
      CALL FPEQ(MP3,MP1)
      CALL FMUNPK(MP1,M_C%MFM)
      M_D = TO_FM('0.941122001974472326543759839200398')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN
          CALL ERRPRT_FM(' Pack ',M_C,'M_C',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 933
      SEED = (/ 2718281,8284590,4523536,0287471,3526624,9775724,7093699 /)
      CALL FM_RANDOM_SEED(PUT=SEED)
      DO J1 = 1, 10
         CALL FM_RANDOM_NUMBER(D1)
      ENDDO
      M_C = D1
      M_D = TO_FM('0.945608442536777')
      M_D = ABS((M_C - M_D)/M_D)
      IF (.NOT.(M_D <= TO_FM('1.0E-10'))) THEN
          CALL ERRPRT_FM(' Rand ',M_C,'M_C',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      CALL FMSETVAR(' MBASE = 10000 ')
      CALL FMSETVAR(' NDIG = 5 ')

      NCASE = 934
      CALL FMSETVAR(' KROUND = 1 ')
      CALL FMSETVAR(' KRPERF = 1 ')
      M_C = SQRT( TO_FM('.49841718043038996023') )
      M_D = TO_FM('.70598667156709832621')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      NCASE = 935
      CALL FMSETVAR(' KROUND = 1 ')
      CALL FMSETVAR(' KRPERF = 0 ')
      M_C = SQRT( TO_FM('.49841718043038996023') )
      M_D = TO_FM('.70598667156709832622')
      IF (.NOT.(M_D == M_C)) THEN
          CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D',  &
                         NCASE,NERROR,KLOG)
      ENDIF

      RETURN
      END SUBROUTINE TEST47

      SUBROUTINE ERRPRTFM(NROUT,M1,NAME1,M2,NAME2,M3,NAME3,  &
                          NCASE,NERROR,KLOG)

!  Print error messages for testing of real (FM) routines.

!  M1 is the value to be tested, as computed by the routine named NROUT.
!  M2 is the reference value, usually converted using FMST2M.
!  M3 is ABS(M1-M2), and ERRPRT is called if this is too big.
!  NAME1,NAME2,NAME3 are strings identifying which variables in the
!                    calling routine correspond to M1,M2,M3.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: M1(-1:LUNPCK),M2(-1:LUNPCK),M3(-1:LUNPCK)

      CHARACTER(2) :: NAME1,NAME2,NAME3
      CHARACTER(6) :: NROUT
      INTEGER KLOG,KWSAVE,NCASE,NERROR

      NERROR = NERROR + 1
      WRITE (KW,  &
          "(//' Error in case',I4,'.  The routine',' being tested was ',A6)"  &
          ) NCASE,NROUT
      WRITE (KLOG,  &
          "(//' Error in case',I4,'.  The routine',' being tested was ',A6)"  &
          ) NCASE,NROUT

!              Temporarily change KW to KLOG so FMPRNT
!              will write to the log file.

      KWSAVE = KW
      KW = KLOG
      WRITE (KLOG,"(1X,A,' =')") NAME1
      CALL FMPRNT(M1)
      WRITE (KLOG,"(1X,A,' =')") NAME2
      CALL FMPRNT(M2)
      WRITE (KLOG,"(1X,A,' =')") NAME3
      CALL FMPRNT(M3)
      KW = KWSAVE
      RETURN
      END SUBROUTINE ERRPRTFM

      SUBROUTINE ERRPRTIM(NROUT,M1,NAME1,M2,NAME2,  &
                          NCASE,NERROR,KLOG)

!  Print error messages for testing of integer (IM) routines.

!  M1 is the value to be tested, as computed by the routine named NROUT.
!  M2 is the reference value, usually converted using IMST2M.
!  NAME1,NAME2 are strings identifying which variables in the calling routine
!              correspond to M1,M2.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: M1(-1:LUNPCK),M2(-1:LUNPCK)

      CHARACTER(2) :: NAME1,NAME2
      CHARACTER(6) :: NROUT
      INTEGER KLOG,KWSAVE,NCASE,NERROR

      NERROR = NERROR + 1
      WRITE (KW,  &
          "(//' Error in case',I4,'.  The routine',' being tested was ',A6)"  &
          ) NCASE,NROUT
      WRITE (KLOG,  &
          "(//' Error in case',I4,'.  The routine',' being tested was ',A6)"  &
          ) NCASE,NROUT

!              Temporarily change KW to KLOG so IMPRNT
!              will write to the log file.

      KWSAVE = KW
      KW = KLOG
      WRITE (KLOG,"(1X,A,' =')") NAME1
      CALL IMPRNT(M1)
      WRITE (KLOG,"(1X,A,' =')") NAME2
      CALL IMPRNT(M2)
      KW = KWSAVE
      END SUBROUTINE ERRPRTIM

      SUBROUTINE ERRPRTZM(NROUT,M1,NAME1,M2,NAME2,M3,NAME3,  &
                          NCASE,NERROR,KLOG)

!  Print error messages.

!  M1 is the value to be tested, as computed by the routine named NROUT.
!  M2 is the reference value, usually converted using ZMST2M.
!  M3 is ABS(M1-M2), and ERRPRTZM is called if this is too big.
!  NAME1,NAME2,NAME3 are strings identifying which variables in the
!                    calling routine correspond to M1,M2,M3.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: M1(-1:LUNPKZ),M2(-1:LUNPKZ),M3(-1:LUNPKZ)

      CHARACTER(2) :: NAME1,NAME2,NAME3
      CHARACTER(6) :: NROUT
      INTEGER KLOG,KWSAVE,NCASE,NERROR

      NERROR = NERROR + 1
      WRITE (KW,  &
          "(//' Error in case',I4,'.  The routine',' being tested was ',A6)"  &
          ) NCASE,NROUT
      WRITE (KLOG,  &
          "(//' Error in case',I4,'.  The routine',' being tested was ',A6)"  &
          ) NCASE,NROUT

!              Temporarily change KW to KLOG so ZMPRNT
!              will write to the log file.

      KWSAVE = KW
      KW = KLOG
      WRITE (KLOG,"(1X,A,' =')") NAME1
      CALL ZMPRNT(M1)
      WRITE (KLOG,"(1X,A,' =')") NAME2
      CALL ZMPRNT(M2)
      WRITE (KLOG,"(1X,A,' =')") NAME3
      CALL ZMPRNT(M3)
      KW = KWSAVE
      END SUBROUTINE ERRPRTZM

      SUBROUTINE ERRPRT_FM(NROUT,M1,NAME1,M2,NAME2,M3,NAME3,  &
                           NCASE,NERROR,KLOG)

!  Print error messages for testing of TYPE (FM) interface routines.

!  M1 is the value to be tested, as computed by the routine named NROUT.
!  M2 is the reference value, usually converted using FMST2M.
!  M3 is ABS(M1-M2), and ERRPRT_FM is called if this is too big.
!  NAME1,NAME2,NAME3 are strings identifying which variables in the
!                    calling routine correspond to M1,M2,M3.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      TYPE (FM) M1,M2,M3

      CHARACTER(3) :: NAME1,NAME2,NAME3
      CHARACTER(6) :: NROUT
      INTEGER KLOG,KWSAVE,NCASE,NERROR

      NERROR = NERROR + 1
      WRITE (KW,  &
         "(//' Error in case',I4,'.  The interface',' being tested was ',A6)"  &
         ) NCASE,NROUT
      WRITE (KLOG,  &
         "(//' Error in case',I4,'.  The interface',' being tested was ',A6)"  &
         ) NCASE,NROUT

!              Temporarily change KW to KLOG so FMPRNT
!              will write to the log file.

      KWSAVE = KW
      KW = KLOG
      WRITE (KLOG,"(1X,A,' =')") NAME1
      CALL FM_PRNT(M1)
      WRITE (KLOG,"(1X,A,' =')") NAME2
      CALL FM_PRNT(M2)
      WRITE (KLOG,"(1X,A,' =')") NAME3
      CALL FM_PRNT(M3)
      KW = KWSAVE
      END SUBROUTINE ERRPRT_FM

      SUBROUTINE ERRPRT_IM(NROUT,M1,NAME1,M2,NAME2,  &
                           NCASE,NERROR,KLOG)

!  Print error messages for testing of TYPE (IM) interface routines.

!  M1 is the value to be tested, as computed by the routine named NROUT.
!  M2 is the reference value, usually converted using IMST2M.
!  NAME1,NAME2 are strings identifying which variables in the calling routine
!              correspond to M1,M2.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      TYPE (IM) M1,M2

      CHARACTER(3) :: NAME1,NAME2
      CHARACTER(6) :: NROUT
      INTEGER KLOG,KWSAVE,NCASE,NERROR

      NERROR = NERROR + 1
      WRITE (KW,  &
        "(//' Error in case',I4,'.  The interface',' being tested was ',A6)"  &
        ) NCASE,NROUT
      WRITE (KLOG,  &
        "(//' Error in case',I4,'.  The interface',' being tested was ',A6)"  &
        ) NCASE,NROUT

!              Temporarily change KW to KLOG so IMPRNT
!              will write to the log file.

      KWSAVE = KW
      KW = KLOG
      WRITE (KLOG,"(1X,A,' =')") NAME1
      CALL IM_PRNT(M1)
      WRITE (KLOG,"(1X,A,' =')") NAME2
      CALL IM_PRNT(M2)
      KW = KWSAVE
      END SUBROUTINE ERRPRT_IM

      SUBROUTINE ERRPRT_ZM(NROUT,M1,NAME1,M2,NAME2,M3,NAME3,  &
                           NCASE,NERROR,KLOG)

!  Print error messages for testing of TYPE (ZM) interface routines.

!  M1 is the value to be tested, as computed by the routine named NROUT.
!  M2 is the reference value, usually converted using ZMST2M.
!  M3 is ABS(M1-M2), and ERRPRT_ZM is called if this is too big.
!  NAME1,NAME2,NAME3 are strings identifying which variables in the calling routine
!                    correspond to M1,M2,M3.

      USE FMVALS
      USE FMZM
      USE TEST_VARS

      IMPLICIT NONE

      TYPE (ZM) M1,M2,M3

      CHARACTER(3) :: NAME1,NAME2,NAME3
      CHARACTER(6) :: NROUT
      INTEGER KLOG,KWSAVE,NCASE,NERROR

      NERROR = NERROR + 1
      WRITE (KW,  &
        "(//' Error in case',I4,'.  The interface',' being tested was ',A6)"  &
        ) NCASE,NROUT
      WRITE (KLOG,  &
        "(//' Error in case',I4,'.  The interface',' being tested was ',A6)"  &
        ) NCASE,NROUT

!              Temporarily change KW to KLOG so ZMPRNT
!              will write to the log file.

      KWSAVE = KW
      KW = KLOG
      WRITE (KLOG,"(1X,A,' =')") NAME1
      CALL ZM_PRNT(M1)
      WRITE (KLOG,"(1X,A,' =')") NAME2
      CALL ZM_PRNT(M2)
      WRITE (KLOG,"(1X,A,' =')") NAME3
      CALL ZM_PRNT(M3)
      KW = KWSAVE
      END SUBROUTINE ERRPRT_ZM

      SUBROUTINE PRTERR(KW,KLOG,NCASE,NERROR)
      IMPLICIT NONE
      INTEGER KW,KLOG,NCASE,NERROR

      WRITE (KW,*) ' Error in case ',NCASE
      WRITE (KLOG,*) ' '
      WRITE (KLOG,*) ' Error in case ',NCASE
      NERROR = NERROR + 1
      END SUBROUTINE PRTERR

      SUBROUTINE TIMEIT(TIME)

      INTEGER JTIME,JRATE
      REAL TIME

!  Return the system time.  f90 version.

      CALL SYSTEM_CLOCK(JTIME,JRATE)
      TIME = REAL(JTIME)/REAL(JRATE)
      RETURN
      END SUBROUTINE TIMEIT
SHAR_EOF
fi # end of overwriting check
cd ..
if test ! -d 'Src'
then
	mkdir 'Src'
fi
cd 'Src'
if test -f 'FM.f90'
then
	echo shar: will not over-write existing file "'FM.f90'"
else
cat << "SHAR_EOF" > 'FM.f90'


!     FM 1.2                    David M. Smith                  8-17-01


!  The routines in this package perform multiple precision arithmetic and
!  functions on three kinds of numbers.
!  FM routines handle floating-point real multiple precision numbers,
!  IM routines handle integer multiple precision numbers, and
!  ZM routines handle floating-point complex multiple precision numbers.


!  1. INITIALIZING THE PACKAGE

!  The variables that contain values to be shared by the different routines are
!  located in module FMVALS in file FMSAVE.f90.  Variables that are described
!  below for controlling various features of the FM package are found in this
!  module.  They are initialized to default values assuming 32-bit integers and
!  64-bit double precision representation of the arrays holding multiple
!  precision numbers.  The base and number of digits to be used are initialized
!  to give slightly more than 50 decimal digits.  Subroutine FMVARS can be used
!  to get a list of these variables and their values.

!  The intent of module FMVALS is to hide the FM internal variables from the
!  user's program, so that no name conflicts can occur.  Subroutine FMSETVAR can
!  be used to change the variables listed below to new values.  It is not always
!  safe to try to change these variables directly by putting USE FMVALS into the
!  calling program and then changing them by hand.  Some of the saved constants
!  depend upon others, so that changing one variable may cause errors if others
!  depending on that one are not also changed.  FMSETVAR automatically updates
!  any others that depend upon the one being changed.

!  Subroutine FMSET also initializes these variables.  It tries to compute the
!  best value for each, and it checks several of the values set in FMVALS to see
!  that they are reasonable for a given machine.  FMSET can also be called to
!  set or change the current precision level for the multiple precision numbers.

!  Calling FMSET is optional in version 1.2 of the FM package.  In previous
!  versions one call was required before any other routine in the package could
!  be used.

!  The routine ZMSET from version 1.1 is no longer needed, and the complex
!  operations are automatically initialized in FMVALS.  It has been left in the
!  package for compatibility with version 1.1.


!  2.  REPRESENTATION OF FM NUMBERS

!  MBASE is the base in which the arithmetic is done.  MBASE must be
!        bigger than one, and less than or equal to the square root of
!        the largest representable integer.  For best efficiency MBASE
!        should be large, but no more than about 1/4 of the square root
!        of the largest representable integer.  Input and output
!        conversions are much faster when MBASE is a power of ten.

!  NDIG  is the number of base MBASE digits that are carried in the
!        multiple precision numbers.  NDIG must be at least two.  The
!        upper limit for NDIG is defined in FMVALS and is restricted
!        only by the amount of memory available.

!  Sometimes it is useful to dynamically vary NDIG during the program.  Routine
!  FMEQU should be used to round numbers to lower precision or zero-pad them to
!  higher precision when changing NDIG.

!  The default value of MBASE is a large power of ten.  FMSET also sets MBASE to
!  a large power of ten.  For an application where another base is used, such as
!  simulating a given machine's base two arithmetic, use subroutine FMSETVAR to
!  change MBASE, so that the other internal values depending on MBASE will be
!  changed accordingly.

!  There are two representations for a floating point multiple precision number.
!  The unpacked representation used by the routines while doing the computations
!  is base MBASE and is stored in NDIG+3 words.  A packed representation is
!  available to store the numbers in the user's program in compressed form.  In
!  this format, the NDIG (base MBASE) digits of the mantissa are packed two per
!  word to conserve storage.  Thus the external, packed form of a number
!  requires (NDIG+1)/2+3 words.

!  This version uses double precision arrays to hold the numbers.  Version 1.0
!  of FM used integer arrays, which are faster on some machines.  The package
!  can be changed to use integer arrays --- see section 11 on EFFICIENCY below.

!  The unpacked format of a floating multiple precision number is as follows.
!  A number MA is kept in an array with MA(1) containing the exponent, and
!  MA(2) through MA(NDIG+1) each containing one digit of the mantissa, expressed
!  in base MBASE.  The array is dimensioned to start at MA(-1), with the
!  sign of the number (+1 or -1) held in MA(-1), and the  approximate number
!  of bits of precision stored in MA(0).  This precision value is intended to
!  be used by FM functions that need to monitor cancellation error in addition
!  and subtraction.  The cancellation monitor code is usually disabled for user
!  calls, and FM functions only check for cancellation when they must.  Tracking
!  cancellation causes most routines to run slower, with addition and
!  subtraction being affected the most.  The exponent is a power of MBASE and
!  the implied radix point is immediately before the first digit of the
!  mantissa.  Every nonzero number is normalized so that the second array
!  element (the first digit of the mantissa) is nonzero.

!  In both representations the sign of the number is carried on the second array
!  element only.  Elements 3,4,... are always nonnegative.  The exponent is a
!  signed integer and may be as large in magnitude as MXEXP.

!  For MBASE = 10,000 and NDIG = 4, if array MA holds the number -pi, it would
!  have these representations:
!                   Word 1         2         3         4         5

!         Unpacked:      1         3      1415      9265      3590
!         Packed:        1     31415  92653590

!  In both formats MA(0) would be 42, indicating that the mantissa has about 42
!  bits of precision, and MA(-1) = -1 since the number is negative.

!  Because of normalization in a large base, the equivalent number of base 10
!  significant digits for an FM number may be as small as
!  LOG10(MBASE)*(NDIG-1) + 1.

!  The integer routines use the FM format to represent numbers, without the
!  number of digits (NDIG) being fixed.  Integers in IM format are essentially
!  variable precision, using the minimum number of words to represent each
!  value.

!  For programs using both FM and IM numbers, FM routines should not be called
!  with IM numbers, and IM routines should not be called with FM numbers, since
!  the implied value of NDIG used for an IM number may not match the explicit
!  NDIG expected by an FM routine.  Use the conversion routines IMFM2I and
!  IMI2FM to change between the FM and IM formats.

!  The format for complex FM numbers (called ZM numbers below) is very similar
!  to that for real FM numbers.  Each ZM array holds two FM numbers to represent
!  the real and imaginary parts of a complex number.  Each ZM array is twice as
!  long as a corresponding FM array, with the imaginary part starting at the
!  midpoint of the array.  As with FM, there are packed and unpacked formats for
!  the numbers.


!  3. INPUT/OUTPUT ROUTINES

!  All versions of the input routines perform free-format conversion from
!  characters to FM numbers.

!  a. Conversion to or from a character array

!     FMINP converts from a character*1 array to an FM number.

!     FMOUT converts an FM number to base 10 and formats it for output as an
!           array of type character*1.  The output is left justified in the
!           array, and the format is defined by two variables in module FMVALS,
!           so that a separate format definition does not have to be provided
!           for each output call.

!     JFORM1 and JFORM2 define a default output format.

!     JFORM1 = 0     E   format       ( .314159M+6 )
!            = 1     1PE format       ( 3.14159M+5 )
!            = 2     F   format       ( 314159.000 )

!     JFORM2 is the number of significant digits to display (if JFORM1 =
!            0 or 1).  If JFORM2 = 0 then a default number of digits is chosen.
!            The default is roughly the full precision of the number.
!     JFORM2 is the number of digits after the decimal point (if JFORM1 = 2).
!            See the FMOUT documentation for more details.

!  b. Conversion to or from a character string

!     FMST2M converts from a character string to an FM number.

!     FMFORM converts an FM number to a character string according to a format
!            provided in each call.  The format description is more like that of
!            a Fortran FORMAT statement, and integer or fixed-point output is
!            right justified.

!  c. Direct read or write

!     FMPRNT uses FMOUT to print one FM number.

!     FMFPRT uses FMFORM to print one FM number.

!     FMWRIT writes FM numbers for later input using FMREAD.

!     FMREAD reads FM numbers written by FMWRIT.

!  The values given to JFORM1 and JFORM2 can be used to define a default output
!  format when FMOUT or FMPRNT are called.  The explicit format used in a call
!  to FMFORM or FMFPRT overrides the settings of JFORM1 and JFORM2.

!  KW is the unit number to be used for standard output from the package,
!     including error and warning messages, and trace output.

!  For multiple precision integers, the corresponding routines IMINP, IMOUT,
!  IMST2M, IMFORM, IMPRNT, IMFPRT, IMWRIT, and IMREAD provide similar input and
!  output conversions.  For output of IM numbers, JFORM1 and JFORM2 are ignored
!  and integer format (JFORM1=2, JFORM2=0) is used.

!  For ZM numbers, the corresponding routines ZMINP, ZMOUT, ZMST2M, ZMFORM,
!  ZMPRNT, ZMFPRT, ZMWRIT, and ZMREAD provide similar input and output
!  conversions.

!  For the output format of ZM numbers, JFORM1 and JFORM2 determine the default
!  format for the individual parts of a complex number as with FM numbers.

!     JFORMZ determines the combined output format of the real and
!            imaginary parts.

!     JFORMZ = 1  normal setting    :    1.23 - 4.56 i
!            = 2  use capital I     :    1.23 - 4.56 I
!            = 3  parenthesis format:  ( 1.23 , -4.56 )

!     JPRNTZ controls whether to print real and imaginary parts
!            on one line whenever possible.

!     JPRNTZ = 1  print both parts as a single string :
!                     1.23456789M+321 - 9.87654321M-123 i
!            = 2  print on separate lines without the 'i' :
!                     1.23456789M+321
!                    -9.87654321M-123

!  For further description of these routines, see sections 9 and 10 below.


!  4. ARITHMETIC TRACING

!  NTRACE and LVLTRC control trace printout from the package.

!  NTRACE =  0   No output except warnings and errors.  (Default)
!         =  1   The result of each call to one of the routines
!                   is printed in base 10, using FMOUT.
!         = -1   The result of each call to one of the routines
!                   is printed in internal base MBASE format.
!         =  2   The input arguments and result of each call to one
!                   of the routines is printed in base 10, using FMOUT.
!         = -2   The input arguments and result of each call to one
!                   of the routines is printed in base MBASE format.

!  LVLTRC defines the call level to which the trace is done.  LVLTRC = 1
!         means only FM routines called directly by the user are traced,
!         LVLTRC = 2 also prints traces for FM routines called by other
!         FM routines called directly by the user, etc.  Default is 1.

!  In the above description, internal MBASE format means the number is
!  printed as it appears in the array --- an exponent followed by NDIG
!  base MBASE digits.


!  5. ERROR CONDITIONS

!  KFLAG is a condition value returned by the package after each call to one of
!        the routines.  Negative values indicate conditions for which a warning
!        message will be printed unless KWARN = 0.
!        Positive values indicate conditions that may be of interest but are not
!        errors.  No warning message is printed if KFLAG is nonnegative.

!  Subroutine FMFLAG is provided to give the user access to the current
!  condition code.  For example, to set the user's local variable LFLAG
!  to FM's internal KFLAG value:      CALL FMFLAG(LFLAG)

!    KFLAG =  0     Normal operation.

!          =  1     One of the operands in FMADD or FMSUB was insignificant with
!                       respect to the other, so that the result was equal to
!                       the argument of larger magnitude.
!          =  2     In converting an FM number to a one word integer in FMM2I,
!                       the FM number was not exactly an integer.  The next
!                       integer toward zero was returned.

!          = -1     NDIG was less than 2 or more than NDIGMX.
!          = -2     MBASE was less than 2 or more than MXBASE.
!          = -3     An exponent was out of range.
!          = -4     Invalid input argument(s) to an FM routine.
!                        UNKNOWN was returned.
!          = -5     + or - OVERFLOW was generated as a result from an
!                        FM routine.
!          = -6     + or - UNDERFLOW was generated as a result from an
!                        FM routine.
!          = -7     The input string (array) to FMINP was not legal.
!          = -8     The character array was not large enough in an
!                   input or output routine.
!          = -9     Precision could not be raised enough to provide all
!                        requested guard digits.  Increasing the value
!                        of NDIGMX in file FMSAVE.f90 may fix this.
!                        UNKNOWN was returned.
!          = -10    An FM input argument was too small in magnitude to
!                        convert to the machine's single or double
!                        precision in FMM2SP or FMM2DP.  Check that the
!                        definitions of SPMAX and DPMAX in file FMSAVE.f90
!                        are correct for the current machine.
!                        Zero was returned.
!          = -11    Array MBERN is not dimensioned large enough for the
!                        requested number of Bernoulli numbers.
!          = -12    Array MJSUMS is not dimensioned large enough for
!                        the number of coefficients needed in the
!                        reflection formula in FMPGAM.

!  When a negative KFLAG condition is encountered, the value of KWARN
!  determines the action to be taken.

!  KWARN = 0     Execution continues and no message is printed.
!        = 1     A warning message is printed and execution continues.
!        = 2     A warning message is printed and execution stops.

!  The default setting is KWARN = 1.

!  When an overflow or underflow is generated for an operation in which an input
!  argument was already an overflow or underflow, no additional message is
!  printed.  When an unknown result is generated and an input argument was
!  already unknown, no additional message is printed.  In these cases the
!  negative KFLAG value is still returned.

!  IM routines handle exceptions like OVERFLOW or UNKNOWN in the same way as FM
!  routines.  When using IMMPY, the product of two large positive integers will
!  return +OVERFLOW.  The routines IMMPYM and IMPMOD can be used to obtain a
!  modular result without overflow.  The largest representable IM integer is
!  MBASE**NDIGMX - 1.  For example, if MBASE is 10**7 and NDIGMX is set to 256,
!  integers less than 10**1792 can be used.


!  6. OTHER OPTIONS

!  KRAD = 0     All angles in the trigonometric functions and inverse functions
!               are measured in degrees.
!       = 1     All angles are measured in radians.  (Default)

!  KROUND = -1  All results are rounded toward minus infinity.
!         =  0  All results are rounded toward zero (chopped).
!         =  1  All results are rounded to the nearest FM number, or to the
!               value with an even last digit if the result is halfway
!               between two FM numbers.  (Default)
!         =  2  All results are rounded toward plus infinity.

!         In all cases, while a function is being computed all intermediate
!         results are rounded to nearest, with only the final result being
!         rounded according to KROUND.

!  KRPERF = 0   A smaller number of guard digits used, to give nearly perfect
!               rounding.  This number is chosen so that the last intermediate
!               result should have error less than 0.001 unit in the last place
!               of the final rounded result.  (Default)
!         = 1   Causes more guard digits to be used, to get perfect rounding in
!               the mode set by KROUND.  This slows execution speed.

!         If a small base is used for the arithmetic, like MBASE = 2, 10, or 16,
!         FM assumes that the arithmetic hardware for some machine is being
!         simulated, so perfect rounding is done without regard for the value
!         of KRPERF.
!         If KROUND = 1, then KRPERF = 1 means returned results are no more than
!         0.500 units in the last place from the exact mathematical result,
!         versus 0.501 for KRPERF = 0.
!         If KROUND is not 1, then KRPERF = 1 means returned results are no more
!         than 1.000 units in the last place from the exact mathematical result,
!         versus 1.001 for KRPERF = 0.

!  KSWIDE defines the maximum screen width to be used for all unit KW output.
!         Default is 80.

!  KESWCH controls the action taken in FMINP and other input routines for
!         strings like 'E7' that have no digits before the exponent field.
!         This is sometimes a convenient abbreviation when doing interactive
!         keyboard input.
!         KESWCH = 1 causes 'E7' to translate like '1.0E+7'.  (Default)
!         KESWCH = 0 causes 'E7' to translate like '0.0E+7' and give 0.

!  CMCHAR defines the exponent letter to be used for FM variable output.
!         Default is 'M', as in 1.2345M+678.
!         Change it to 'E' for output to be read by a non-FM program.

!  KDEBUG = 0   No error checking is done to see if input arguments are valid
!               and parameters like NDIG and MBASE are correct upon entry to
!               each routine.  (Default)
!         = 1   Some error checking is done.  (Slower speed)

!  See module FMVALS in file FMSAVE.f90 for additional description of these and
!  other variables defining various FM conditions.


!  7. ARRAY DIMENSIONS

!  The dimensions of the arrays in the FM package are defined using parameters
!  NDIGMX and NBITS.
!  NDIGMX is the maximum value the user may set for NDIG.
!  NBITS  is the number of bits used to represent integers for a given machine.
!         See the EFFICIENCY discussion below.

!  The standard version of FM sets NDIGMX = 55, so on a 32-bit machine using
!  MBASE = 10**7 the maximum precision is about 7*54+1 = 379 significant
!  digits.  Previous versions of FM set NDIGMX = 256.  Two reasons for making
!  this change are:
!  (a) Almost all applications using FM use only 30 to 50 significant digits
!      for checking double or quadruple precision results, and the larger
!      arrays are wasted space.
!  (b) Most FM applications use the derived type interface so that the number
!      of changes to existing code is minimized.  Many compilers implement the
!      FM interface by doing copy in / copy out argument passing of the derived
!      types.  Copying the entire large array when only a small part of it is
!      being used causes the derived type arithmetic to be slow compared to
!      making direct calls to the subroutines.  Setting NDIGMX to be only
!      slightly higher than a program actually uses minimizes any performance
!      penalty for the derived type arithmetic.

!  To change dimensions so that 10,000 significant digit calculation can be
!  done, NDIGMX needs to be at least  10**4/7 + 5 = 1434.  This allows for a
!  few user guard digits to be defined when the precision is changed using
!  CALL FMSET(10000).  Changing 'NDIGMX = 55' to 'NDIGMX = 1434' in FMSAVE.f90
!  will define all the new array sizes.

!  If NDIG much greater than 256 is to be used and elementary functions will
!  be needed, they will be faster if array MJSUMS is larger.  The parameter
!  defining the size of MJSUMS is set in the standard version by
!      LJSUMS = 8*(LUNPCK+3)
!  The 8 means that up to eight concurrent sums can be used by the elementary
!  functions.  The approximate number needed for best speed is given by
!      0.051*Log(MBASE)*NDIG**0.333 + 1.85
!  For example, with MBASE=10**7 and NDIG=1434 this gives 11.  Changing
!  'LJSUMS = 8*(LUNPCK+3)' to 'LJSUMS = 11*(LUNPCK+3)' in FMSAVE.f90 will give
!  slightly better speed.

!  FM numbers in packed format have dimension -1:LPACK, and those in unpacked
!  format have dimension -1:LUNPCK.

!  The parameters LPACKZ and LUNPKZ define the size of the packed and unpacked
!  ZM arrays.  The real part starts at the beginning of the array, and the
!  imaginary part starts at word KPTIMP for packed format or at word KPTIMU for
!  unpacked format.


!  8. PORTABILITY

!  In FMSET several variables are set to machine-dependent values, and many of
!  the variables initialized in module FMVALS in file FMSAVE.f90 are checked to
!  see that they have reasonable values.  FMSET will print warning messages on
!  unit KW for any of the FMVALS variables that seem to be poorly initialized.

!  If an FM run fails, call FMVARS to get a list of all the FMVALS variables
!  printed on unit KW.  Setting KDEBUG = 1 at the start may also identify some
!  errors.

!  Some compilers object to a function like FMCOMP with side effects such as
!  changing KFLAG or other module variables.  Blocks of code in FMCOMP and
!  IMCOMP that modify these variables are identified so they may be removed or
!  commented out to produce a function without side effects.  This disables
!  trace printing in FMCOMP and IMCOMP, and error codes are not returned in
!  KFLAG.  See FMCOMP and IMCOMP for further details.

!  In FMBER2 and FMPGAM several constants are used that require the machine's
!  integer word size to be at least 32 bits.


!  9.  LIST OF ROUTINES

!  These are the FM routines that are designed to be called by the user.
!  All are subroutines except logical function FMCOMP.
!  MA, MB, MC refer to FM format numbers.

!  In Fortran-90 and later versions of the Fortran standard, it is potentially
!  unsafe to use the same array more than once in the calling sequence.  The
!  operation MA = MA + MB should not be written as
!        CALL FMADD(MA,MB,MA)
!  since the compiler is allowed to pass the three arguments with a copy in /
!  copy out mechanism.  This means the third argument, containing the result,
!  might not be copied out last, and then a later copy out of the original
!  input MA could destroy the computed result.

!  One solution is to use a third array and then put the result back in MA:
!        CALL FMADD(MA,MB,MC)
!        CALL FMEQ(MC,MA)

!  When the first call is doing one of the "fast" operations like addition,
!  the extra call to move the result back to MA can cause a noticeable loss in
!  efficiency.  To avoid this, separate routines are provided for the basic
!  arithmetic operations when the result is to be returned in the same array
!  as one of the inputs.

!  A routine name with a suffix of  "_R1" returns the result in the first
!  input array, and a suffix of "_R2" returns the result in the second input
!  array.  The example above would then be:
!        CALL FMADD_R1(MA,MB)

!  These routines each have one less argument than the original version, since
!  the output is re-directed to one of the inputs.  The result array should
!  not be the same as any input array when the original version of the routine
!  is used.

!  The routines that can be used this way are listed below.  For others, like
!        CALL FMEXP(MA,MA)
!  the relative cost of doing an extra copy is small.  This one should become
!        CALL FMEXP(MA,MB)
!        CALL FMEQ(MB,MA)

!  If the derived-type interface is used, as in
!        TYPE (FM) A,B
!        ...
!        A = A + B
!  there is no problem putting the result back into A, since the interface
!  routine creates a temporary scratch array for the result of A + B, allowing
!  copy in / copy out to work.

!  For each of these routines there is also a version available for which the
!  argument list is the same but all FM numbers are in packed format.  The
!  routines using packed numbers have the same names except 'FM' is replaced by
!  'FP' at the start of each name.


!  FMABS(MA,MB)         MB = ABS(MA)

!  FMACOS(MA,MB)        MB = ACOS(MA)

!  FMADD(MA,MB,MC)      MC = MA + MB

!  FMADD_R1(MA,MB)      MA = MA + MB

!  FMADD_R2(MA,MB)      MB = MA + MB

!  FMADDI(MA,IVAL)      MA = MA + IVAL   Increment an FM number by a one word
!                                        integer.  Note this call does not have
!                                        an "MB" result like FMDIVI and FMMPYI.

!  FMASIN(MA,MB)        MB = ASIN(MA)

!  FMATAN(MA,MB)        MB = ATAN(MA)

!  FMATN2(MA,MB,MC)     MC = ATAN2(MA,MB)

!  FMBIG(MA)            MA = Biggest FM number less than overflow.

!  FMCHSH(MA,MB,MC)     MB = COSH(MA),  MC = SINH(MA).
!                            Faster than making two separate calls.

!  FMCOMP(MA,LREL,MB)        Logical comparison of MA and MB.
!                            LREL is a CHARACTER*2 value identifying
!                            which of the six comparisons is to be made.
!                            Example:  IF (FMCOMP(MA,'GE',MB)) ...
!                            Also can be:  IF (FMCOMP(MA,'>=',MB)) ...
!                            CHARACTER*1 is ok:  IF (FMCOMP(MA,'>',MB)) ...

!  FMCONS                    Set several saved constants that depend on MBASE,
!                            the base being used.  FMCONS should be called
!                            immediately after changing MBASE.

!  FMCOS(MA,MB)         MB = COS(MA)

!  FMCOSH(MA,MB)        MB = COSH(MA)

!  FMCSSN(MA,MB,MC)     MB = COS(MA),  MC = SIN(MA).
!                            Faster than making two separate calls.

!  FMDIG(NSTACK,KST)         Find a set of precisions to use during Newton
!                            iteration for finding a simple root starting with
!                            about double precision accuracy.

!  FMDIM(MA,MB,MC)      MC = DIM(MA,MB)

!  FMDIV(MA,MB,MC)      MC = MA / MB

!  FMDIV_R1(MA,MB)      MA = MA / MB

!  FMDIV_R2(MA,MB)      MB = MA / MB

!  FMDIVI(MA,IVAL,MB)   MB = MA/IVAL   IVAL is a one word integer.

!  FMDIVI_R1(MA,IVAL)   MA = MA/IVAL

!  FMDP2M(X,MA)         MA = X    Convert from double precision to FM.

!  FMDPM(X,MA)          MA = X    Convert from double precision to FM.
!                                 Faster than FMDP2M, but MA agrees with X only
!                                 to D.P. accuracy.  See the comments in the
!                                 two routines.

!  FMEQ(MA,MB)          MB = MA   Both have precision NDIG.
!                                 This is the version to use for standard
!                                 B = A  statements.

!  FMEQU(MA,MB,NA,NB)   MB = MA   Version for changing precision.
!                                 MA has NA digits (i.e., MA was computed
!                                 using NDIG = NA), and MB will be defined
!                                 having NB digits.
!                                 MB is rounded if NB < NA
!                                 MB is zero-padded if NB > NA

!  FMEXP(MA,MB)         MB = EXP(MA)

!  FMFLAG(K)            K = KFLAG  get the value of the FM condition
!                                  flag -- stored in the internal FM
!                                  variable KFLAG in module FMVALS.

!  FMFORM(FORM,MA,STRING)    MA is converted to a character string using format
!                               FORM and returned in STRING.  FORM can represent
!                               I, F, E, or 1PE formats.  Example:
!                               CALL FMFORM('F60.40',MA,STRING)

!  FMFPRT(FORM,MA)           Print MA on unit KW using FORM format.

!  FMI2M(IVAL,MA)       MA = IVAL   Convert from one word integer to FM.

!  FMINP(LINE,MA,LA,LB) MA = LINE   Input conversion.
!                                   Convert LINE(LA) through LINE(LB)
!                                   from characters to FM.

!  FMINT(MA,MB)         MB = INT(MA)    Integer part of MA.

!  FMIPWR(MA,IVAL,MB)   MB = MA**IVAL   Raise an FM number to a one word
!                                       integer power.

!  FMLG10(MA,MB)        MB = LOG10(MA)

!  FMLN(MA,MB)          MB = LOG(MA)

!  FMLNI(IVAL,MA)       MA = LOG(IVAL)   Natural log of a one word integer.

!  FMM2DP(MA,X)         X  = MA     Convert from FM to double precision.

!  FMM2I(MA,IVAL)       IVAL = MA   Convert from FM to integer.

!  FMM2SP(MA,X)         X  = MA     Convert from FM to single precision.

!  FMMAX(MA,MB,MC)      MC = MAX(MA,MB)

!  FMMIN(MA,MB,MC)      MC = MIN(MA,MB)

!  FMMOD(MA,MB,MC)      MC = MA mod MB

!  FMMPY(MA,MB,MC)      MC = MA * MB

!  FMMPY_R1(MA,MB)      MA = MA * MB

!  FMMPY_R2(MA,MB)      MB = MA * MB

!  FMMPYI(MA,IVAL,MB)   MB = MA*IVAL    Multiply by a one word integer.

!  FMMPYI_R1(MA,IVAL)   MA = MA*IVAL

!  FMNINT(MA,MB)        MB = NINT(MA)   Nearest FM integer.

!  FMOUT(MA,LINE,LB)    LINE = MA   Convert from FM to character.
!                                   LINE is a character array of length LB.

!  FMPI(MA)             MA = pi

!  FMPRNT(MA)                Print MA on unit KW using current format.

!  FMPWR(MA,MB,MC)      MC = MA**MB

!  FM_RANDOM_NUMBER(X)  X    is returned as a double precision random number,
!                            uniform on (0,1).  High-quality, long-period
!                            generator.
!                            Note that X is double precision, unlike the similar
!                            Fortran intrinsic random number routine, which
!                            returns a single-precision result.
!                            See the comments in section 10 below and also those
!                            in the routine for more details.

!  FMREAD(KREAD,MA)     MA   is returned after reading one (possibly multi-line)
!                            FM number on unit KREAD.  This routine reads
!                            numbers written by FMWRIT.

!  FMRPWR(MA,K,J,MB)    MB = MA**(K/J)  Rational power.
!                            Faster than FMPWR for functions like the cube root.

!  FMSET(NPREC)              Set the internal FM variables so that the precision
!                            is at least NPREC base 10 digits plus three base 10
!                            guard digits.

!  FMSETVAR(STRING)          Define a new value for one of the internal FM
!                            variables in module FMVALS that controls one of the
!                            FM options.  STRING has the form  variable = value.
!                            Example:  To change the screen width for FM output:
!                                  CALL FMSETVAR(' KSWIDE = 120 ')
!                            The variables that can be changed and the options
!                            they control are listed in sections 2 through 6
!                            above.  Only one variable can be set per call.
!                            The variable name in STRING must have no embedded
!                            blanks.  The value part of STRING can be in any
!                            numerical format, except in the case of variable
!                            CMCHAR, which is character type.  To set CMCHAR to
!                            'E', don't use any quotes in STRING:
!                                  CALL FMSETVAR(' CMCHAR = E ')

!  FMSIGN(MA,MB,MC)     MC = SIGN(MA,MB)   Sign transfer.

!  FMSIN(MA,MB)         MB = SIN(MA)

!  FMSINH(MA,MB)        MB = SINH(MA)

!  FMSP2M(X,MA)         MA = X   Convert from single precision to FM.

!  FMSQR(MA,MB)         MB = MA * MA   Faster than FMMPY.

!  FMSQR_R1(MA)         MA = MA * MA

!  FMSQRT(MA,MB)        MB = SQRT(MA)

!  FMSQRT_R1(MA)        MA = SQRT(MA)

!  FMST2M(STRING,MA)    MA = STRING
!                            Convert from character string to FM.
!                            STRING may be in any numerical format.
!                            Often more convenient than FMINP, which converts
!                            an array of CHARACTER*1 values.  Example:
!                                  CALL FMST2M('123.4',MA)

!  FMSUB(MA,MB,MC)      MC = MA - MB

!  FMSUB_R1(MA,MB)      MA = MA - MB

!  FMSUB_R2(MA,MB)      MB = MA - MB

!  FMTAN(MA,MB)         MB = TAN(MA)

!  FMTANH(MA,MB)        MB = TANH(MA)

!  FMULP(MA,MB)         MB = One Unit in the Last Place of MA.

!  FMVARS                    Write the current values of the internal FM
!                            variables on unit KW.

!  FMWRIT(KWRITE,MA)         Write MA on unit KWRITE.
!                            Multi-line numbers will have '&' as the last
!                            nonblank character on all but the last line.  These
!                            numbers can then be read easily using FMREAD.



!  These are the Gamma and Related Functions.

!  FMBERN(N,MA,MB)      MB = MA*B(N)  Multiply by Nth Bernoulli number

!  FMBETA(MA,MB,MC)     MC = Beta(MA,MB)

!  FMCOMB(MA,MB,MC)     MC = Combination MA choose MB  (Binomial coeff.)

!  FMEULR(MA)           MA = Euler's constant ( 0.5772156649... )

!  FMFACT(MA,MB)        MB = MA Factorial  (Gamma(MA+1))

!  FMGAM(MA,MB)         MB = Gamma(MA)

!  FMIBTA(MX,MA,MB,MC)  MC = Incomplete Beta(MX,MA,MB)

!  FMIGM1(MA,MB,MC)     MC = Incomplete Gamma(MA,MB).  Lower case Gamma(a,x)

!  FMIGM2(MA,MB,MC)     MC = Incomplete Gamma(MA,MB).  Upper case Gamma(a,x)

!  FMLNGM(MA,MB)        MB = Ln(Gamma(MA))

!  FMPGAM(N,MA,MB)      MB = Polygamma(N,MA)  (Nth derivative of Psi)

!  FMPOCH(MA,N,MB)      MB = MA*(MA+1)*(MA+2)*...*(MA+N-1)  (Pochhammer)

!  FMPSI(MA,MB)         MB = Psi(MA)      (Derivative of Ln(Gamma(MA))



!  These are the integer routines that are designed to be called by the user.
!  All are subroutines except logical function IMCOMP.  MA, MB, MC refer to IM
!  format numbers.  In each case the version of the routine to handle packed IM
!  numbers has the same name, with 'IM' replaced by 'IP'.

!  IMABS(MA,MB)         MB = ABS(MA)

!  IMADD(MA,MB,MC)      MC = MA + MB

!  IMBIG(MA)            MA = Biggest IM number less than overflow.

!  IMCOMP(MA,LREL,MB)        Logical comparison of MA and MB.
!                            LREL is a CHARACTER*2 value identifying which of
!                            the six comparisons is to be made.
!                            Example:  IF (IMCOMP(MA,'GE',MB)) ...
!                            Also can be:  IF (IMCOMP(MA,'>=',MB))
!                            CHARACTER*1 is ok:  IF (IMCOMP(MA,'>',MB)) ...

!  IMDIM(MA,MB,MC)      MC = DIM(MA,MB)

!  IMDIV(MA,MB,MC)      MC = int(MA/MB)
!                            Use IMDIVR if the remainder is also needed.

!  IMDIVI(MA,IVAL,MB)   MB = int(MA/IVAL)
!                            IVAL is a one word integer.
!                            Use IMDVIR to get the remainder also.

!  IMDIVR(MA,MB,MC,MD)  MC = int(MA/MB),   MD = MA mod MB
!                            When both the quotient and remainder are needed,
!                            this routine is twice as fast as calling both
!                            IMDIV and IMMOD.

!  IMDVIR(MA,IVAL,MB,IREM)   MB = int(MA/IVAL),   IREM = MA mod IVAL
!                            IVAL and IREM are one word integers.

!  IMEQ(MA,MB)          MB = MA

!  IMFM2I(MAFM,MB)      MB = MAFM  Convert from real (FM) format to
!                                  integer (IM) format.

!  IMFORM(FORM,MA,STRING)    MA is converted to a character string using format
!                               FORM and returned in STRING.  FORM can represent
!                               I, F, E, or 1PE formats.  Example:
!                               CALL IMFORM('I70',MA,STRING)

!  IMFPRT(FORM,MA)           Print MA on unit KW using FORM format.

!  IMGCD(MA,MB,MC)      MC = greatest common divisor of MA and MB.

!  IMI2FM(MA,MBFM)      MBFM = MA  Convert from integer (IM) format to
!                                  real (FM) format.

!  IMI2M(IVAL,MA)       MA = IVAL   Convert from one word integer to IM.

!  IMINP(LINE,MA,LA,LB) MA = LINE   Input conversion.
!                                   Convert LINE(LA) through LINE(LB)
!                                   from characters to IM.

!  IMM2DP(MA,X)         X  = MA     Convert from IM to double precision.

!  IMM2I(MA,IVAL)       IVAL = MA   Convert from IM to one word integer.

!  IMMAX(MA,MB,MC)      MC = MAX(MA,MB)

!  IMMIN(MA,MB,MC)      MC = MIN(MA,MB)

!  IMMOD(MA,MB,MC)      MC = MA mod MB

!  IMMPY(MA,MB,MC)      MC = MA*MB

!  IMMPYI(MA,IVAL,MB)   MB = MA*IVAL    Multiply by a one word integer.

!  IMMPYM(MA,MB,MC,MD)  MD = MA*MB mod MC
!                            Slightly faster than calling IMMPY and IMMOD
!                            separately, and it works for cases where IMMPY
!                            would return OVERFLOW.

!  IMOUT(MA,LINE,LB)    LINE = MA   Convert from IM to character.
!                                   LINE is a character array of length LB.

!  IMPMOD(MA,MB,MC,MD)  MD = MA**MB mod MC

!  IMPRNT(MA)                Print MA on unit KW.

!  IMPWR(MA,MB,MC)      MC = MA**MB

!  IMREAD(KREAD,MA)     MA   is returned after reading one (possibly multi-line)
!                            IM number on unit KREAD.
!                            This routine reads numbers written by IMWRIT.

!  IMSIGN(MA,MB,MC)     MC = SIGN(MA,MB)   Sign transfer.

!  IMSQR(MA,MB)         MB = MA*MA   Faster than IMMPY.

!  IMST2M(STRING,MA)    MA = STRING
!                            Convert from character string to IM.
!                            Often more convenient than IMINP, which converts an
!                            array of CHARACTER*1 values.  Example:
!                                 CALL IMST2M('12345678901',MA)

!  IMSUB(MA,MB,MC)      MC = MA - MB

!  IMWRIT(KWRITE,MA)         Write MA on unit KWRITE.
!                            Multi-line numbers will have '&' as the last
!                            nonblank character on all but the last line.
!                            These numbers can then be read easily using IMREAD.



!  These are the complex routines that are designed to be called by the user.
!  All are subroutines, and in each case the version of the routine to handle
!  packed ZM numbers has the same name, with 'ZM' replaced by 'ZP'.

!  MA, MB, MC refer to ZM format complex numbers.
!  MAFM, MBFM, MCFM refer to FM format real numbers.
!  INTEG is a Fortran INTEGER variable.
!  ZVAL is a Fortran COMPLEX variable.

!  ZMABS(MA,MBFM)       MBFM = ABS(MA)    Result is real.

!  ZMACOS(MA,MB)        MB = ACOS(MA)

!  ZMADD(MA,MB,MC)      MC = MA + MB

!  ZMADDI(MA,INTEG)     MA = MA + INTEG  Increment an ZM number by a one word
!                                        integer.  Note this call does not have
!                                        an "MB" result like ZMDIVI and ZMMPYI.

!  ZMARG(MA,MBFM)       MBFM = Argument(MA)    Result is real.

!  ZMASIN(MA,MB)        MB = ASIN(MA)

!  ZMATAN(MA,MB)        MB = ATAN(MA)

!  ZMCHSH(MA,MB,MC)     MB = COSH(MA),  MC = SINH(MA).
!                            Faster than 2 calls.

!  ZMCMPX(MAFM,MBFM,MC) MC = CMPLX(MAFM,MBFM)

!  ZMCONJ(MA,MB)        MB = CONJG(MA)

!  ZMCOS(MA,MB)         MB = COS(MA)

!  ZMCOSH(MA,MB)        MB = COSH(MA)

!  ZMCSSN(MA,MB,MC)     MB = COS(MA),  MC = SIN(MA).
!                            Faster than 2 calls.

!  ZMDIV(MA,MB,MC)      MC = MA / MB

!  ZMDIVI(MA,INTEG,MB)  MB = MA / INTEG

!  ZMEQ(MA,MB)          MB = MA

!  ZMEQU(MA,MB,NDA,NDB) MB = MA    Version for changing precision.
!                                  (NDA and NDB are as in FMEQU)

!  ZMEXP(MA,MB)         MB = EXP(MA)

!  ZMFORM(FORM1,FORM2,MA,STRING)   STRING = MA
!                       MA is converted to a character string using format
!                       FORM1 for the real part and FORM2 for the imaginary
!                       part.  The  result is returned in STRING.  FORM1 and
!                       FORM2 can represent I, F, E, or 1PE formats.  Example:
!                             CALL ZMFORM('F20.10','F15.10',MA,STRING)
!                       A 1PE in the first format does not carry over to the
!                       other format descriptor, as it would in an ordinary
!                       FORMAT statement.

!  ZMFPRT(FORM1,FORM2,MA)    Print MA on unit KW using formats FORM1 and FORM2.

!  ZMI2M(INTEG,MA)           MA = CMPLX(INTEG,0)

!  ZM2I2M(INTEG1,INTEG2,MA)  MA = CMPLX(INTEG1,INTEG2)

!  ZMIMAG(MA,MBFM)           MBFM = IMAG(MA)    Imaginary part.

!  ZMINP(LINE,MA,LA,LB)      MA = LINE   Input conversion.
!                                 Convert LINE(LA) through LINE(LB) from
!                                 characters to ZM.  LINE is a character array
!                                 of length at least LB.

!  ZMINT(MA,MB)         MB = INT(MA)        Integer part of both Real
!                                           and Imaginary parts of MA.

!  ZMIPWR(MA,INTEG,MB)  MB = MA ** INTEG    Integer power function.

!  ZMLG10(MA,MB)        MB = LOG10(MA)

!  ZMLN(MA,MB)          MB = LOG(MA)

!  ZMM2I(MA,INTEG)      INTEG = INT(REAL(MA))

!  ZMM2Z(MA,ZVAL)       ZVAL = MA

!  ZMMPY(MA,MB,MC)      MC = MA * MB

!  ZMMPYI(MA,INTEG,MB)  MB = MA * INTEG

!  ZMNINT(MA,MB)        MB = NINT(MA)   Nearest integer of both Real
!                                       and Imaginary.

!  ZMOUT(MA,LINE,LB,LAST1,LAST2)        LINE = MA
!                       Convert from FM to character.
!                       LINE  is the returned character*1 array.
!                       LB    is the dimensioned size of LINE.
!                       LAST1 is returned as the position in LINE of
!                             the last character of REAL(MA).
!                       LAST2 is returned as the position in LINE
!                             of the last character of AIMAG(MA).

!  ZMPRNT(MA)           Print MA on unit KW using current format.

!  ZMPWR(MA,MB,MC)      MC = MA ** MB

!  ZMREAD(KREAD,MA)     MA   is returned after reading one (possibly multi-line)
!                            ZM number on unit KREAD.
!                            This routine reads numbers written by ZMWRIT.

!  ZMREAL(MA,MBFM)      MBFM = REAL(MA)    Real part.

!  ZMRPWR(MA,IVAL,JVAL,MB)     MB = MA ** (IVAL/JVAL)

!  ZMSET(NPREC)         Set precision to the equivalent of a few more than NPREC
!                       base 10 digits.  This is now the same as FMSET, but is
!                       retained for compatibility with earlier versions of the
!                       package.

!  ZMSIN(MA,MB)         MB = SIN(MA)

!  ZMSINH(MA,MB)        MB = SINH(MA)

!  ZMSQR(MA,MB)         MB = MA*MA    Faster than ZMMPY.

!  ZMSQRT(MA,MB)        MB = SQRT(MA)

!  ZMST2M(STRING,MA)    MA = STRING
!                            Convert from character string to ZM.
!                            Often more convenient than ZMINP, which
!                            converts an array of CHARACTER*1 values.
!                            Example: CALL ZMST2M('123.4+5.67i',MA).

!  ZMSUB(MA,MB,MC)      MC = MA - MB

!  ZMTAN(MA,MB)         MB = TAN(MA)

!  ZMTANH(MA,MB)        MB = TANH(MA)

!  ZMWRIT(KWRITE,MA)    Write MA on unit KWRITE.  Multi-line numbers are
!                       formatted for automatic reading with ZMREAD.

!  ZMZ2M(ZVAL,MA)       MA = ZVAL


!  10. NEW FOR VERSION 1.2

!  Version 1.2 is written in Fortran-90 free source format.

!  The routines for the Gamma function and related mathematical special
!  functions are new in version 1.2.

!  Several new derived-type function interfaces are included in module FMZM in
!  file FMZM90.f90, such as integer multiple precision operations GCD, modular
!  multiplication, and modular powers.  There are also formatting functions and
!  function interfaces for the Gamma and related special functions.

!  Two new rounding modes have been added, round toward -infinity and round
!  toward +infinity.  See the description of KROUND above.
!  An option has been added to force more guard digits to be used, so that basic
!  arithmetic operations will always round perfectly.  See the description of
!  KRPERF above.
!  These options are included for applications that use FM to check IEEE
!  hardware arithmetic.  They are not normally useful for most multiple
!  precision calculations.

!  The random number routine FM_RANDOM_NUMBER uses 49-digit prime numbers in a
!  shuffled multiplicative congruential generator.  Historically, some popular
!  random number routines tried so hard for maximum speed that they were later
!  found to fail some tests for randomness.  FM_RANDOM_NUMBER tries to return
!  high-quality random values.  It is much slower than other generators, but can
!  return about 60,000 numbers per second on a 400 MHz single-processor machine.
!  This is usually fast enough to be used as a check for suspicious monte carlo
!  results from other generators.
!  For more details, see the comments in the routine.

!  The arrays for multiple precision numbers were dimensioned starting at 0 in
!  version 1.1, and now begin at -1.  Array(-1) now holds the sign of the number
!  instead of combining the sign with Array(2) as before.  The reason for moving
!  the sign bit is that many of the original routines, written before Fortran-90
!  existed, simplified the logic by temporarily making input arguments positive,
!  working with positive values, then restoring the signs to the input arguments
!  upon return.  This became illegal under Fortran-90 when used with the derived
!  type interface, which demands the inputs to functions for arithmetic operator
!  overloading be declared with INTENT(IN).

!  The common blocks of earlier versions have been replaced by module FMVALS.
!  This makes it easier to hide the FM internal variable names from the calling
!  program, and these variables can be initialized in the module so the
!  initializing call to FMSET is no longer mandatory.  Several new routines are
!  provided to set or return the values for some of these variables.  See the
!  descriptions for FMSETVAR, FMFLAG, and FMVARS above.

!  Version 1.0 used integer arrays and integer arithmetic internally to perform
!  the multiple precision operations.  Later versions use double precision
!  arithmetic and arrays internally.  This is usually faster at higher
!  precisions, and on many machines it is also faster at lower precisions.
!  Version 1.2 is written so that the arithmetic used can easily be changed from
!  double precision to integer, or any other available arithmetic type.  This
!  permits the user to make the best use of a given machine's arithmetic
!  hardware.  See the EFFICIENCY discussion below.


!  11. EFFICIENCY

!  When the derived type interface is used to access the FM routines, there may
!  be a loss of speed if the arrays used to define the multiple precision data
!  types are larger than necessary.  See comment (b) in the section above on
!  array dimensions.

!  To take advantage of hardware architecture on different machines, the package
!  has been designed so that the arithmetic used to perform the multiple
!  precision operations can easily be changed.  All variables that must be
!  changed to get a different arithmetic have names beginning with 'M' and are
!  declared using REAL (KIND(1.0D0)) ...

!  For example, to change the package to use integer arithmetic internally, make
!  these two changes everywhere in the FM.f90 file.
!  Change  'REAL (KIND(1.0D0))'  to  'INTEGER'.
!  Change  'AINT ('  to  'INT('.  Note the blank between AINT and (.
!  On some systems, changing  'AINT ('  to  '('  may give better speed.

!  In most places in FM, an AINT function is not supposed to be changed.  These
!  are written 'AINT(', with no embedded blank, so they will not be changed by
!  the global change above.

!  The first of these changes must also be made throughout the files FMZM90.f90
!  and FMSAVE.f90.
!  Change  'REAL (KIND(1.0D0))'  to  'INTEGER'.

!  Many of the variables in FMSAVE.f90 are initialized when they are declared,
!  so the initialization values should be changed to integer values.
!  Find the lines beginning '! Integer initialization' in file FMSAVE.f90 and
!  change the values.  The values needed for 32-bit integer arithmetic are next
!  to the double precision values, but commented out.  In every case, the line
!  before the '! Integer initialization' should have '!' inserted in column 1
!  and the line after should have the '!' removed from column 1.  If a different
!  wordsize is used, the first call to FMSET will check the values defined in
!  file FMSAVE.f90 and write messages (on unit KW) if any need to be changed.

!  When changing to a different type of arithmetic, any FM arrays in the user's
!  program must be changed to agree.  If derived types are used instead of
!  direct calls, no changes should be needed in the calling program.

!  For example, in the test program TestFM.f90, change all
!  'REAL (KIND(1.0D0))'  to  'INTEGER', as with the other files.

!  This version of FM restricts the base used to be also representable in
!  integer variables, so using precision above double usually does not save much
!  time unless integers can also be declared at a higher precision.  Using IEEE
!  Extended would allow a base of around 10**9 to be chosen, but the delayed
!  digit-normalization method used for multiplication and division means that a
!  slightly smaller base like 10**8 would probably run faster.  This would
!  usually not be much faster than using the usual base 10**7 with double
!  precision.

!  The value of NBITS defined as a parameter in FMVALS refers to the number of
!  bits used to represent integers in an M-variable word.  Typical values for
!  NBITS are:  24 for IEEE single precision, 32 for integer, 53 for IEEE double
!  precision.  NBITS controls only array size, so setting it too high is ok, but
!  then the program will use slightly more memory than necessary.

!  For cases where special compiler directives or minor re-writing of the code
!  may improve speed, several of the most important loops in FM are identified
!  by comments containing the string '(Inner Loop)'.

! ------------------------------------------------------------------------------
! ------------------------------------------------------------------------------


      SUBROUTINE FMSET(NPREC)

!  Initialize the global FM variables that must be set before calling
!  other FM routines.  These variables are initialized to fairly standard
!  values in the FMSAVE.f90 file (MODULE FMVALS), so calling FMSET at the
!  beginning of a program is now optional.  FMSET is a convenient way to set
!  or change the precision being used, and it also checks to see that the
!  generic values chosen for several machine-dependent variables are valid.

!  Base and precision will be set to give at least NPREC+3 decimal
!  digits of precision (giving the user three base ten guard digits).

!  MBASE (base for FM arithmetic) is set to a large power of ten.
!  JFORM1 and JFORM2 (default output format controls) are set to 1PE format
!  displaying NPREC significant digits.

!  Several FM options were set here in previous versions of the package,
!  and are now initialized to their default values in module FMVALS.
!  Here are the initial settings:

!  The trace option is set off.
!  The mode for angles in trig functions is set to radians.
!  The rounding mode is set to symmetric rounding.
!  Warning error message level is set to 1.
!  Cancellation error monitor is set off.
!  Screen width for output is set to 80 columns.
!  The exponent character for FM output is set to 'M'.
!  Debug error checking is set off.

      USE FMVALS
      IMPLICIT NONE

      INTEGER NPREC

      REAL (KIND(1.0D0)) :: MAXINT_CHK,MXEXP2_CHK,MEXPOV_CHK,MEXPUN_CHK,  &
                            MUNKNO_CHK
      DOUBLE PRECISION DPEPS_CHK,DPMAX_CHK,SPMAX_CHK,TEMP
      INTEGER INTMAX_CHK,K,NPSAVE

      IF (NBITS < DIGITS(MAXINT)) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' NBITS was set to ',NBITS,' in file FMSAVE.f90'
          WRITE (KW,*) ' For this machine it should be at least ',DIGITS(MAXINT)
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' '
          WRITE (KW,*) ' NBITS is a parameter that controls array size, so its'
          WRITE (KW,*) ' value cannot be changed for this run, and this might'
          WRITE (KW,*) ' cause some FM operations to get incorrect results.'
          WRITE (KW,*) ' '
      ENDIF

!             MAXINT should be set to a very large integer, possibly
!                    the largest representable integer for the current
!                    machine.  For most 32-bit machines, MAXINT is set
!                    to  2**53 - 1 = 9.007D+15  when double precision
!                    arithmetic is used for M-variables.  Using integer
!                    M-variables usually gives MAXINT = 2**31 - 1 =
!                    2147483647.

!                    Setting MAXINT to a smaller number is ok, but this
!                    unnecessarily restricts the permissible range of
!                    MBASE and MXEXP.

      MAXINT_CHK = RADIX(MAXINT_CHK)
      MAXINT_CHK = ((MAXINT_CHK**(DIGITS(MAXINT_CHK)-1)-1)*MAXINT_CHK - 1) +  &
                     MAXINT_CHK
      IF (MAXINT > MAXINT_CHK) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' MAXINT was set to ',MAXINT,' in file FMSAVE.f90'
          WRITE (KW,*) ' For this machine it should be no more than ',MAXINT_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, MAXINT has been changed to ',MAXINT_CHK
          WRITE (KW,*) ' '
          MAXINT = MAXINT_CHK
      ELSE IF (MAXINT < MAXINT_CHK/2) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' MAXINT was set to ',MAXINT,' in file FMSAVE.f90'
          WRITE (KW,*) ' For better performance set it to ',MAXINT_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, MAXINT has been changed to ',MAXINT_CHK
          WRITE (KW,*) ' '
          MAXINT = MAXINT_CHK
      ENDIF

!             INTMAX is a large value close to the overflow threshold
!                    for integer variables.  It is usually 2**31 - 1
!                    for machines with 32-bit integer arithmetic.

!                    The following code sets INTMAX_CHK to the
!                    largest representable integer.
!                    Then INTMAX is checked against this value.

      INTMAX_CHK = HUGE(1)
      IF (INTMAX > INTMAX_CHK) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' INTMAX was set to ',INTMAX,' in file FMSAVE.f90'
          WRITE (KW,*) ' For this machine it should be no more than ',INTMAX_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, INTMAX has been changed to ',INTMAX_CHK
          WRITE (KW,*) ' '
          INTMAX = INTMAX_CHK
      ELSE IF (INTMAX < INTMAX_CHK/2) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' INTMAX was set to ',INTMAX,' in file FMSAVE.f90'
          WRITE (KW,*) ' For better performance set it to ',INTMAX_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, INTMAX has been changed to ',INTMAX_CHK
          WRITE (KW,*) ' '
          INTMAX = INTMAX_CHK
      ENDIF

!             DPMAX should be set to a value near the machine's double
!                   precision overflow threshold, so that DPMAX and
!                   1.0D0/DPMAX are both representable in double
!                   precision.

      DPMAX_CHK = HUGE(1.0D0)/5
      IF (DPMAX > DPMAX_CHK) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' DPMAX was set to ',DPMAX,' in file FMSAVE.f90'
          WRITE (KW,*) ' For this machine it should be no more than ',DPMAX_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, DPMAX has been changed to ',DPMAX_CHK
          WRITE (KW,*) ' '
          DPMAX = DPMAX_CHK
      ELSE IF (DPMAX < DPMAX_CHK/1.0D2) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' DPMAX was set to ',DPMAX,' in file FMSAVE.f90'
          WRITE (KW,*) ' For better performance set it to ',DPMAX_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, DPMAX has been changed to ',DPMAX_CHK
          WRITE (KW,*) ' '
          DPMAX = DPMAX_CHK
      ENDIF

!             SPMAX should be set to a value near the machine's single
!                   precision overflow threshold, so that 1.01*SPMAX
!                   and 1.0/SPMAX are both representable in single
!                   precision.

      SPMAX_CHK = HUGE(1.0)/5
      IF (SPMAX > SPMAX_CHK) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' SPMAX was set to ',SPMAX,' in file FMSAVE.f90'
          WRITE (KW,*) ' For this machine it should be no more than ',SPMAX_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, SPMAX has been changed to ',SPMAX_CHK
          WRITE (KW,*) ' '
          SPMAX = SPMAX_CHK
      ELSE IF (SPMAX < SPMAX_CHK/1.0D2) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' SPMAX was set to ',SPMAX,' in file FMSAVE.f90'
          WRITE (KW,*) ' For better performance set it to ',SPMAX_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, SPMAX has been changed to ',SPMAX_CHK
          WRITE (KW,*) ' '
          SPMAX = SPMAX_CHK
      ENDIF

!             MXBASE is the maximum value for MBASE.

      TEMP = MAXINT
      TEMP = INT(MIN(DBLE(INTMAX),SQRT(TEMP)))
      IF (MXBASE > TEMP) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' MXBASE was set to ',MXBASE,' in file FMSAVE.f90'
          WRITE (KW,*) ' For this machine it should be no more than ',TEMP
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, MXBASE has been changed to ',TEMP
          WRITE (KW,*) ' '
          MXBASE = TEMP
      ELSE IF (MXBASE < TEMP/2) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' MXBASE was set to ',MXBASE,' in file FMSAVE.f90'
          WRITE (KW,*) ' For better performance set it to ',TEMP
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, MXBASE has been changed to ',TEMP
          WRITE (KW,*) ' '
          MXBASE = TEMP
      ENDIF

!             MBASE is the currently used base for arithmetic.

      K = INT(LOG10(DBLE(MXBASE)/4))
      MBASE = 10**K

!             NDIG is the number of digits currently being carried.

      NPSAVE = NPREC
      NDIG = 2 + (NPREC+2)/K
      IF (NDIG < 2 .OR. NDIG > NDIGMX) THEN
          NDIG = MAX(2,NDIG)
          NDIG = MIN(NDIGMX,NDIG)
          WRITE (KW,  &
                 "(//' Precision out of range when calling FMSET.',"  //  &
                 "'  NPREC =',I20/' The nearest valid NDIG will be'," //  &
                 "' used instead:   NDIG =',I6//)"                        &
                ) NPREC,NDIG
          NPSAVE = 0
      ENDIF

!             NCALL is the call stack pointer.

      NCALL = 0

!             MXEXP  is the current maximum exponent.
!             MXEXP2 is the internal maximum exponent.  This is used to
!                    define the overflow and underflow thresholds.

!             These values are chosen so that FM routines can raise the
!             overflow/underflow limit temporarily while computing
!             intermediate results, and so that EXP(INTMAX) is greater
!             than MXBASE**(MXEXP2+1).

!             The overflow threshold is MBASE**(MXEXP+1), and the
!             underflow threshold is MBASE**(-MXEXP-1).
!             This means the valid exponents in the first word of an FM
!             number can range from -MXEXP to MXEXP+1 (inclusive).

      MXEXP = INT((DBLE(INTMAX))/(2.0D0*LOG(DBLE(MXBASE))) - 1.0D0)
      MXEXP2_CHK = INT(2*MXEXP + MXEXP/100)
      IF (MXEXP2 > MXEXP2_CHK*1.01) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' MXEXP2 was set to ',MXEXP2,' in file FMSAVE.f90'
          WRITE (KW,*) ' For this machine it should be no more than ',MXEXP2_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, MXEXP2 has been changed to ',MXEXP2_CHK
          WRITE (KW,*) ' '
          MXEXP2 = MXEXP2_CHK
      ELSE IF (MXEXP2 < MXEXP2_CHK*0.99) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' MXEXP2 was set to ',MXEXP2,' in file FMSAVE.f90'
          WRITE (KW,*) ' For this machine it should be no less than ',MXEXP2_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, MXEXP2 has been changed to ',MXEXP2_CHK
          WRITE (KW,*) ' '
          MXEXP2 = MXEXP2_CHK
      ENDIF

!             KACCSW is a switch used to enable cancellation error
!                    monitoring.  Routines where cancellation is
!                    not a problem run faster by skipping the
!                    cancellation monitor calculations.
!                    KACCSW = 0 means no error monitoring,
!                           = 1 means error monitoring is done.

      KACCSW = 0

!             MEXPUN is the exponent used as a special symbol for
!                    underflowed results.

      MEXPUN_CHK = -AINT(MXEXP2*1.01D0)
      IF (MEXPUN < MEXPUN_CHK*1.01) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' MEXPUN was set to ',MEXPUN,' in file FMSAVE.f90'
          WRITE (KW,*) ' For this machine it should be no less than ',MEXPUN_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, MEXPUN has been changed to ',MEXPUN_CHK
          WRITE (KW,*) ' '
          MEXPUN = MEXPUN_CHK
      ELSE IF (MEXPUN > MEXPUN_CHK) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' MEXPUN was set to ',MEXPUN,' in file FMSAVE.f90'
          WRITE (KW,*) ' For this machine it should be no more than ',MEXPUN_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, MEXPUN has been changed to ',MEXPUN_CHK
          WRITE (KW,*) ' '
          MEXPUN = MEXPUN_CHK
      ENDIF

!             MEXPOV is the exponent used as a special symbol for
!                    overflowed results.

      MEXPOV_CHK = -MEXPUN
      IF (MEXPOV /= MEXPOV_CHK) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' MEXPOV was set to ',MEXPOV,' in file FMSAVE.f90'
          WRITE (KW,*) ' For this machine it should be ',MEXPOV_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, MEXPOV has been changed to ',MEXPOV_CHK
          WRITE (KW,*) ' '
          MEXPOV = MEXPOV_CHK
      ENDIF

!             MUNKNO is the exponent used as a special symbol for
!                    unknown FM results (1/0, SQRT(-3.0), ...).

      MUNKNO_CHK = AINT(MEXPOV*1.01D0)
      IF (MUNKNO > MUNKNO_CHK*1.01) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' MUNKNO was set to ',MUNKNO,' in file FMSAVE.f90'
          WRITE (KW,*) ' For this machine it should be no more than ',MUNKNO_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, MUNKNO has been changed to ',MUNKNO_CHK
          WRITE (KW,*) ' '
          MUNKNO = MUNKNO_CHK
      ELSE IF (MUNKNO < MUNKNO_CHK) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' MUNKNO was set to ',MUNKNO,' in file FMSAVE.f90'
          WRITE (KW,*) ' For this machine it should be no less than ',MUNKNO_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, MUNKNO has been changed to ',MUNKNO_CHK
          WRITE (KW,*) ' '
          MUNKNO = MUNKNO_CHK
      ENDIF

!             RUNKNO is returned from FM to real or double conversion
!                    routines when no valid result can be expressed in
!                    real or double precision.  On systems that provide
!                    a value for undefined results (e.g., Not A Number)
!                    setting RUNKNO to that value is reasonable.  On
!                    other systems set it to a value that is likely to
!                    make any subsequent results obviously wrong that
!                    use it.  In either case a KFLAG = -4 condition is
!                    also returned.

      RUNKNO = -1.01*SPMAX

!             IUNKNO is returned from FM to integer conversion routines
!                    when no valid result can be expressed as a one word
!                    integer.  KFLAG = -4 is also set.

      IUNKNO = -INT(MXEXP2)

!             DPEPS is the approximate machine precision.

      DPEPS_CHK = EPSILON(1.0D0)
      IF (DPEPS > DPEPS_CHK*1.01) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' DPEPS was set to ',DPEPS,' in file FMSAVE.f90'
          WRITE (KW,*) ' For this machine it should be no more than ',DPEPS_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, DPEPS has been changed to ',DPEPS_CHK
          WRITE (KW,*) ' '
          DPEPS = DPEPS_CHK
      ELSE IF (DPEPS < DPEPS_CHK*0.99) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
          WRITE (KW,*) ' DPEPS was set to ',DPEPS,' in file FMSAVE.f90'
          WRITE (KW,*) ' For this machine it should be no less than ',DPEPS_CHK
          WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
          WRITE (KW,*) ' For this run, DPEPS has been changed to ',DPEPS_CHK
          WRITE (KW,*) ' '
          DPEPS = DPEPS_CHK
      ENDIF

!             JFORM1 indicates the format used by FMOUT.

      JFORM1 = 1

!             JFORM2 indicates the number of digits used in FMOUT.

      JFORM2 = NPSAVE

!             Set JFORMZ to ' 1.23 + 4.56 i ' format.

      JFORMZ = 1

!             Set JPRNTZ to print real and imaginary parts on one
!             line whenever possible.

      JPRNTZ = 1

!             Initialize two hash tables that are used for character
!             look-up during input conversion.

      CALL FMHTBL

!             FMCONS sets several real and double precision constants.

      CALL FMCONS


      RETURN
      END SUBROUTINE FMSET

      SUBROUTINE FMABS(MA,MB)

!  MB = ABS(MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MD2B
      INTEGER KWRNSV

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMABS '
      IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)

      KFLAG = 0
      KWRNSV = KWARN
      KWARN = 0
      CALL FMEQ(MA,MB)
      MB(-1) = 1
      KWARN = KWRNSV

      IF (KACCSW == 1) THEN
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
          MB(0) = MIN(MB(0),MD2B)
      ENDIF
      IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMABS

      SUBROUTINE FMACOS(MA,MB)

!  MB = ACOS(MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
      INTEGER J,K,KASAVE,KOVUN,KRESLT,NDSAVE

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB .OR. MA(1) > 0 .OR. MA(2) == 0) THEN
          CALL FMENTR('FMACOS',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMACOS'
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52-1,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,MB,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      MAS = MA(-1)
      MACCA = MA(0)
      CALL FMEQ2(MA,MB,NDSAVE,NDIG)
      MB(0) = NINT(NDIG*ALOGM2)

!             Use ACOS(X) = ATAN(SQRT(1-X*X)/X)

      MB(-1) = 1
      CALL FMI2M(1,M05)
      CALL FMSUB(M05,MB,M03)
      CALL FMADD(M05,MB,M04)
      CALL FMMPY_R2(M03,M04)
      CALL FMSQRT_R1(M04)
      CALL FMDIV_R2(M04,MB)

      CALL FMATAN(MB,M13)
      CALL FMEQ(M13,MB)

      IF (MAS < 0) THEN
          IF (KRAD == 1) THEN
              CALL FMPI(M05)
          ELSE
              CALL FMI2M(180,M05)
          ENDIF
          CALL FMSUB_R2(M05,MB)
      ENDIF

!             Round the result and return.

      MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
      MB(0) = MIN(MB(0),MACCA,MACMAX)
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMACOS

      SUBROUTINE FMADD(MA,MB,MC)

!  MC = MA + MB

!  This routine performs the trace printing for addition.
!  FMADD2 is used to do the arithmetic.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMADD '
          CALL FMNTR(2,MA,MB,2,1)

          CALL FMADD2(MA,MB,MC)

          CALL FMNTR(1,MC,MC,1,1)
      ELSE
          CALL FMADD2(MA,MB,MC)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMADD

      SUBROUTINE FMADD2(MA,MB,MC)

!  Internal addition routine.  MC = MA + MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MA0,MA1,MA2,MAS,MB0,MB1,MB2,MB2RD,MBS
      INTEGER J,JCOMP,JRSSAV,JSIGN,KRESLT,N1,NGUARD,NMWA
      REAL B2RDA,B2RDB

      IF (MBLOGS /= MBASE) CALL FMCONS
      JRSSAV = JRSIGN
      MA2 = MA(2)
      MB2 = MB(2)
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR.  &
          KDEBUG == 1) THEN
          IF (KSUB == 1) THEN
              CALL FMARGS('FMSUB ',2,MA,MB,KRESLT)
          ELSE
              CALL FMARGS('FMADD ',2,MA,MB,KRESLT)
          ENDIF
          IF (KRESLT /= 0) THEN
              IF ((KRESLT /= 1 .AND. KRESLT /= 2) .OR. MA(2) == 0 .OR.  &
                  MB(2) == 0) THEN
                  NCALL = NCALL + 1
                  IF (KSUB == 1) THEN
                      NAMEST(NCALL) = 'FMSUB '
                  ELSE
                      NAMEST(NCALL) = 'FMADD '
                  ENDIF
                  CALL FMRSLT(MA,MB,MC,KRESLT)
                  JRSIGN = JRSSAV
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
      ELSE
          IF (MA(2) == 0) THEN
              MA0 = MIN(MA(0),MB(0))
              CALL FMEQ(MB,MC)
              MC(0) = MA0
              KFLAG = 1
              IF (KSUB == 1) THEN
                  IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
                  KFLAG = 0
              ENDIF
              JRSIGN = JRSSAV
              RETURN
          ENDIF
          IF (MB(2) == 0) THEN
              MA0 = MIN(MA(0),MB(0))
              CALL FMEQ(MA,MC)
              MC(0) = MA0
              KFLAG = 1
              JRSIGN = JRSSAV
              RETURN
          ENDIF
      ENDIF

      MA0 = MA(0)
      IF (KACCSW == 1) THEN
          MB0 = MB(0)
          MA1 = MA(1)
          MB1 = MB(1)
      ENDIF
      KFLAG = 0
      N1 = NDIG + 1

!             NGUARD is the number of guard digits used.

      IF (NCALL > 1) THEN
          NGUARD = NGRD21
          IF (NGUARD > NDIG) NGUARD = NDIG
      ELSE
          NGUARD = NGRD52
          IF (NGUARD > NDIG) NGUARD = NDIG
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 10
          ENDIF
      ENDIF
      NMWA = N1 + NGUARD

!             Save the signs of MA and MB and then work with
!             positive numbers.
!             JSIGN is the sign of the result of MA + MB.

      JSIGN = 1
      MAS = MA(-1)
      MBS = MB(-1)
      IF (KSUB == 1) MBS = -MBS

!             See which one is larger in absolute value.

      JCOMP = 2
      IF (MA(1) > MB(1)) THEN
          JCOMP = 1
      ELSE IF (MB(1) > MA(1)) THEN
          JCOMP = 3
      ELSE
          DO J = 2, N1
             IF (MA(J) > MB(J)) THEN
                 JCOMP = 1
                 EXIT
             ENDIF
             IF (MB(J) > MA(J)) THEN
                 JCOMP = 3
                 EXIT
             ENDIF
          ENDDO
      ENDIF

      IF (JCOMP < 3) THEN
          IF (MAS < 0) JSIGN = -1
          JRSIGN = JSIGN
          IF (MAS*MBS > 0) THEN
              CALL FMADDP(MA,MB,NGUARD,NMWA)
          ELSE
              CALL FMADDN(MA,MB,NGUARD,NMWA)
          ENDIF
      ELSE
          IF (MBS < 0) JSIGN = -1
          JRSIGN = JSIGN
          IF (MAS*MBS > 0) THEN
              CALL FMADDP(MB,MA,NGUARD,NMWA)
          ELSE
              CALL FMADDN(MB,MA,NGUARD,NMWA)
          ENDIF
      ENDIF

!             Transfer to MC and fix the sign of the result.

      CALL FMMOVE(MWA,MC)
      MC(-1) = 1
      IF (JSIGN < 0 .AND. MC(2) /= 0) MC(-1) = -1

      IF (KFLAG < 0) THEN
          IF (KSUB == 1) THEN
              NAMEST(NCALL) = 'FMSUB '
          ELSE
              NAMEST(NCALL) = 'FMADD '
          ENDIF
          CALL FMWARN
      ENDIF

      IF (KACCSW == 1) THEN
          B2RDA = LOG(REAL(ABS(MC(2))+1)/REAL(ABS(MA2)+1))/0.69315 +  &
                  REAL(MC(1)-MA1)*ALOGM2 + REAL(MA0)
          B2RDB = LOG(REAL(ABS(MC(2))+1)/REAL(ABS(MB2)+1))/0.69315 +  &
                  REAL(MC(1)-MB1)*ALOGM2 + REAL(MB0)
          MB2RD = NINT(MAX(0.0,MIN(B2RDA,B2RDB,  &
                  (NDIG-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)))
          IF (MC(2) == 0) THEN
              MC(0) = 0
          ELSE
              MC(0) = MIN(MAX(MA0,MB0),MB2RD)
          ENDIF
      ELSE
          MC(0) = MA0
      ENDIF

      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMADD2

      SUBROUTINE FMADD_R1(MA,MB)

!  MA = MA + MB

!  This routine performs the trace printing for addition.
!  FMADD2_R1 is used to do the arithmetic.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMADD '
          CALL FMNTR(2,MA,MB,2,1)

          CALL FMADD2_R1(MA,MB)

          CALL FMNTR(1,MA,MA,1,1)
      ELSE
          CALL FMADD2_R1(MA,MB)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMADD_R1

      SUBROUTINE FMADD2_R1(MA,MB)

!  Internal addition routine.  MA = MA + MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MA0,MA1,MA2,MAS,MB0,MB1,MB2,MB2RD,MBS
      INTEGER J,JCOMP,JRSSAV,JSIGN,KRESLT,N1,NGUARD,NMWA
      REAL B2RDA,B2RDB

      IF (MBLOGS /= MBASE) CALL FMCONS
      JRSSAV = JRSIGN
      MA2 = MA(2)
      MB2 = MB(2)
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR.  &
          KDEBUG == 1) THEN
          IF (KSUB == 1) THEN
              CALL FMARGS('FMSUB ',2,MA,MB,KRESLT)
          ELSE
              CALL FMARGS('FMADD ',2,MA,MB,KRESLT)
          ENDIF
          IF (KRESLT /= 0) THEN
              IF ((KRESLT /= 1 .AND. KRESLT /= 2) .OR. MA(2) == 0 .OR.  &
                  MB(2) == 0) THEN
                  NCALL = NCALL + 1
                  IF (KSUB == 1) THEN
                      NAMEST(NCALL) = 'FMSUB '
                  ELSE
                      NAMEST(NCALL) = 'FMADD '
                  ENDIF
                  CALL FMRSLT(MA,MB,M07,KRESLT)
                  CALL FMEQ(M07,MA)
                  JRSIGN = JRSSAV
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
      ELSE
          IF (MA(2) == 0) THEN
              MA0 = MIN(MA(0),MB(0))
              CALL FMEQ(MB,MA)
              MA(0) = MA0
              KFLAG = 1
              IF (KSUB == 1) THEN
                  IF (MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -MA(-1)
                  KFLAG = 0
              ENDIF
              JRSIGN = JRSSAV
              RETURN
          ENDIF
          IF (MB(2) == 0) THEN
              MA0 = MIN(MA(0),MB(0))
              MA(0) = MA0
              KFLAG = 1
              JRSIGN = JRSSAV
              RETURN
          ENDIF
      ENDIF

      MA0 = MA(0)
      IF (KACCSW == 1) THEN
          MB0 = MB(0)
          MA1 = MA(1)
          MB1 = MB(1)
      ENDIF
      KFLAG = 0
      N1 = NDIG + 1

!             NGUARD is the number of guard digits used.

      IF (NCALL > 1) THEN
          NGUARD = NGRD21
          IF (NGUARD > NDIG) NGUARD = NDIG
      ELSE
          NGUARD = NGRD52
          IF (NGUARD > NDIG) NGUARD = NDIG
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 10
          ENDIF
      ENDIF
      NMWA = N1 + NGUARD

!             Save the signs of MA and MB and then work with
!             positive numbers.
!             JSIGN is the sign of the result of MA + MB.

      JSIGN = 1
      MAS = MA(-1)
      MBS = MB(-1)
      IF (KSUB == 1) MBS = -MBS

!             See which one is larger in absolute value.

      JCOMP = 2
      IF (MA(1) > MB(1)) THEN
          JCOMP = 1
      ELSE IF (MB(1) > MA(1)) THEN
          JCOMP = 3
      ELSE
          DO J = 2, N1
             IF (MA(J) > MB(J)) THEN
                 JCOMP = 1
                 EXIT
             ENDIF
             IF (MB(J) > MA(J)) THEN
                 JCOMP = 3
                 EXIT
             ENDIF
          ENDDO
      ENDIF

      IF (JCOMP < 3) THEN
          IF (MAS < 0) JSIGN = -1
          JRSIGN = JSIGN
          IF (MAS*MBS > 0) THEN
              CALL FMADDP(MA,MB,NGUARD,NMWA)
          ELSE
              CALL FMADDN(MA,MB,NGUARD,NMWA)
          ENDIF
      ELSE
          IF (MBS < 0) JSIGN = -1
          JRSIGN = JSIGN
          IF (MAS*MBS > 0) THEN
              CALL FMADDP(MB,MA,NGUARD,NMWA)
          ELSE
              CALL FMADDN(MB,MA,NGUARD,NMWA)
          ENDIF
      ENDIF

!             Transfer to MA and fix the sign of the result.

      CALL FMMOVE(MWA,MA)
      MA(-1) = 1
      IF (JSIGN < 0 .AND. MA(2) /= 0) MA(-1) = -1

      IF (KFLAG < 0) THEN
          IF (KSUB == 1) THEN
              NAMEST(NCALL) = 'FMSUB '
          ELSE
              NAMEST(NCALL) = 'FMADD '
          ENDIF
          CALL FMWARN
      ENDIF

      IF (KACCSW == 1) THEN
          B2RDA = LOG(REAL(ABS(MA(2))+1)/REAL(ABS(MA2)+1))/0.69315 +  &
                  REAL(MA(1)-MA1)*ALOGM2 + REAL(MA0)
          B2RDB = LOG(REAL(ABS(MA(2))+1)/REAL(ABS(MB2)+1))/0.69315 +  &
                  REAL(MA(1)-MB1)*ALOGM2 + REAL(MB0)
          MB2RD = NINT(MAX(0.0,MIN(B2RDA,B2RDB,  &
                  (NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315)))
          IF (MA(2) == 0) THEN
              MA(0) = 0
          ELSE
              MA(0) = MIN(MAX(MA0,MB0),MB2RD)
          ENDIF
      ELSE
          MA(0) = MA0
      ENDIF

      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMADD2_R1

      SUBROUTINE FMADD_R2(MA,MB)

!  MB = MA + MB

!  This routine performs the trace printing for addition.
!  FMADD2_R2 is used to do the arithmetic.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMADD '
          CALL FMNTR(2,MA,MB,2,1)

          CALL FMADD2_R2(MA,MB)

          CALL FMNTR(1,MB,MB,1,1)
      ELSE
          CALL FMADD2_R2(MA,MB)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMADD_R2

      SUBROUTINE FMADD2_R2(MA,MB)

!  Internal addition routine.  MB = MA + MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MA0,MA1,MA2,MAS,MB0,MB1,MB2,MB2RD,MBS
      INTEGER J,JCOMP,JRSSAV,JSIGN,KRESLT,N1,NGUARD,NMWA
      REAL B2RDA,B2RDB

      IF (MBLOGS /= MBASE) CALL FMCONS
      JRSSAV = JRSIGN
      MA2 = MA(2)
      MB2 = MB(2)
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR.  &
          KDEBUG == 1) THEN
          IF (KSUB == 1) THEN
              CALL FMARGS('FMSUB ',2,MA,MB,KRESLT)
          ELSE
              CALL FMARGS('FMADD ',2,MA,MB,KRESLT)
          ENDIF
          IF (KRESLT /= 0) THEN
              IF ((KRESLT /= 1 .AND. KRESLT /= 2) .OR. MA(2) == 0 .OR.  &
                  MB(2) == 0) THEN
                  NCALL = NCALL + 1
                  IF (KSUB == 1) THEN
                      NAMEST(NCALL) = 'FMSUB '
                  ELSE
                      NAMEST(NCALL) = 'FMADD '
                  ENDIF
                  CALL FMRSLT(MA,MB,M07,KRESLT)
                  CALL FMEQ(M07,MB)
                  JRSIGN = JRSSAV
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
      ELSE
          IF (MA(2) == 0) THEN
              MA0 = MIN(MA(0),MB(0))
              MB(0) = MA0
              KFLAG = 1
              IF (KSUB == 1) THEN
                  IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
                  KFLAG = 0
              ENDIF
              JRSIGN = JRSSAV
              RETURN
          ENDIF
          IF (MB(2) == 0) THEN
              MA0 = MIN(MA(0),MB(0))
              CALL FMEQ(MA,MB)
              MB(0) = MA0
              KFLAG = 1
              JRSIGN = JRSSAV
              RETURN
          ENDIF
      ENDIF

      MA0 = MA(0)
      IF (KACCSW == 1) THEN
          MB0 = MB(0)
          MA1 = MA(1)
          MB1 = MB(1)
      ENDIF
      KFLAG = 0
      N1 = NDIG + 1

!             NGUARD is the number of guard digits used.

      IF (NCALL > 1) THEN
          NGUARD = NGRD21
          IF (NGUARD > NDIG) NGUARD = NDIG
      ELSE
          NGUARD = NGRD52
          IF (NGUARD > NDIG) NGUARD = NDIG
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 10
          ENDIF
      ENDIF
      NMWA = N1 + NGUARD

!             Save the signs of MA and MB and then work with
!             positive numbers.
!             JSIGN is the sign of the result of MA + MB.

      JSIGN = 1
      MAS = MA(-1)
      MBS = MB(-1)
      IF (KSUB == 1) MBS = -MBS

!             See which one is larger in absolute value.

      JCOMP = 2
      IF (MA(1) > MB(1)) THEN
          JCOMP = 1
      ELSE IF (MB(1) > MA(1)) THEN
          JCOMP = 3
      ELSE
          DO J = 2, N1
             IF (MA(J) > MB(J)) THEN
                 JCOMP = 1
                 EXIT
             ENDIF
             IF (MB(J) > MA(J)) THEN
                 JCOMP = 3
                 EXIT
             ENDIF
          ENDDO
      ENDIF

      IF (JCOMP < 3) THEN
          IF (MAS < 0) JSIGN = -1
          JRSIGN = JSIGN
          IF (MAS*MBS > 0) THEN
              CALL FMADDP(MA,MB,NGUARD,NMWA)
          ELSE
              CALL FMADDN(MA,MB,NGUARD,NMWA)
          ENDIF
      ELSE
          IF (MBS < 0) JSIGN = -1
          JRSIGN = JSIGN
          IF (MAS*MBS > 0) THEN
              CALL FMADDP(MB,MA,NGUARD,NMWA)
          ELSE
              CALL FMADDN(MB,MA,NGUARD,NMWA)
          ENDIF
      ENDIF

!             Transfer to MB and fix the sign of the result.

      CALL FMMOVE(MWA,MB)
      MB(-1) = 1
      IF (JSIGN < 0 .AND. MB(2) /= 0) MB(-1) = -1

      IF (KFLAG < 0) THEN
          IF (KSUB == 1) THEN
              NAMEST(NCALL) = 'FMSUB '
          ELSE
              NAMEST(NCALL) = 'FMADD '
          ENDIF
          CALL FMWARN
      ENDIF

      IF (KACCSW == 1) THEN
          B2RDA = LOG(REAL(ABS(MB(2))+1)/REAL(ABS(MA2)+1))/0.69315 +  &
                  REAL(MB(1)-MA1)*ALOGM2 + REAL(MA0)
          B2RDB = LOG(REAL(ABS(MB(2))+1)/REAL(ABS(MB2)+1))/0.69315 +  &
                  REAL(MB(1)-MB1)*ALOGM2 + REAL(MB0)
          MB2RD = NINT(MAX(0.0,MIN(B2RDA,B2RDB,  &
                  (NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)))
          IF (MB(2) == 0) THEN
              MB(0) = 0
          ELSE
              MB(0) = MIN(MAX(MA0,MB0),MB2RD)
          ENDIF
      ELSE
          MB(0) = MA0
      ENDIF

      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMADD2_R2

      SUBROUTINE FMADDI(MA,IVAL)

!  MA = MA + IVAL

!  Increment MA by one word integer IVAL.

!  This routine is faster than FMADD when IVAL is small enough so
!  that it can be added to a single word of MA without often causing
!  a carry.  Otherwise FMI2M and FMADD are used.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER IVAL
      REAL (KIND(1.0D0)) :: MAEXP,MD2B,MKSUM
      INTEGER KPTMA

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMADDI'
          CALL FMNTR(2,MA,MA,1,1)
          CALL FMNTRI(2,IVAL,0)
      ENDIF
      KFLAG = 0

      MAEXP = MA(1)
      IF (MAEXP <= 0 .OR. MAEXP > NDIG) GO TO 110
      KPTMA = INT(MAEXP) + 1
      IF (KPTMA > 2 .AND. MA(-1) < 0) THEN
          MKSUM = MA(KPTMA) - IVAL
      ELSE
          MKSUM = MA(KPTMA) + IVAL
      ENDIF

      IF (MKSUM >= MBASE .OR. MKSUM <= (-MBASE)) GO TO 110
      IF (MA(-1) < 0) THEN
          IF (KPTMA > 2) THEN
              IF (MKSUM >= 0) THEN
                  MA(KPTMA) = MKSUM
                  GO TO 120
              ELSE
                  GO TO 110
              ENDIF
          ELSE
              IF (MKSUM < 0) THEN
                  MA(KPTMA) = MKSUM
                  GO TO 120
              ELSE
                  GO TO 110
              ENDIF
          ENDIF
      ELSE
          IF (KPTMA > 2) THEN
              IF (MKSUM >= 0) THEN
                  MA(KPTMA) = MKSUM
                  GO TO 120
              ELSE
                  GO TO 110
              ENDIF
          ELSE
              IF (MKSUM > 0) THEN
                  MA(KPTMA) = MKSUM
                  GO TO 120
              ELSE
                  GO TO 110
              ENDIF
          ENDIF
      ENDIF

  110 CALL FMI2M(IVAL,M01)
      CALL FMADD2_R1(MA,M01)

  120 IF (KACCSW == 1) THEN
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315)
          MA(0) = MIN(MA(0),MD2B)
      ENDIF
      IF (NTRACE /= 0) THEN
          CALL FMNTR(1,MA,MA,1,1)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMADDI

      SUBROUTINE FMADDN(MA,MB,NGUARD,NMWA)

!  Internal addition routine.  MWA = MA - MB
!  The arguments are such that MA >= MB >= 0.

!  NGUARD is the number of guard digits being carried.
!  NMWA is the number of words in MWA that will be used.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER NGUARD,NMWA
      REAL (KIND(1.0D0)) :: MK,MR
      INTEGER J,K,KL,KP1,KP2,KPT,KSH,N1,N2,NK,NK1

      N1 = NDIG + 1

!             Check for an insignificant operand.

      MK = MA(1) - MB(1)
      IF (MK >= NDIG+2) THEN
          DO J = 1, N1
             MWA(J) = MA(J)
          ENDDO
          MWA(N1+1) = 0
          IF (KROUND == 0 .OR. (KROUND == 2 .AND. JRSIGN == -1) .OR.  &
             (KROUND == -1 .AND. JRSIGN == 1)) THEN
              MWA(N1) = MWA(N1) - 1
              GO TO 120
          ENDIF
          KFLAG = 1
          RETURN
      ENDIF
      K = INT(MK)
      IF (NGUARD <= 1) NMWA = N1 + 2

!             Subtract MB from MA.

      KP1 = MIN(N1,K+1)
      MWA(K+1) = 0
      DO J = 1, KP1
         MWA(J) = MA(J)
      ENDDO
      KP2 = K + 2

!             (Inner Loop)

      DO J = KP2, N1
         MWA(J) = MA(J) - MB(J-K)
      ENDDO

      N2 = NDIG + 2
      IF (N2-K <= 1) N2 = 2 + K
      NK = MIN(NMWA,N1+K)
      DO J = N2, NK
         MWA(J) = -MB(J-K)
      ENDDO
      NK1 = NK + 1
      DO J = NK1, NMWA
         MWA(J) = 0
      ENDDO

!             Normalize.  Fix the sign of any negative digit.

      IF (K > 0) THEN
          DO J = NMWA, KP2, -1
             IF (MWA(J) < 0) THEN
                 MWA(J) = MWA(J) + MBASE
                 MWA(J-1) = MWA(J-1) - 1
             ENDIF
          ENDDO

          KPT = KP2 - 1
  110     IF (MWA(KPT) < 0 .AND. KPT >= 3) THEN
              MWA(KPT) = MWA(KPT) + MBASE
              MWA(KPT-1) = MWA(KPT-1) - 1
              KPT = KPT - 1
              GO TO 110
          ENDIF
          GO TO 130
      ENDIF

  120 DO J = N1, 3, -1
         IF (MWA(J) < 0) THEN
             MWA(J) = MWA(J) + MBASE
             MWA(J-1) = MWA(J-1) - 1
         ENDIF
      ENDDO

!             Shift left if there are any leading zeros in the mantissa.

  130 DO J = 2, NMWA
         IF (MWA(J) > 0) THEN
             KSH = J - 2
             GO TO 140
         ENDIF
      ENDDO
      MWA(1) = 0
      RETURN

  140 IF (KSH > 0) THEN
          KL = NMWA - KSH
          DO J = 2, KL
             MWA(J) = MWA(J+KSH)
          ENDDO
          DO J = KL+1, NMWA
             MWA(J) = 0
          ENDDO
          MWA(1) = MWA(1) - KSH
          IF (MK >= NDIG+2) THEN
              MWA(N1) = MBASE - 1
          ENDIF
      ENDIF

!             Round the result.

      MR = 2*MWA(NDIG+2) + 1
      IF (KROUND == -1 .OR. KROUND == 2) THEN
          CALL FMRND(MWA,NDIG,NGUARD,0)
      ELSE IF (MR >= MBASE) THEN
          IF (MR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
              IF (KROUND /= 0 .OR. NCALL > 1) THEN
                  MWA(N1) = MWA(N1) + 1
                  MWA(N1+1) = 0
              ENDIF
          ELSE
              CALL FMRND(MWA,NDIG,NGUARD,0)
          ENDIF
      ENDIF

!             See if the result is equal to one of the input arguments.

      IF (ABS(MA(1)-MB(1)) < NDIG) GO TO 150
      IF (ABS(MA(1)-MB(1)) > NDIG+1) THEN
          KFLAG = 1
          GO TO 150
      ENDIF

      N2 = NDIG + 4
      DO J = 3, N1
         IF (MWA(N2-J) /= MA(N2-J)) GO TO 150
      ENDDO
      IF (MWA(1) /= MA(1)) GO TO 150
      IF (MWA(2) /= ABS(MA(2))) GO TO 150
      KFLAG = 1

  150 RETURN
      END SUBROUTINE FMADDN

      SUBROUTINE FMADDP(MA,MB,NGUARD,NMWA)

!  Internal addition routine.  MWA = MA + MB
!  The arguments are such that MA >= MB >= 0.

!  NMWA is the number of words in MWA that will be used.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER NGUARD,NMWA
      REAL (KIND(1.0D0)) :: MK,MKT,MR
      INTEGER J,K,KP,KP2,KPT,KSHIFT,N1,N2,NK

      N1 = NDIG + 1

!             Check for an insignificant operand.

      MK = MA(1) - MB(1)
      IF (MK >= NDIG+1) THEN
          MWA(1) = MA(1) + 1
          MWA(2) = 0
          DO J = 2, N1
             MWA(J+1) = MA(J)
          ENDDO
          MWA(N1+2) = 0
          IF ((KROUND ==  2 .AND. JRSIGN ==  1) .OR.  &
              (KROUND == -1 .AND. JRSIGN == -1)) THEN
              MWA(N1+2) = 1
              GO TO 120
          ENDIF
          KFLAG = 1
          RETURN
      ENDIF
      K = INT(MK)

!             Add MA and MB.

      MWA(1) = MA(1) + 1
      MWA(2) = 0
      DO J = 2, K+1
         MWA(J+1) = MA(J)
      ENDDO
      KP2 = K + 2

!             (Inner Loop)

      DO J = KP2, N1
         MWA(J+1) = MA(J) + MB(J-K)
      ENDDO
      N2 = NDIG + 2
      NK = MIN(NMWA,N1+K)
      DO J = N2, NK
         MWA(J+1) = MB(J-K)
      ENDDO
      DO J = NK+1, NMWA
         MWA(J+1) = 0
      ENDDO

!             Normalize.  Fix any digit not less than MBASE.

      IF (K == NDIG) GO TO 140

      IF (K > 0) THEN
          DO J = N1+1, KP2, -1
             IF (MWA(J) >= MBASE) THEN
                 MWA(J) = MWA(J) - MBASE
                 MWA(J-1) = MWA(J-1) + 1
             ENDIF
          ENDDO

          KPT = KP2 - 1
  110     IF (MWA(KPT) >= MBASE .AND. KPT >= 3) THEN
              MWA(KPT) = MWA(KPT) - MBASE
              MWA(KPT-1) = MWA(KPT-1) + 1
              KPT = KPT - 1
              GO TO 110
          ENDIF
          GO TO 120
      ENDIF

      DO J = N1+1, 3, -1
         IF (MWA(J) >= MBASE) THEN
             MWA(J) = MWA(J) - MBASE
             MWA(J-1) = MWA(J-1) + 1
         ENDIF
      ENDDO

!             Shift right if the leading digit is not less than MBASE.

  120 IF (MWA(2) >= MBASE) THEN
  130     KP = NMWA + 4
          DO J = 4, NMWA
             MWA(KP-J) = MWA(KP-J-1)
          ENDDO
          MKT = AINT (MWA(2)/MBASE)
          MWA(3) = MWA(2) - MKT*MBASE
          MWA(2) = MKT
          MWA(1) = MWA(1) + 1
          IF (MWA(2) >= MBASE) GO TO 130
      ENDIF

!             Round the result.

  140 KSHIFT = 0
      IF (MWA(2) == 0) KSHIFT = 1
      MR = 2*MWA(NDIG+2+KSHIFT) + 1
      IF (KROUND == -1 .OR. KROUND == 2) THEN
          CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
      ELSE IF (MR >= MBASE) THEN
          IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
              IF (KROUND /= 0 .OR. NCALL > 1) THEN
                  MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
                  MWA(N1+1+KSHIFT) = 0
              ENDIF
          ELSE
              CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
          ENDIF
      ENDIF

!             See if the result is equal to one of the input arguments.

      IF (ABS(MA(1)-MB(1)) < NDIG) GO TO 150
      IF (KSHIFT == 0) GO TO 150
      IF (ABS(MA(1)-MB(1)) > NDIG+1) THEN
          KFLAG = 1
          GO TO 150
      ENDIF

      N2 = NDIG + 4
      DO J = 3, N1
         IF (MWA(N2-J+1) /= MA(N2-J)) GO TO 150
      ENDDO
      IF (MWA(1) /= MA(1)+1) GO TO 150
      IF (MWA(3) /= ABS(MA(2))) GO TO 150
      KFLAG = 1

  150 RETURN
      END SUBROUTINE FMADDP

      SUBROUTINE FMARGS(KROUTN,NARGS,MA,MB,KRESLT)

!  Check the input arguments to a routine for special cases.

!  KROUTN - Name of the subroutine that was called
!  NARGS  - The number of input arguments (1 or 2)
!  MA     - First input argument
!  MB     - Second input argument (if NARGS is 2)
!  KRESLT - Result code returned to the calling routine.

!  Result codes:

!   0 - Perform the normal operation
!   1 - The result is the first input argument
!   2 - The result is the second input argument
!   3 - The result is -OVERFLOW
!   4 - The result is +OVERFLOW
!   5 - The result is -UNDERFLOW
!   6 - The result is +UNDERFLOW
!   7 - The result is -1.0
!   8 - The result is +1.0
!   9 - The result is -pi/2
!  10 - The result is +pi/2
!  11 - The result is 0.0
!  12 - The result is UNKNOWN
!  13 - The result is +pi
!  14 - The result is -pi/4
!  15 - The result is +pi/4

      USE FMVALS
      IMPLICIT NONE
      CHARACTER(6) :: KROUTN
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER NARGS,KRESLT

      REAL (KIND(1.0D0)) :: MBS
      INTEGER J,KWRNSV,NCATMA,NCATMB,NDS

!             These tables define the result codes to be returned for
!             given values of the input argument(s).

!             For example, row 7 column 2 of this array initialization
!             KADD(2,7) = 2 means that if the first argument in a call
!             to FMADD is in category 7 ( -UNDERFLOW ) and the second
!             argument is in category 2 ( near -OVERFLOW but
!             representable ) then the result code is 2 ( the value
!             of the sum is equal to the second input argument).
!             See routine FMCAT for descriptions of the categories.

      INTEGER :: KADD(15,15) = RESHAPE(  (/  &
                 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,12,12,  &
                 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0,12,  &
                 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4,  &
                 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4,  &
                 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4,  &
                 3, 0, 0, 0, 0, 0,12, 1,12, 0, 0, 0, 0, 0, 4,  &
                 3, 2, 2, 2, 2,12,12, 5,12,12, 2, 2, 2, 2, 4,  &
                 3, 2, 2, 2, 2, 2, 5, 2, 6, 2, 2, 2, 2, 2, 4,  &
                 3, 2, 2, 2, 2,12,12, 6,12,12, 2, 2, 2, 2, 4,  &
                 3, 0, 0, 0, 0, 0,12, 1,12, 0, 0, 0, 0, 0, 4,  &
                 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4,  &
                 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4,  &
                 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4,  &
                12, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4,  &
                12,12, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4   /)  &
        , (/ 15,15 /) )

      INTEGER :: KMPY(15,15) = RESHAPE(  (/  &
                 4, 4, 4, 4,12,12,12,11,12,12,12, 3, 3, 3, 3,  &
                 4, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 3,  &
                 4, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 3,  &
                 4, 0, 0, 0, 0, 0, 6,11, 5, 0, 0, 1, 0, 0, 3,  &
                12, 0, 0, 0, 0, 0, 6,11, 5, 0, 0, 1, 0, 0,12,  &
                12, 0, 0, 0, 0, 0, 6,11, 5, 0, 0, 1, 0, 0,12,  &
                12,12,12, 6, 6, 6, 6,11, 5, 5, 5, 5,12,12,12,  &
                11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,  &
                12,12,12, 5, 5, 5, 5,11, 6, 6, 6, 6,12,12,12,  &
                12, 0, 0, 0, 0, 0, 5,11, 6, 0, 0, 1, 0, 0,12,  &
                12, 0, 0, 0, 0, 0, 5,11, 6, 0, 0, 1, 0, 0,12,  &
                 3, 2, 2, 2, 2, 2, 5,11, 6, 2, 2, 2, 2, 2, 4,  &
                 3, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 4,  &
                 3, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 4,  &
                 3, 3, 3, 3,12,12,12,11,12,12,12, 4, 4, 4, 4   /)  &
        , (/ 15,15 /) )

      INTEGER :: KDIV(15,15) = RESHAPE(  (/  &
                12,12,12, 4, 4, 4, 4,12, 3, 3, 3, 3,12,12,12,  &
                12, 0, 0, 0, 0, 0, 4,12, 3, 0, 0, 1, 0, 0,12,  &
                12, 0, 0, 0, 0, 0, 4,12, 3, 0, 0, 1, 0, 0,12,  &
                 6, 0, 0, 0, 0, 0, 4,12, 3, 0, 0, 1, 0, 0, 5,  &
                 6, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 5,  &
                 6, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 5,  &
                 6, 6, 6, 6,12,12,12,12,12,12,12, 5, 5, 5, 5,  &
                11,11,11,11,11,11,11,12,11,11,11,11,11,11,11,  &
                 5, 5, 5, 5,12,12,12,12,12,12,12, 6, 6, 6, 6,  &
                 5, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 6,  &
                 5, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 6,  &
                 5, 0, 0, 0, 0, 0, 3,12, 4, 0, 0, 1, 0, 0, 6,  &
                12, 0, 0, 0, 0, 0, 3,12, 4, 0, 0, 1, 0, 0,12,  &
                12, 0, 0, 0, 0, 0, 3,12, 4, 0, 0, 1, 0, 0,12,  &
                12,12,12, 3, 3, 3, 3,12, 4, 4, 4, 4,12,12,12   /)  &
        , (/ 15,15 /) )

      INTEGER :: KPWR(15,15) = RESHAPE(  (/  &
                12,12, 0, 5,12,12,12, 8,12,12,12, 3, 0,12,12,  &
                12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12,  &
                12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12,  &
                12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12,  &
                12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12,  &
                12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12,  &
                12,12, 0, 3,12,12,12, 8,12,12,12, 5, 0,12,12,  &
                12,12,12,12,12,12,12,12,11,11,11,11,11,11,11,  &
                 4, 4, 4, 4,12,12,12, 8,12,12,12, 6, 6, 6, 6,  &
                 4, 4, 0, 0, 0, 8, 8, 8, 8, 0, 0, 1, 0, 6, 6,  &
                 4, 4, 0, 0, 0, 8, 8, 8, 8, 0, 0, 1, 0, 6, 6,  &
                 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,  &
                 6, 6, 0, 0, 0, 8, 8, 8, 8, 8, 0, 1, 0, 4, 4,  &
                 6, 6, 0, 0, 0, 8, 8, 8, 8, 8, 0, 1, 0, 4, 4,  &
                 6, 6, 6, 6,12,12,12, 8,12,12,12, 4, 4, 4, 4   /)  &
        , (/ 15,15 /) )

      INTEGER :: KSQRT(15) = (/ 12,12,12,12,12,12,12,11,12, 0, 0, 8, 0, 0,12 /)
      INTEGER :: KEXP(15)  = (/  6, 6, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0, 4, 4 /)
      INTEGER :: KLN(15)   = (/ 12,12,12,12,12,12,12,12,12, 0, 0,11, 0, 0,12 /)
      INTEGER :: KSIN(15)  = (/ 12,12, 0, 0, 0, 0, 5,11, 6, 0, 0, 0, 0,12,12 /)
      INTEGER :: KCOS(15)  = (/ 12,12, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0,12,12 /)
      INTEGER :: KTAN(15)  = (/ 12,12, 0, 0, 0, 0, 5,11, 6, 0, 0, 0, 0,12,12 /)
      INTEGER :: KASIN(15) = (/ 12,12,12, 9, 0, 0, 5,11, 6, 0, 0,10,12,12,12 /)
      INTEGER :: KACOS(15) = (/ 12,12,12,13, 0,10,10,10,10,10, 0,11,12,12,12 /)
      INTEGER :: KATAN(15) = (/  9, 9, 0,14, 0, 0, 5,11, 6, 0, 0,15, 0,10,10 /)
      INTEGER :: KSINH(15) = (/  3, 3, 0, 0, 0, 1, 5,11, 6, 1, 0, 0, 0, 4, 4 /)
      INTEGER :: KCOSH(15) = (/  4, 4, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0, 4, 4 /)
      INTEGER :: KTANH(15) = (/  7, 7, 0, 0, 0, 1, 5,11, 6, 1, 0, 0, 0, 8, 8 /)
      INTEGER :: KLG10(15) = (/ 12,12,12,12,12,12,12,12,12, 0, 0,11, 0, 0,12 /)

      KRESLT = 12
      KFLAG = -4
      IF (MA(1) == MUNKNO) RETURN
      IF (NARGS == 2) THEN
          IF (MB(1) == MUNKNO) RETURN
      ENDIF
      IF (MBLOGS /= MBASE) CALL FMCONS
      KFLAG = 0
      NAMEST(NCALL) = KROUTN

!             Check the validity of parameters if this is a user call.

      IF (NCALL > 1 .AND. KDEBUG == 0) GO TO 130

!             Check NDIG.

      IF (NDIG < 2 .OR. NDIG > NDIGMX) THEN
          KFLAG = -1
          CALL FMWARN
          NDS = NDIG
          IF (NDIG < 2) NDIG = 2
          IF (NDIG > NDIGMX) NDIG = NDIGMX
          WRITE (KW,  &
                 "(' NDIG was',I10,'.  It has been changed to',I10,'.')"  &
                ) NDS,NDIG
          RETURN
      ENDIF

!             Check MBASE.

      IF (MBASE < 2 .OR. MBASE > MXBASE) THEN
          KFLAG = -2
          CALL FMWARN
          MBS = MBASE
          IF (MBASE < 2) MBASE = 2
          IF (MBASE > MXBASE) MBASE = MXBASE
          WRITE (KW,  &
                 "(' MBASE was',I10,'.  It has been changed to',I10,'.')"  &
                ) INT(MBS),INT(MBASE)
          CALL FMCONS
          RETURN
      ENDIF

!             Check exponent range.

      IF (MA(1) > MXEXP+1 .OR. MA(1) < -MXEXP) THEN
          IF (ABS(MA(1)) /= MEXPOV .OR. ABS(MA(2)) /= 1) THEN
              KFLAG = -3
              CALL FMWARN
              RETURN
          ENDIF
      ENDIF
      IF (NARGS == 2) THEN
          IF (MB(1) > MXEXP+1 .OR. MB(1) < -MXEXP) THEN
              IF (ABS(MB(1)) /= MEXPOV .OR. ABS(MB(2)) /= 1) THEN
                  KFLAG = -3
                  CALL FMWARN
                  RETURN
              ENDIF
          ENDIF
      ENDIF

!             Check for properly normalized digits in the
!             input arguments.

      IF (ABS(MA(1)-INT(MA(1))) /= 0) KFLAG = 1
      IF (MA(2) <= (-1) .OR. MA(2) >= MBASE .OR.  &
          ABS(MA(2)-INT(MA(2))) /= 0) KFLAG = 2
      IF (KDEBUG == 0) GO TO 110
      DO J = 3, NDIG+1
         IF (MA(J) < 0 .OR. MA(J) >= MBASE .OR.  &
             ABS(MA(J)-INT(MA(J))) /= 0) THEN
             KFLAG = J
             GO TO 110
         ENDIF
      ENDDO
  110 IF (KFLAG /= 0) THEN
          J = KFLAG
          KFLAG = -4
          KWRNSV = KWARN
          IF (KWARN >= 2) KWARN = 1
          CALL FMWARN
          KWARN = KWRNSV
          IF (KWARN >= 1) THEN
              WRITE (KW,*) ' First invalid array element:  MA(',  &
                           J,') = ',MA(J)
          ENDIF
          KFLAG = -4
          IF (KWARN >= 2) THEN
              STOP
          ENDIF
          RETURN
      ENDIF
      IF (NARGS == 2) THEN
          IF (ABS(MB(1)-INT(MB(1))) /= 0) KFLAG = 1
          IF (MB(2) <= (-1) .OR. MB(2) >= MBASE .OR.  &
              ABS(MB(2)-INT(MB(2))) /= 0) KFLAG = 2
          IF (KDEBUG == 0) GO TO 120
          DO J = 3, NDIG+1
             IF (MB(J) < 0 .OR. MB(J) >= MBASE .OR.  &
                 ABS(MB(J)-INT(MB(J))) /= 0) THEN
                 KFLAG = J
                 GO TO 120
             ENDIF
          ENDDO
  120     IF (KFLAG /= 0) THEN
              J = KFLAG
              KFLAG = -4
              KWRNSV = KWARN
              IF (KWARN >= 2) KWARN = 1
              CALL FMWARN
              KWARN = KWRNSV
              IF (KWARN >= 1) THEN
                  WRITE (KW,*) ' First invalid array element:  MB(',  &
                               J,') = ',MB(J)
              ENDIF
              KFLAG = -4
              IF (KWARN >= 2) THEN
                  STOP
              ENDIF
              RETURN
          ENDIF
      ENDIF

!             Check for special cases.

  130 CALL FMCAT(MA,NCATMA)
      NCATMB = 0
      IF (NARGS == 2) CALL FMCAT(MB,NCATMB)

      IF (KROUTN == 'FMADD ') THEN
          KRESLT = KADD(NCATMB,NCATMA)
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMSUB ') THEN
          IF (NCATMB < 16) NCATMB = 16 - NCATMB
          KRESLT = KADD(NCATMB,NCATMA)
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMMPY ') THEN
          KRESLT = KMPY(NCATMB,NCATMA)
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMDIV ') THEN
          KRESLT = KDIV(NCATMB,NCATMA)
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMPWR ') THEN
          KRESLT = KPWR(NCATMB,NCATMA)
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMSQRT') THEN
          KRESLT = KSQRT(NCATMA)
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMEXP ') THEN
          KRESLT = KEXP(NCATMA)
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMLN  ') THEN
          KRESLT = KLN(NCATMA)
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMSIN ') THEN
          KRESLT = KSIN(NCATMA)
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMCOS ') THEN
          KRESLT = KCOS(NCATMA)
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMTAN ') THEN
          KRESLT = KTAN(NCATMA)
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMASIN') THEN
          KRESLT = KASIN(NCATMA)
          IF ((NCATMA == 7.OR.NCATMA == 9) .AND. KRAD == 0) KRESLT = 12
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMACOS') THEN
          KRESLT = KACOS(NCATMA)
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMATAN') THEN
          KRESLT = KATAN(NCATMA)
          IF ((NCATMA == 7.OR.NCATMA == 9) .AND. KRAD == 0) KRESLT = 12
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMSINH') THEN
          KRESLT = KSINH(NCATMA)
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMCOSH') THEN
          KRESLT = KCOSH(NCATMA)
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMTANH') THEN
          KRESLT = KTANH(NCATMA)
          GO TO 140
      ENDIF

      IF (KROUTN == 'FMLG10') THEN
          KRESLT = KLG10(NCATMA)
          GO TO 140
      ENDIF

      KRESLT = 0
      RETURN

  140 IF (KRESLT == 12) THEN
          KFLAG = -4
          CALL FMWARN
      ENDIF
      IF (KRESLT == 3 .OR. KRESLT == 4) THEN
          IF (NCATMA == 1 .OR. NCATMA == 7 .OR. NCATMA == 9 .OR.  &
              NCATMA == 15 .OR. NCATMB == 1 .OR. NCATMB == 7 .OR.  &
              NCATMB == 9 .OR. NCATMB == 15) THEN
              KFLAG = -5
          ELSE
              KFLAG = -5
              CALL FMWARN
          ENDIF
      ENDIF
      IF (KRESLT == 5 .OR. KRESLT == 6) THEN
          IF (NCATMA == 1 .OR. NCATMA == 7 .OR. NCATMA == 9 .OR.  &
              NCATMA == 15 .OR. NCATMB == 1 .OR. NCATMB == 7 .OR.  &
              NCATMB == 9 .OR. NCATMB == 15) THEN
              KFLAG = -6
          ELSE
              KFLAG = -6
              CALL FMWARN
          ENDIF
      ENDIF
      RETURN
      END SUBROUTINE FMARGS

      SUBROUTINE FMASIN(MA,MB)

!  MB = ARCSIN(MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
      INTEGER J,K,KASAVE,KOVUN,KRESLT,NDSAVE

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB .OR. MA(1) > 0 .OR. MA(2) == 0) THEN
          CALL FMENTR('FMASIN',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMASIN'
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52-1,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,MB,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      MACCA = MA(0)
      CALL FMEQ2(MA,MB,NDSAVE,NDIG)
      MB(0) = NINT(NDIG*ALOGM2)

!             Use ASIN(X) = ATAN(X/SQRT(1-X*X))

      CALL FMI2M(1,M05)
      CALL FMSUB(M05,MB,M03)
      CALL FMADD(M05,MB,M04)
      CALL FMMPY_R2(M03,M04)
      CALL FMSQRT_R1(M04)
      CALL FMDIV_R1(MB,M04)

      CALL FMATAN(MB,M13)
      CALL FMEQ(M13,MB)

!             Round the result and return.

      MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
      MB(0) = MIN(MB(0),MACCA,MACMAX)
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMASIN

      SUBROUTINE FMATAN(MA,MB)

!  MB = ARCTAN(MA)

      USE FMVALS
      IMPLICIT NONE

      DOUBLE PRECISION X,XM
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER NSTACK(19)
      REAL (KIND(1.0D0)) :: MA1,MACCA,MACMAX,MAS,MXSAVE
      INTEGER J,K,KASAVE,KOVUN,KRESLT,KRSAVE,KST,KWRNSV,NDSAV1,NDSAVE,  &
              NDSV

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN
          CALL FMENTR('FMATAN',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMATAN'
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52-1,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,MB,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      MACCA = MA(0)
      CALL FMEQ2(MA,M05,NDSAVE,NDIG)
      M05(0) = NINT(NDIG*ALOGM2)

!             If MA >= 1 work with 1/MA.

      MA1 = MA(1)
      MAS = MA(-1)
      M05(-1) = 1
      IF (MA1 >= 1) THEN
          CALL FMI2M(1,MB)
          CALL FMDIV_R2(MB,M05)
      ENDIF

      KRSAVE = KRAD
      KRAD = 1
      KWRNSV = KWARN

      X = M05(1)
      XM = MXBASE

!             In case pi has not been computed at the current precision
!             and will be needed here, get it to full precision first
!             to avoid repeated calls at increasing precision during
!             Newton iteration.

      IF (MA1 >= 1 .OR. KRSAVE == 0) THEN
          IF (MBSPI /= MBASE .OR. NDIGPI < NDIG)  THEN
              NDSV = NDIG
              NDIG = MIN(NDIG+2,NDG2MX)
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'NOEQ  '
              CALL FMPI(MPISAV)
              NCALL = NCALL - 1
              NDIG = NDSV
          ENDIF
      ENDIF

!             If the argument is small, use the Taylor series,
!             otherwise use Newton iteration.

      IF (X*DLOGMB < -5.0D0*LOG(XM)) THEN
          KWARN = 0
          CALL FMEQ(M05,MB)
          IF (MB(1) <= -NDIG) GO TO 120
          CALL FMSQR(M05,M06)
          J = 3
          NDSAV1 = NDIG

  110     CALL FMMPY_R1(M05,M06)
          IF (M05(1) /= MUNKNO .AND. M05(2) /= 0) M05(-1) = -M05(-1)
          CALL FMDIVI(M05,J,M03)
          NDIG = NDSAV1
          CALL FMADD_R1(MB,M03)
          IF (KFLAG /= 0) THEN
              KFLAG = 0
              GO TO 120
          ENDIF
          NDIG = NDSAV1 - INT((MB(1)-M03(1)))
          IF (NDIG < 2) NDIG = 2
          J = J + 2
          GO TO 110
      ELSE

          CALL FMM2DP(M05,X)
          X = ATAN(X)
          CALL FMDPM(X,MB)
          CALL FMDIG(NSTACK,KST)

!             Newton iteration.

          DO J = 1, KST
             NDIG = NSTACK(J)
             CALL FMSIN(MB,M06)
             CALL FMSQR(M06,M03)
             CALL FMI2M(1,M04)
             CALL FMSUB_R2(M04,M03)
             CALL FMSQRT(M03,M04)
             CALL FMDIV_R2(M06,M04)
             CALL FMSUB_R1(M04,M05)
             CALL FMMPY_R2(M03,M04)
             CALL FMSUB_R1(MB,M04)
          ENDDO
          MB(0) = NINT(NDIG*ALOGM2)
      ENDIF

!             If MA >= 1 use pi/2 - ATAN(1/MA)

  120 IF (MA1 >= 1) THEN
          CALL FMDIVI(MPISAV,2,M06)
          CALL FMSUB_R2(M06,MB)
      ENDIF

!             Convert to degrees if necessary, round and return.

      KRAD = KRSAVE
      IF (KRAD == 0) THEN
          CALL FMMPYI_R1(MB,180)
          CALL FMDIV_R1(MB,MPISAV)
      ENDIF
      IF (MB(1) /= MUNKNO .AND. MB(2) /= 0 .AND. MAS < 0) MB(-1) = -MB(-1)

      IF (KFLAG == 1) KFLAG = 0
      KWARN = KWRNSV
      MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
      MB(0) = MIN(MB(0),MACCA,MACMAX)
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMATAN

      SUBROUTINE FMATN2(MA,MB,MC)

!  MC = ATAN2(MA,MB)

!  MC is returned as the angle between -pi and pi (or -180 and 180 if
!  degree mode is selected) for which TAN(MC) = MA/MB.  MC is an angle
!  for the point (MB,MA) in polar coordinates.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MXEXP1,MXSAVE
      INTEGER J,JQUAD,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB) THEN
          CALL FMENTR('FMATN2',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMATN2'
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52-1,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MB,MC,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      KWRNSV = KWARN
      KWARN = 0

      MACCA = MA(0)
      MACCB = MB(0)
      CALL FMEQ2(MA,M01,NDSAVE,NDIG)
      M01(0) = NINT(NDIG*ALOGM2)
      CALL FMEQ2(MB,M02,NDSAVE,NDIG)
      M02(0) = NINT(NDIG*ALOGM2)

!             Check for special cases.

      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR.  &
         (MA(2) == 0 .AND. MB(2) == 0)) THEN
          CALL FMST2M('UNKNOWN',MC)
          KFLAG = -4
          GO TO 110
      ENDIF

      IF (MB(2) == 0 .AND. MA(-1) > 0) THEN
          IF (KRAD == 0) THEN
              CALL FMI2M(90,MC)
          ELSE
              CALL FMPI(MC)
              CALL FMDIVI_R1(MC,2)
          ENDIF
          GO TO 110
      ENDIF

      IF (MB(2) == 0 .AND. MA(-1) < 0) THEN
          IF (KRAD == 0) THEN
              CALL FMI2M(-90,MC)
          ELSE
              CALL FMPI(MC)
              CALL FMDIVI_R1(MC,-2)
          ENDIF
          GO TO 110
      ENDIF

      MXEXP1 = INT(MXEXP2/2.01D0)
      IF (MA(1) == MEXPOV .AND. MB(1) < MXEXP1-NDIG-2) THEN
          IF (KRAD == 0) THEN
              CALL FMI2M(90,MC)
          ELSE
              CALL FMPI(MC)
              CALL FMDIVI_R1(MC,2)
          ENDIF
          IF (M01(-1) < 0) MC(-1) = -1
          GO TO 110
      ENDIF

      IF (MA(1) == MEXPUN .AND. (-MB(1)) < MXEXP1-NDIG-2 .AND.  &
                                 MB(-1) < 0) THEN
          IF (KRAD == 0) THEN
              CALL FMI2M(180,MC)
          ELSE
              CALL FMPI(MC)
          ENDIF
          IF (M01(-1) < 0) MC(-1) = -1
          GO TO 110
      ENDIF

      IF (MB(1) == MEXPOV .AND. MA(1) < MXEXP1-NDIG-2 .AND.  &
                                MB(-1) < 0) THEN
          IF (KRAD == 0) THEN
              CALL FMI2M(180,MC)
          ELSE
              CALL FMPI(MC)
          ENDIF
          IF (M01(-1) < 0) MC(-1) = -1
          GO TO 110
      ENDIF

      IF (MB(1) == MEXPUN .AND. MA(2) == 0) THEN
          IF (MB(-1) < 0) THEN
              IF (KRAD == 0) THEN
                  CALL FMI2M(180,MC)
              ELSE
                  CALL FMPI(MC)
              ENDIF
          ELSE
              CALL FMI2M(0,MC)
          ENDIF
          GO TO 110
      ENDIF

      IF (MB(1) == MEXPUN .AND. (-MA(1)) < MXEXP1-NDIG-2) THEN
          IF (KRAD == 0) THEN
              CALL FMI2M(90,MC)
          ELSE
              CALL FMPI(MC)
              CALL FMDIVI_R1(MC,2)
          ENDIF
          IF (M01(-1) < 0) MC(-1) = -1
          GO TO 110
      ENDIF

!             Determine the quadrant for the result, then use FMATAN.

      IF (MA(-1) >= 0 .AND. MB(-1) > 0) JQUAD = 1
      IF (MA(-1) >= 0 .AND. MB(-1) < 0) JQUAD = 2
      IF (MA(-1) < 0 .AND. MB(-1) < 0) JQUAD = 3
      IF (MA(-1) < 0 .AND. MB(-1) > 0) JQUAD = 4

      CALL FMDIV(M01,M02,MC)
      MC(-1) = 1
      CALL FMATAN(MC,M13)
      CALL FMEQ(M13,MC)

      IF (JQUAD == 2 .OR. JQUAD == 3) THEN
          IF (KRAD == 0) THEN
              CALL FMI2M(180,M05)
              CALL FMSUB_R2(M05,MC)
          ELSE
              CALL FMPI(M05)
              CALL FMSUB_R2(M05,MC)
          ENDIF
      ENDIF

      IF ((JQUAD == 3 .OR. JQUAD == 4) .AND. MC(1) /= MUNKNO .AND.  &
          MC(2) /= 0) MC(-1) = -MC(-1)

!             Round the result and return.

  110 IF (KFLAG == 1) KFLAG = 0
      KWARN = KWRNSV
      MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)
      MC(0) = MIN(MC(0),MACCA,MACCB,MACMAX)
      DO J = -1, NDIG+1
         M01(J) = MC(J)
      ENDDO
      CALL FMEXIT(M01,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMATN2

      SUBROUTINE FMBIG(MA)

!     MA = The biggest representable FM number using the current base
!          and precision.
!          The smallest positive number is then 1.0/MA.
!          Because of rounding, 1.0/(1.0/MA) will then overflow.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      INTEGER J,N1

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMBIG '

      IF (MBLOGS /= MBASE) CALL FMCONS
      KFLAG = 0
      N1 = NDIG + 1
      DO J = 2, N1
         MA(J) = MBASE - 1
      ENDDO
      MA(1) = MXEXP + 1
      MA(0) = NINT(NDIG*ALOGM2)
      MA(-1) = 1

      IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMBIG

      SUBROUTINE FMCAT(MA,NCAT)

!  NCAT is returned as the category of MA.  This is used by the various
!  arithmetic routines to handle special cases such as:
!  'number greater than 1' + 'underflowed result' is the first argument,
!  'overflowed result' / 'overflowed result' is 'unknown'.

!  NCAT       range

!   1.         -OV                OV stands for overflowed results.
!   2.   (-OV   , -OVTH)             ( MA(1) >= MAXEXP+2 )
!   3.   (-OVTH ,    -1)
!   4.         -1                 OVTH stands for a representable
!   5.   (-1    , -UNTH)               number near the overflow
!   6.   (-UNTH ,   -UN)               threshold.
!   7.         -UN                     ( MA(1) >= MAXEXP-NDIG+1 )
!   8.          0
!   9.         +UN                UN stands for underflowed results.
!  10.   (+UN   , +UNTH)             ( MA(1) <= -MAXEXP-1 )
!  11.   (+UNTH ,    +1)
!  12.         +1                 UNTH stands for a representable
!  13.   (+1    , +OVTH)               number near the underflow
!  14.   (+OVTH ,   +OV)               threshold.
!  15.         +OV                     ( MA(1) <= -MAXEXP+NDIG-1 )
!  16.       UNKNOWN

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER NCAT

      REAL (KIND(1.0D0)) :: MA2,MXEXP1
      INTEGER J,NLAST

!             Check for special symbols.

      NCAT = 16
      IF (MA(1) == MUNKNO) RETURN

      IF (MA(1) == MEXPOV) THEN
          NCAT = 15
          IF (MA(-1) < 0) NCAT = 1
          RETURN
      ENDIF

      IF (MA(1) == MEXPUN) THEN
          NCAT = 9
          IF (MA(-1) < 0) NCAT = 7
          RETURN
      ENDIF

      IF (MA(2) == 0) THEN
          NCAT = 8
          RETURN
      ENDIF

!             Check for +1 or -1.

      MA2 = ABS(MA(2))
      IF (MA(1) == 1 .AND. MA2 == 1) THEN
          NLAST = NDIG + 1
          IF (NLAST >= 3) THEN
              DO J = 3, NLAST
                 IF (MA(J) /= 0) GO TO 110
              ENDDO
          ENDIF
          NCAT = 12
          IF (MA(-1) < 0) NCAT = 4
          RETURN
      ENDIF

  110 MXEXP1 = INT(MXEXP)
      IF (MA(1) >= MXEXP1-NDIG+2) THEN
          NCAT = 14
          IF (MA(-1) < 0) NCAT = 2
          RETURN
      ENDIF

      IF (MA(1) >= 1) THEN
          NCAT = 13
          IF (MA(-1) < 0) NCAT = 3
          RETURN
      ENDIF

      IF (MA(1) >= -MXEXP1+NDIG) THEN
          NCAT = 11
          IF (MA(-1) < 0) NCAT = 5
          RETURN
      ENDIF

      IF (MA(1) >= -MXEXP1) THEN
          NCAT = 10
          IF (MA(-1) < 0) NCAT = 6
          RETURN
      ENDIF

      RETURN
      END SUBROUTINE FMCAT

      SUBROUTINE FMCHSH(MA,MB,MC)

!  MB = COSH(MA),    MC = SINH(MA)

!  If both the hyperbolic sine and cosine are needed, this routine
!  is faster than calling both FMCOSH and FMSINH.

!  MB and MC must be distinct arrays.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
      INTEGER J,K,KASAVE,KOVUN,KRESLT,KWRNSV,NCSAVE,NDSAVE

      IF (MBLOGS /= MBASE) CALL FMCONS
      MACCA = MA(0)
      MAS = MA(-1)
      IF (ABS(MA(1)) > MEXPAB) THEN
          NCSAVE = NCALL
          CALL FMENTR('FMCHSH',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (MA(1) == MUNKNO) KOVUN = 2
          NCALL = NCSAVE + 1
          CALL FMEQ2(MA,M04,NDSAVE,NDIG)
          M04(0) = NINT(NDIG*ALOGM2)
          M04(-1) = 1
          CALL FMCOSH(M04,MB)
          CALL FMSINH(M04,MC)
          GO TO 110
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMCHSH'
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  NCALL = NCALL - 1
                  NDIG = NDSAVE
                  CALL FMEQ(MA,M04)
                  CALL FMCOSH(M04,MB)
                  CALL FMSINH(M04,MC)
                  KFLAG = -9
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      CALL FMEQ2(MA,M04,NDSAVE,NDIG)
      M04(0) = NINT(NDIG*ALOGM2)
      M04(-1) = 1

      K = 1
      IF (M04(1) == 0 .AND. M04(2) /= 0) THEN
          IF (MBASE/M04(2) >= 100) K = 2
      ENDIF
      IF (M04(1) >= 0 .AND. M04(2) /= 0 .AND. K == 1) THEN
          CALL FMCOSH(M04,MB)
          IF (MB(1) > NDIG) THEN
              CALL FMEQ(MB,MC)
              GO TO 110
          ENDIF
          CALL FMSQR(MB,M03)
          CALL FMI2M(-1,M02)
          CALL FMADD_R1(M03,M02)
          CALL FMSQRT(M03,MC)
      ELSE
          CALL FMSINH(M04,MC)
          CALL FMSQR(MC,M03)
          CALL FMI2M(1,M02)
          CALL FMADD_R1(M03,M02)
          CALL FMSQRT(M03,MB)
      ENDIF

!             Round and return.

  110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)
      MC(0) = MIN(MC(0),MACCA,MACMAX)
      IF (MAS < 0 .AND. MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
      CALL FMEQ2_R1(MC,NDIG,NDSAVE)
      MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
      MB(0) = MIN(MB(0),MACCA,MACMAX)
      IF (KOVUN == 2) THEN
          KWRNSV = KWARN
          KWARN = 0
      ENDIF
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      IF (KOVUN == 2) THEN
          KWARN = KWRNSV
      ENDIF
      IF (NTRACE /= 0) THEN
          IF (ABS(NTRACE) >= 1 .AND. NCALL+1 <= LVLTRC) THEN
              IF (NTRACE < 0) THEN
                  CALL FMNTRJ(MC,NDIG)
              ELSE
                  CALL FMPRNT(MC)
              ENDIF
          ENDIF
      ENDIF
      RETURN
      END SUBROUTINE FMCHSH

      FUNCTION FMCOMP(MA,LREL,MB)

!  Logical comparison of FM numbers MA and MB.

!  LREL is a CHARACTER description of the comparison to be done:
!  LREL = 'EQ' returns FMCOMP = .TRUE. if MA == MB
!       = 'NE', 'GE', 'GT', 'LE', 'LT' also work like a logical IF.
!       = '==', '/=', '<', '<=', '>', '>=' may be used.

!  For comparisons involving 'UNKNOWN' or two identical special symbols
!  such as +OVERFLOW,'EQ',+OVERFLOW, FMCOMP is returned FALSE and a
!  KFLAG = -4 error condition is returned.

!  Some compilers object to functions with side effects such as
!  changing KFLAG or other module FMVALS variables.  Blocks of
!  code that modify these variables are identified by:
!      C                                                 DELETE START
!        ...
!      C                                                 DELETE STOP
!  These may be removed or commented out to produce a function without
!  side effects.  This disables trace printing in FMCOMP, and error
!  codes are not returned in KFLAG.

      USE FMVALS
      IMPLICIT NONE

      LOGICAL FMCOMP
      CHARACTER(*) :: LREL
      CHARACTER(2) :: JREL
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      INTEGER J,JCOMP,NLAST

!                                                 DELETE START
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMCOMP'

      IF (NCALL <= LVLTRC .AND. ABS(NTRACE) >= 2) THEN
          WRITE (KW,"(' Input to FMCOMP')")

          IF (NTRACE > 0) THEN
              CALL FMPRNT(MA)
              IF (INDEX('=/<>',LREL(1:1)) > 0) THEN
                  WRITE (KW,"(8X,A)") LREL
              ELSE
                  WRITE (KW,"(7X,'.',A,'.')") LREL
              ENDIF
              CALL FMPRNT(MB)
          ELSE
              CALL FMNTRJ(MA,NDIG)
              IF (INDEX('=/<>',LREL(1:1)) > 0) THEN
                  WRITE (KW,"(8X,A)") LREL
              ELSE
                  WRITE (KW,"(7X,'.',A,'.')") LREL
              ENDIF
              CALL FMNTRJ(MB,NDIG)
          ENDIF
      ENDIF
!                                                 DELETE STOP

!             JCOMP will be 1 if MA > MB
!                           2 if MA == MB
!                           3 if MA < MB

!             Check for special cases.

      JREL = LREL
      IF (LREL /= 'EQ' .AND. LREL /= 'NE' .AND. LREL /= 'LT' .AND.  &
          LREL /= 'GT' .AND. LREL /= 'LE' .AND. LREL /= 'GE') THEN
          IF (LREL == 'eq' .OR. LREL == '==') THEN
              JREL = 'EQ'
          ELSE IF (LREL == 'ne' .OR. LREL == '/=') THEN
              JREL = 'NE'
          ELSE IF (LREL == 'lt' .OR. LREL == '<') THEN
              JREL = 'LT'
          ELSE IF (LREL == 'gt' .OR. LREL == '>') THEN
              JREL = 'GT'
          ELSE IF (LREL == 'le' .OR. LREL == '<=') THEN
              JREL = 'LE'
          ELSE IF (LREL == 'ge' .OR. LREL == '>=') THEN
              JREL = 'GE'
          ELSE
              FMCOMP = .FALSE.
!                                                 DELETE START
              KFLAG = -4
              IF (NCALL /= 1 .OR. KWARN <= 0) GO TO 120
!                                                 DELETE STOP
              IF (KWARN <= 0) GO TO 120
              WRITE (KW,  &
                     "(/' Error of type KFLAG = -4 in FM package in',"   //  &
                     "' routine FMCOMP'//1X,A,' is not one of the six'," //  &
                     "' recognized comparisons.'//' .FALSE. has been',"  //  &
                     "' returned.'/)"                                        &
                    ) LREL
              IF (KWARN >= 2) THEN
                  STOP
              ENDIF
              GO TO 120
          ENDIF
      ENDIF

      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
          FMCOMP = .FALSE.
!                                                 DELETE START
          KFLAG = -4
!                                                 DELETE STOP
          GO TO 120
      ENDIF

      IF (ABS(MA(1)) == MEXPOV .AND. MA(1) == MB(1) .AND.  &
          MA(2) == MB(2) .AND. MA(-1) == MB(-1)) THEN
          FMCOMP = .FALSE.
!                                                 DELETE START
          KFLAG = -4
          IF (NCALL /= 1 .OR. KWARN <= 0) GO TO 120
!                                                 DELETE STOP
          IF (KWARN <= 0) GO TO 120
          WRITE (KW,  &
                 "(/' Error of type KFLAG = -4 in FM package in routine'," //  &
                 "' FMCOMP'//' Two numbers in the same overflow or',"      //  &
                 "' underflow category cannot be compared.'//"             //  &
                 "' .FALSE. has been returned.'/)"                             &
                 )
          IF (KWARN >= 2) THEN
              STOP
          ENDIF
          GO TO 120
      ENDIF

!             Check for zero.

!                                                 DELETE START
      KFLAG = 0
!                                                 DELETE STOP
      IF (MA(2) == 0) THEN
          JCOMP = 2
          IF (MB(2) == 0) GO TO 110
          IF (MB(-1) < 0) JCOMP = 1
          IF (MB(-1) > 0) JCOMP = 3
          GO TO 110
      ENDIF
      IF (MB(2) == 0) THEN
          JCOMP = 1
          IF (MA(-1) < 0) JCOMP = 3
          GO TO 110
      ENDIF
!             Check for opposite signs.

      IF (MA(-1) > 0 .AND. MB(-1) < 0) THEN
          JCOMP = 1
          GO TO 110
      ENDIF
      IF (MB(-1) > 0 .AND. MA(-1) < 0) THEN
          JCOMP = 3
          GO TO 110
      ENDIF

!             See which one is larger in absolute value.

      IF (MA(1) > MB(1)) THEN
          JCOMP = 1
          GO TO 110
      ENDIF
      IF (MB(1) > MA(1)) THEN
          JCOMP = 3
          GO TO 110
      ENDIF
      NLAST = NDIG + 1

      DO J = 2, NLAST
         IF (ABS(MA(J)) > ABS(MB(J))) THEN
             JCOMP = 1
             GO TO 110
         ENDIF
         IF (ABS(MB(J)) > ABS(MA(J))) THEN
             JCOMP = 3
             GO TO 110
         ENDIF
      ENDDO

      JCOMP = 2

!             Now match the JCOMP value to the requested comparison.

  110 IF (JCOMP == 1 .AND. MA(-1) < 0) THEN
          JCOMP = 3
      ELSE IF (JCOMP == 3 .AND. MB(-1) < 0) THEN
          JCOMP = 1
      ENDIF

      FMCOMP = .FALSE.
      IF (JCOMP == 1 .AND. (JREL == 'GT' .OR. JREL == 'GE' .OR.  &
                            JREL == 'NE')) FMCOMP = .TRUE.

      IF (JCOMP == 2 .AND. (JREL == 'EQ' .OR. JREL == 'GE' .OR.  &
                            JREL == 'LE')) FMCOMP = .TRUE.

      IF (JCOMP == 3 .AND. (JREL == 'NE' .OR. JREL == 'LT' .OR.  &
                            JREL == 'LE')) FMCOMP = .TRUE.

  120 CONTINUE
!                                                 DELETE START
      IF (NTRACE /= 0) THEN
          IF (NCALL <= LVLTRC .AND. ABS(NTRACE) >= 1) THEN
              IF (KFLAG == 0) THEN
                  WRITE (KW,  &
                         "(' FMCOMP',15X,'Call level =',I2,5X,'MBASE =',"  //  &
                         "I10,5X,'NDIG =',I6)"                                 &
                        ) NCALL,INT(MBASE),NDIG
              ELSE
                  WRITE (KW,  &
                         "(' FMCOMP',6X,'Call level =',I2,4X,'MBASE =',"  //  &
                         "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)"                &
                        ) NCALL,INT(MBASE),NDIG,KFLAG
              ENDIF
              IF (FMCOMP) THEN
                  WRITE (KW,"(7X,'.TRUE.')")
              ELSE
                  WRITE (KW,"(7X,'.FALSE.')")
              ENDIF
          ENDIF
      ENDIF
      NCALL = NCALL - 1
!                                                 DELETE STOP
      RETURN
      END FUNCTION FMCOMP

      SUBROUTINE FMCONS

!  Set several saved machine precision constants.

      USE FMVALS
      IMPLICIT NONE

      MBLOGS = MBASE
      ALOGMB = LOG(REAL(MBASE))
      ALOGM2 = ALOGMB/LOG(2.0)
      ALOGMX = LOG(REAL(MAXINT))
      ALOGMT = ALOGMB/LOG(10.0)
      NGRD21 = INT(2.0/ALOGMT + 1.0)
      NGRD52 = INT(5.0/ALOGMT + 2.0)
      NGRD22 = INT(2.0/ALOGMT + 2.0)
      IF (MBASE < 1000 .OR. KRPERF /= 0) THEN
          NGRD21 = 2*NGRD21
          NGRD52 = 4*NGRD52
          NGRD22 = 2*NGRD22
      ENDIF
      MEXPAB = AINT (MXEXP2/5)
      DLOGMB = LOG(DBLE(MBASE))
      DLOGTN = LOG(10.0D0)
      DLOGTW = LOG(2.0D0)
      DPPI = 4.0D0*ATAN(1.0D0)
      DLOGTP = LOG(2.0D0*DPPI)
      DLOGPI = LOG(DPPI)
      DLOGEB = -LOG(DPEPS)/DLOGMB

      RETURN
      END SUBROUTINE FMCONS

      SUBROUTINE FMCOS(MA,MB)

!  MB = COS(MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
      INTEGER J,JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NDSV

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN
          CALL FMENTR('FMCOS ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMCOS '
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,MB,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      MACCA = MA(0)
      CALL FMEQ2(MA,MB,NDSAVE,NDIG)
      MB(0) = NINT(NDIG*ALOGM2)
      MB(-1) = 1
      CALL FMEQ(MB,MWE)
      KWRNSV = KWARN
      KWARN = 0

!             Reduce the argument, convert to radians if the input is
!             in degrees, and evaluate the function.

      CALL FMRDC(MB,JSIN,JCOS,JSWAP)
      KWARN = KWRNSV
      IF (MB(1) == MUNKNO) THEN
          IF (KRAD /= 1 .OR. JSWAP == 1) THEN
              CALL FMEQ(MWE,MB)
              CALL FMRDC(MB,JSIN,JCOS,JSWAP)
              GO TO 110
          ENDIF
          IF (MBSPI /= MBASE .OR. NDIGPI < NDIG)  THEN
              NDSV = NDIG
              NDIG = MIN(NDIG+2,NDG2MX)
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'NOEQ  '
              CALL FMPI(MPISAV)
              NCALL = NCALL - 1
              NDIG = NDSV
          ENDIF
          CALL FMDIV(MWE,MPISAV,M04)
          CALL FMNINT(M04,M03)
          CALL FMMPY(M03,MPISAV,M02)
          CALL FMSUB_R2(MWE,M02)
          IF (M02(2) == 0) CALL FMULP(MWE,M02)
          CALL FMI2M(1,M04)
          CALL FMSQR_R1(M02)
          CALL FMDIVI_R1(M02,2)
          CALL FMSUB_R2(M04,M02)
          CALL FMSUB_R1(M02,M04)
          IF (M02(2) == 0) THEN
              CALL FMI2M(JCOS,MB)
          ELSE
              CALL FMEQ(MWE,MB)
              CALL FMRDC(MB,JSIN,JCOS,JSWAP)
          ENDIF
          GO TO 110
      ENDIF
      IF (KRAD == 0) THEN
          IF (MBSPI /= MBASE .OR. NDIGPI < NDIG)  THEN
              NDSV = NDIG
              NDIG = MIN(NDIG+2,NDG2MX)
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'NOEQ  '
              CALL FMPI(MPISAV)
              NCALL = NCALL - 1
              NDIG = NDSV
          ENDIF
          CALL FMMPY_R1(MB,MPISAV)
          CALL FMDIVI_R1(MB,180)
      ENDIF
      IF (MB(1) /= MUNKNO) THEN
          IF (JSWAP == 0) THEN
              CALL FMCOS2(MB,M09)
              CALL FMEQ(M09,MB)
          ELSE
              IF (MB(1) < 0 .OR. NDIG <= 50) THEN
                  CALL FMSIN2(MB,M09)
                  CALL FMEQ(M09,MB)
              ELSE
                  CALL FMCOS2(MB,M09)
                  CALL FMEQ(M09,MB)
                  CALL FMI2M(1,M03)
                  CALL FMSQR_R1(MB)
                  CALL FMSUB_R2(M03,MB)
                  CALL FMSQRT_R1(MB)
              ENDIF
          ENDIF
      ENDIF

!             Append the sign, round, and return.

      IF (MB(1) /= MUNKNO .AND. MB(2) /= 0 .AND. JCOS == -1) MB(-1) = -MB(-1)
  110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
      MB(0) = MIN(MB(0),MACCA,MACMAX)
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMCOS

      SUBROUTINE FMCOS2(MA,MB)

!  Internal subroutine for MB = COS(MA) where 0 <= MA <= 1.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
!             LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent
!             sums.  Increasing this value will begin to improve the
!             speed of COS when the base is large and precision exceeds
!             about 1,500 decimal digits.

      REAL (KIND(1.0D0)) :: MAXVAL
      INTEGER J,J2,K,K2,KPT,KTWO,KWRNSV,L,L2,LARGE,N2,NBOT,NDSAV1,  &
              NDSAVE,NTERM
      REAL ALOG2,ALOGT,B,T,TJ

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (MA(2) == 0) THEN
          CALL FMI2M(1,MB)
          RETURN
      ENDIF
      NDSAVE = NDIG
      KWRNSV = KWARN
      KWARN = 0

!             Use the direct series
!                  COS(X) = 1 - X**2/2! + X**4/4! - ...

!             The argument will be divided by 2**K2 before the series
!             is summed.  The series will be added as J2 concurrent
!             series.  The approximately optimal values of K2 and J2
!             are now computed to try to minimize the time required.
!             N2/2 is the approximate number of terms of the series
!             that will be needed, and L2 guard digits will be carried.

!             Since X is small when the series is summed, COS(X) - 1
!             is computed.  Then a version of the recovery formula can
!             be used that does not suffer from severe cancellation.

      B = REAL(MBASE)
      K = NGRD52
      T = MAX(NDIG-K,2)
      ALOG2 = LOG(2.0)
      ALOGT = LOG(T)
      TJ = 0.03*ALOGMB*T**0.3333 + 1.85
      J2 = INT(TJ)
      J2 = MAX(1,MIN(J2,LJSUMS/NDG2MX))
      K2 = INT(0.5*SQRT(T*ALOGMB/TJ) + 2.8)

      L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B +  &
            REAL(MA(3))/(B*B)))/ALOG2 - 0.3)
      K2 = K2 - L
      IF (L < 0) L = 0
      IF (K2 < 0) THEN
          K2 = 0
          J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) + .33)
      ENDIF
      IF (J2 <= 1) J2 = 1

      N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2))
      L2 = INT(LOG(REAL(N2)+2.0**K2)/ALOGMB)
      NDIG = NDIG + L2
      IF (NDIG > NDG2MX) THEN
          IF (NCALL == 1) THEN
              KFLAG = -9
              CALL FMWARN
              NDIG = NDSAVE
              CALL FMST2M('UNKNOWN',MB)
              KWARN = KWRNSV
              RETURN
          ELSE
              NDIG = NDG2MX
          ENDIF
      ENDIF
      NDSAV1 = NDIG

!             Divide the argument by 2**K2.

      CALL FMEQ2(MA,M02,NDSAVE,NDIG)
      KTWO = 1
      MAXVAL = MXBASE/2
      IF (K2 > 0) THEN
          DO J = 1, K2
             KTWO = 2*KTWO
             IF (KTWO > MAXVAL) THEN
                 CALL FMDIVI_R1(M02,KTWO)
                 KTWO = 1
             ENDIF
          ENDDO
          IF (KTWO > 1) CALL FMDIVI_R1(M02,KTWO)
      ENDIF

!             Split into J2 concurrent sums and reduce NDIG while
!             computing each term in the sum as the terms get smaller.

      CALL FMSQR_R1(M02)
      CALL FMEQ(M02,M03)
      IF (M03(1) /= MUNKNO .AND. M03(2) /= 0) M03(-1) = -M03(-1)
      NTERM = 2
      DO J = 1, J2
         NBOT = NTERM*(NTERM-1)
         CALL FMDIVI_R1(M03,NBOT)
         NTERM = NTERM + 2
         KPT = (J-1)*(NDIG+3)
         CALL FMEQ(M03,MJSUMS(KPT-1))
         IF (M03(1) /= MUNKNO .AND. M03(2) /= 0) M03(-1) = -M03(-1)
      ENDDO
      IF (M02(1) < -NDIG) GO TO 120
      CALL FMIPWR(M02,J2,MB)

  110 CALL FMMPY_R1(M03,MB)
      LARGE = INT(INTMAX/NTERM)
      DO J = 1, J2
         NBOT = NTERM*(NTERM-1)
         IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN
             CALL FMDIVI_R1(M03,NTERM)
             NBOT = NTERM - 1
             CALL FMDIVI_R1(M03,NBOT)
         ELSE
             CALL FMDIVI_R1(M03,NBOT)
         ENDIF
         KPT = (J-1)*(NDSAV1+3)
         NDIG = NDSAV1
         CALL FMADD_R1(MJSUMS(KPT-1),M03)
         IF (KFLAG /= 0) GO TO 120
         NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1))
         IF (NDIG < 2) NDIG = 2
         IF (M03(1) /= MUNKNO .AND. M03(2) /= 0) M03(-1) = -M03(-1)
         NTERM = NTERM + 2
      ENDDO
      GO TO 110

!             Next put the J2 separate sums back together.

  120 KFLAG = 0
      KPT = (J2-1)*(NDIG+3)
      CALL FMEQ(MJSUMS(KPT-1),MB)
      IF (J2 >= 2) THEN
          DO J = 2, J2
             CALL FMMPY_R2(M02,MB)
             KPT = (J2-J)*(NDIG+3)
             CALL FMADD_R1(MB,MJSUMS(KPT-1))
          ENDDO
      ENDIF

!             Reverse the effect of reducing the argument to
!             compute COS(MA).

      NDIG = NDSAV1
      IF (K2 > 0) THEN
          IF (NDSAVE <= 20) THEN
              CALL FMI2M(2,M02)
              DO J = 1, K2
                 CALL FMADD(MB,M02,M03)
                 CALL FMMPY_R2(MB,M03)
                 CALL FMADD(M03,M03,MB)
              ENDDO
          ELSE
              DO J = 1, K2
                 CALL FMSQR(MB,M03)
                 CALL FMADD(MB,MB,M02)
                 CALL FMADD_R1(M03,M02)
                 CALL FMADD(M03,M03,MB)
              ENDDO
          ENDIF
      ENDIF
      CALL FMI2M(1,M03)
      CALL FMADD_R2(M03,MB)

      CALL FMEQ2_R1(MB,NDSAV1,NDSAVE)
      NDIG = NDSAVE
      KWARN = KWRNSV

      RETURN
      END SUBROUTINE FMCOS2

      SUBROUTINE FMCOSH(MA,MB)

!  MB = COSH(MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
      INTEGER J,K,KASAVE,KOVUN,KRESLT,NDSAVE,NMETHD

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB) THEN
          CALL FMENTR('FMCOSH',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMCOSH'
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,MB,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      MACCA = MA(0)
      CALL FMEQ2(MA,MB,NDSAVE,NDIG)
      MB(0) = NINT(NDIG*ALOGM2)
      MB(-1) = 1
      IF (MA(2) == 0) THEN
          CALL FMI2M(1,MB)
          GO TO 120
      ENDIF

!             Use a series for small arguments, FMEXP for large ones.

      IF (MB(1) == MUNKNO) GO TO 120
      IF (MBASE > 99) THEN
          IF (MB(1) <= 0) THEN
              NMETHD = 1
          ELSE IF (MB(1) >= 2) THEN
              NMETHD = 2
          ELSE IF (ABS(MB(2)) < 10) THEN
              NMETHD = 1
          ELSE
              NMETHD = 2
          ENDIF
      ELSE
          IF (MB(1) <= 0) THEN
              NMETHD = 1
          ELSE
              NMETHD = 2
          ENDIF
      ENDIF

      IF (NMETHD == 2) GO TO 110
      CALL FMCSH2(MB,M09)
      CALL FMEQ(M09,MB)
      GO TO 120

  110 CALL FMEXP(MB,M12)
      CALL FMEQ(M12,MB)
      IF (MB(1) == MEXPOV) THEN
          GO TO 120
      ELSE IF (MB(1) == MEXPUN) THEN
          MB(1) = MEXPOV
          GO TO 120
      ENDIF
      IF (INT(MB(1)) <= (NDIG+1)/2) THEN
          CALL FMI2M(1,M01)
          CALL FMDIV_R1(M01,MB)
          CALL FMADD_R1(MB,M01)
      ENDIF
      CALL FMDIVI_R1(MB,2)

!             Round and return.

  120 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
      MB(0) = MIN(MB(0),MACCA,MACMAX)
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMCOSH

      SUBROUTINE FMCSH2(MA,MB)

!  Internal subroutine for MB = COSH(MA).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
!             LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent
!             sums.  Increasing this value will begin to improve the
!             speed of COSH when the base is large and precision exceeds
!             about 1,500 decimal digits.

      REAL (KIND(1.0D0)) :: MAXVAL
      INTEGER J,J2,K,K2,KPT,KTWO,KWRNSV,L,L2,LARGE,N2,NBOT,NDSAV1,  &
              NDSAVE,NTERM
      REAL ALOG2,ALOGT,B,T,TJ

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (MA(2) == 0) THEN
          CALL FMI2M(1,MB)
          RETURN
      ENDIF
      NDSAVE = NDIG
      KWRNSV = KWARN
      KWARN = 0

!             Use the direct series
!                  COSH(X) = 1 + X**2/2! + X**4/4! - ...

!             The argument will be divided by 2**K2 before the series
!             is summed.  The series will be added as J2 concurrent
!             series.  The approximately optimal values of K2 and J2
!             are now computed to try to minimize the time required.
!             N2/2 is the approximate number of terms of the series
!             that will be needed, and L2 guard digits will be carried.

!             Since X is small when the series is summed, COSH(X) - 1
!             is computed.  Then a version of the recovery formula can
!             be used that does not suffer from severe cancellation.

      B = REAL(MBASE)
      K = NGRD52
      T = MAX(NDIG-K,2)
      ALOG2 = LOG(2.0)
      ALOGT = LOG(T)
      TJ = 0.03*ALOGMB*T**0.3333 + 1.85
      J2 = INT(TJ)
      J2 = MAX(1,MIN(J2,LJSUMS/NDG2MX))
      K2 = INT(0.5*SQRT(T*ALOGMB/TJ) + 2.8)

      L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B +  &
            REAL(MA(3))/(B*B)))/ALOG2 - 0.3)
      K2 = K2 - L
      IF (L < 0) L = 0
      IF (K2 < 0) THEN
          K2 = 0
          J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) + .33)
      ENDIF
      IF (J2 <= 1) J2 = 1

      N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2))
      L2 = INT(LOG(REAL(N2)+2.0**K2)/ALOGMB)
      NDIG = NDIG + L2
      IF (NDIG > NDG2MX) THEN
          IF (NCALL == 1) THEN
              KFLAG = -9
              CALL FMWARN
              NDIG = NDSAVE
              CALL FMST2M('UNKNOWN',MB)
              KWARN = KWRNSV
              RETURN
          ELSE
              NDIG = NDG2MX
          ENDIF
      ENDIF
      NDSAV1 = NDIG
      CALL FMEQ2(MA,M02,NDSAVE,NDIG)

!             Divide the argument by 2**K2.

      KTWO = 1
      MAXVAL = MXBASE/2
      IF (K2 > 0) THEN
          DO J = 1, K2
             KTWO = 2*KTWO
             IF (KTWO > MAXVAL) THEN
                 CALL FMDIVI_R1(M02,KTWO)
                 KTWO = 1
             ENDIF
          ENDDO
          IF (KTWO > 1) CALL FMDIVI_R1(M02,KTWO)
      ENDIF

!             Split into J2 concurrent sums and reduce NDIG while
!             computing each term in the sum as the terms get smaller.

      CALL FMSQR_R1(M02)
      CALL FMEQ(M02,M03)
      NTERM = 2
      DO J = 1, J2
         NBOT = NTERM*(NTERM-1)
         CALL FMDIVI_R1(M03,NBOT)
         NTERM = NTERM + 2
         KPT = (J-1)*(NDIG+3)
         CALL FMEQ(M03,MJSUMS(KPT-1))
      ENDDO
      IF (M02(1) < -NDIG) GO TO 120
      CALL FMIPWR(M02,J2,MB)

  110 CALL FMMPY_R1(M03,MB)
      LARGE = INT(INTMAX/NTERM)
      DO J = 1, J2
         NBOT = NTERM*(NTERM-1)
         IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN
             CALL FMDIVI_R1(M03,NTERM)
             NBOT = NTERM - 1
             CALL FMDIVI_R1(M03,NBOT)
         ELSE
             CALL FMDIVI_R1(M03,NBOT)
         ENDIF
         KPT = (J-1)*(NDSAV1+3)
         NDIG = NDSAV1
         CALL FMADD_R1(MJSUMS(KPT-1),M03)
         IF (KFLAG /= 0) GO TO 120
         NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1))
         IF (NDIG < 2) NDIG = 2
         NTERM = NTERM + 2
      ENDDO
      GO TO 110

!             Next put the J2 separate sums back together.

  120 KFLAG = 0
      KPT = (J2-1)*(NDIG+3)
      CALL FMEQ(MJSUMS(KPT-1),MB)
      IF (J2 >= 2) THEN
          DO J = 2, J2
             CALL FMMPY_R2(M02,MB)
             KPT = (J2-J)*(NDIG+3)
             CALL FMADD_R1(MB,MJSUMS(KPT-1))
          ENDDO
      ENDIF

!             Reverse the effect of reducing the argument to
!             compute COSH(MA).

      NDIG = NDSAV1
      IF (K2 > 0) THEN
          IF (NDSAVE <= 20) THEN
              CALL FMI2M(2,M02)
              DO J = 1, K2
                 CALL FMADD(MB,M02,M03)
                 CALL FMMPY_R2(MB,M03)
                 CALL FMADD(M03,M03,MB)
              ENDDO
          ELSE
              DO J = 1, K2
                 CALL FMSQR(MB,M03)
                 CALL FMADD(MB,MB,M02)
                 CALL FMADD_R1(M03,M02)
                 CALL FMADD(M03,M03,MB)
              ENDDO
          ENDIF
      ENDIF
      CALL FMI2M(1,M03)
      CALL FMADD_R2(M03,MB)

      CALL FMEQ2_R1(MB,NDSAV1,NDSAVE)
      NDIG = NDSAVE
      KWARN = KWRNSV

      RETURN
      END SUBROUTINE FMCSH2

      SUBROUTINE FMCSSN(MA,MB,MC)

!  MB = COS(MA),    MC = SIN(MA)

!  If both the sine and cosine are needed, this routine is faster
!  than calling both FMCOS and FMSIN.

!  MB and MC must be distinct arrays.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
      INTEGER J,JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,KWRNSV,NCSAVE,  &
              NDSAVE,NDSV

      IF (MBLOGS /= MBASE) CALL FMCONS
      MACCA = MA(0)
      MAS = MA(-1)
      IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN
          NCSAVE = NCALL
          CALL FMENTR('FMCSSN',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (MA(1) == MUNKNO) KOVUN = 2
          NCALL = NCSAVE + 1
          CALL FMEQ2(MA,M05,NDSAVE,NDIG)
          M05(0) = NINT(NDIG*ALOGM2)
          M05(-1) = 1
          CALL FMCOS(M05,MB)
          CALL FMSIN(M05,MC)
          GO TO 110
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMCSSN'
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  NCALL = NCALL - 1
                  NDIG = NDSAVE
                  CALL FMEQ(MA,M05)
                  CALL FMCOS(M05,MB)
                  CALL FMSIN(M05,MC)
                  KFLAG = -9
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      IF (MA(2) == 0) THEN
          CALL FMI2M(1,MB)
          CALL FMI2M(0,MC)
          GO TO 110
      ENDIF

      CALL FMEQ2(MA,MB,NDSAVE,NDIG)
      MB(0) = NINT(NDIG*ALOGM2)
      MB(-1) = 1
      CALL FMEQ(MB,MWE)

!             Reduce the argument, convert to radians if the input is
!             in degrees, and evaluate the functions.

      CALL FMRDC(MB,JSIN,JCOS,JSWAP)
      IF (MB(1) == MUNKNO) THEN
          CALL FMCOS(MWE,MB)
          CALL FMSIN(MWE,MC)
          GO TO 110
      ENDIF
      IF (KRAD == 0) THEN
          IF (MBSPI /= MBASE .OR. NDIGPI < NDIG)  THEN
              NDSV = NDIG
              NDIG = MIN(NDIG+2,NDG2MX)
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'NOEQ  '
              CALL FMPI(MPISAV)
              NCALL = NCALL - 1
              NDIG = NDSV
          ENDIF
          CALL FMMPY_R1(MB,MPISAV)
          CALL FMDIVI_R1(MB,180)
      ENDIF
      IF (MB(1) /= MUNKNO) THEN
          IF (JSWAP == 0) THEN
              IF (MB(1) < 0) THEN
                  CALL FMSIN2(MB,MC)
                  MC(-1) = JSIN*MC(-1)
                  CALL FMSQR(MC,M03)
                  CALL FMI2M(1,M02)
                  CALL FMSUB_R2(M02,M03)
                  CALL FMSQRT(M03,MB)
                  MB(-1) = JCOS*MB(-1)
              ELSE
                  CALL FMCOS2(MB,M09)
                  CALL FMEQ(M09,MB)
                  MB(-1) = JCOS*MB(-1)
                  CALL FMSQR(MB,M03)
                  CALL FMI2M(1,M02)
                  CALL FMSUB_R2(M02,M03)
                  CALL FMSQRT(M03,MC)
                  MC(-1) = JSIN*MC(-1)
              ENDIF
          ELSE
              IF (MB(1) < 0) THEN
                  CALL FMSIN2(MB,M09)
                  CALL FMEQ(M09,MB)
                  MB(-1) = JCOS*MB(-1)
                  CALL FMSQR(MB,M03)
                  CALL FMI2M(1,M02)
                  CALL FMSUB_R2(M02,M03)
                  CALL FMSQRT(M03,MC)
                  MC(-1) = JSIN*MC(-1)
              ELSE
                  CALL FMCOS2(MB,MC)
                  MC(-1) = JSIN*MC(-1)
                  CALL FMSQR(MC,M03)
                  CALL FMI2M(1,M02)
                  CALL FMSUB_R2(M02,M03)
                  CALL FMSQRT(M03,MB)
                  MB(-1) = JCOS*MB(-1)
              ENDIF
          ENDIF
      ELSE
          CALL FMEQ(MB,MC)
      ENDIF

!             Round and return.

  110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)
      MC(0) = MIN(MC(0),MACCA,MACMAX)
      IF (MAS < 0 .AND. MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
      CALL FMEQ2_R1(MC,NDIG,NDSAVE)
      MB(0) = MIN(MB(0),MACCA,MACMAX)
      IF (KOVUN == 2) THEN
          KWRNSV = KWARN
          KWARN = 0
      ENDIF
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      IF (KOVUN == 2) THEN
          KWARN = KWRNSV
      ENDIF
      IF (NTRACE /= 0) THEN
          IF (ABS(NTRACE) >= 1 .AND. NCALL+1 <= LVLTRC) THEN
              IF (NTRACE < 0) THEN
                  CALL FMNTRJ(MC,NDIG)
              ELSE
                  CALL FMPRNT(MC)
              ENDIF
          ENDIF
      ENDIF
      RETURN
      END SUBROUTINE FMCSSN

      SUBROUTINE FMDBL(A,B,C)

!  C = A + B.  All are double precision.  This routine tries to
!  force the compiler to round C to double precision accuracy.
!  Some compilers allow double precision loops like the ones in
!  FMSET and FMDM to be done in extended precision, which defeats
!  the routine's attempt to determine double precision accuracy.
!  This can lead to doing too few Newton steps and failing to
!  get sufficient accuracy in several FM routines.

      USE FMVALS
      IMPLICIT NONE
      DOUBLE PRECISION A,B,C
      C = A + B
      RETURN
      END SUBROUTINE FMDBL

      SUBROUTINE FMDIG(NSTACK,KST)

!  Compute the number of intermediate digits to be used in Newton
!  iteration.  This assumes that a starting approximation that is
!  accurate to double precision is used, and the root is simple.

!  KST is the number of iterations needed for final accuracy NDIG.
!  NSTACK(J) holds the value of NDIG to be used for the
!            Jth iteration.

      USE FMVALS
      IMPLICIT NONE

      INTEGER NSTACK(19),KST

      DOUBLE PRECISION Y
      INTEGER J,JT,L,ND,NDT,NE

      IF (MBLOGS /= MBASE) CALL FMCONS

!             NE is the maximum number of base MBASE digits that
!             can be used in the first Newton iteration.

      NE = INT(1.9D0*DLOGEB)

!             Fill the intermediate digit stack (backwards).

      KST = 1
      ND = NDIG
      NSTACK(1) = ND
      IF (ND < NE .OR. ND <= 2) RETURN

  110 Y = ND

!             The 1.9 accounts for the fact that the number of correct
!             digits approximately doubles at each iteration.

      NDT = INT(Y/1.9D0)
      IF (2*NDT <= ND) NDT = NDT + 1
      ND = NDT
      KST = KST + 1
      NSTACK(KST) = ND
      IF (ND > NE .AND. ND > 2) GO TO 110

!             Reverse the stack.

      L = KST/2
      DO J = 1, L
         JT = NSTACK(J)
         NSTACK(J) = NSTACK(KST+1-J)
         NSTACK(KST+1-J) = JT
      ENDDO

      RETURN
      END SUBROUTINE FMDIG

      SUBROUTINE FMDIM(MA,MB,MC)

!  MC = DIM(MA,MB)

!  Positive difference.  MC = MA - MB  if MA >= MB,
!                           = 0        otherwise.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MXSAVE
      INTEGER J,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE
      LOGICAL FMCOMP

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB) THEN
          CALL FMENTR('FMDIM ',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMDIM '
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52-1,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MB,MC,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF
      KWRNSV = KWARN
      KWARN = 0
      MXEXP = MXSAVE

      MACCA = MA(0)
      MACCB = MB(0)
      CALL FMEQ2(MA,M01,NDSAVE,NDIG)
      M01(0) = NINT(NDIG*ALOGM2)
      CALL FMEQ2(MB,M02,NDSAVE,NDIG)
      M02(0) = NINT(NDIG*ALOGM2)

      IF (FMCOMP(M01,'LT',M02)) THEN
          CALL FMI2M(0,MC)
      ELSE
          CALL FMSUB(M01,M02,MC)
      ENDIF

      IF (KFLAG == 1) KFLAG = 0
      KWARN = KWRNSV
      MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)
      MC(0) = MIN(MC(0),MACCA,MACCB,MACMAX)
      DO J = -1, NDIG+1
         M01(J) = MC(J)
      ENDDO
      CALL FMEXIT(M01,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMDIM

      SUBROUTINE FMDIV(MA,MB,MC)

!  MC = MA / MB

!  This routine performs the trace printing for division.
!  FMDIV2 is used to do the arithmetic.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMDIV '
          CALL FMNTR(2,MA,MB,2,1)

          CALL FMDIV2(MA,MB,MC)

          CALL FMNTR(1,MC,MC,1,1)
      ELSE
          CALL FMDIV2(MA,MB,MC)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMDIV

      SUBROUTINE FMDIV2(MA,MB,MC)

!  Internal division routine.  MC = MA / MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MLR,MR,MS,MT1,MT2
      INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KT3,L,N1,NG,NGUARD,NL

      IF (MBLOGS /= MBASE) CALL FMCONS
      JRSSAV = JRSIGN
      MACCA = MA(0)
      MACCB = MB(0)
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR.  &
          KDEBUG == 1) THEN
          CALL FMARGS('FMDIV ',2,MA,MB,KRESLT)
          IF (KRESLT /= 0) THEN
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'FMDIV '
              CALL FMRSLT(MA,MB,MC,KRESLT)
              JRSIGN = JRSSAV
              NCALL = NCALL - 1
              RETURN
          ENDIF
      ELSE
          IF (MB(2) == 0) THEN
              NAMEST(NCALL) = 'FMDIV '
              CALL FMIM(0,MC)
              KFLAG = -4
              CALL FMWARN
              MC(1) = MUNKNO
              MC(2) = 1
              MC(0) = NINT(NDIG*ALOGM2)
              JRSIGN = JRSSAV
              RETURN
          ENDIF
          IF (MA(2) == 0) THEN
              CALL FMIM(0,MC)
              MC(0) = MIN(MACCA,MACCB)
              JRSIGN = JRSSAV
              RETURN
          ENDIF
      ENDIF
      KFLAG = 0

!             NGUARD is the number of guard digits used.

      IF (NCALL > 1) THEN
          NGUARD = NGRD21
          IF (NGUARD > NDIG) NGUARD = NDIG
      ELSE
          NGUARD = NGRD52 - 1
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 10
          ENDIF
      ENDIF
      N1 = NDIG + 1
      NG = NDIG + NGUARD

!             Save the sign of MA and MB and then work only with
!             positive numbers.

      MAS = MA(-1)
      MBS = MB(-1)
      IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      MWA(1) = MA(1) - MB(1) + 1

      IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
          IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN
              MBASEL = MBASE
              NDIGL = NDIG
              NGUARL = NGUARD
              DO J = 2, 1000
                 MR = MBASE*MBASEL
                 IF (4*MR > MXBASE) THEN
                     N21 = J - 1
                     NDIG = (NDIGL-1)/N21 + 1
                     IF (NDIG < 2) NDIG = 2
                     NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG
                     IF (NGRDN < 1) NGRDN = 1
                     EXIT
                 ENDIF
                 MBASE = MR
              ENDDO
              MBASEN = MBASE
              NDIGN = NDIG
          ELSE
              MBASE = MBASEN
              NDIG = NDIGN
          ENDIF
          MPMA(1) = 0
          MPMB(1) = 0
          L = 2 - N21
          DO J = 2, NDIGL+2-N21, N21
             MT1 = MA(J)
             MT2 = MB(J)
             DO K = J+1, J+N21-1
                MT1 = MT1*MBASEL + MA(K)
                MT2 = MT2*MBASEL + MB(K)
             ENDDO
             MPMA(2+J/N21) = MT1
             MPMB(2+J/N21) = MT2
             L = J
          ENDDO
          DO J = 3+L/N21, NDIG+NGRDN+2
             MPMA(J) = 0
             MPMB(J) = 0
          ENDDO
          IF (L+N21 <= NDIGL+1) THEN
              MT1 = 0
              MT2 = 0
              DO J = L+N21, L+2*N21-1
                 IF (J <= NDIGL+1) THEN
                     MT1 = MT1*MBASEL + MA(J)
                     MT2 = MT2*MBASEL + MB(J)
                 ELSE
                     MT1 = MT1*MBASEL
                     MT2 = MT2*MBASEL
                 ENDIF
              ENDDO
              MPMA(2+(L+N21)/N21) = MT1
              MPMB(2+(L+N21)/N21) = MT2
          ENDIF
          NG = NDIG + NGRDN + 1
          IF (MPMA(2) >= MPMB(2)) NG = NG + 1

!             Copy MA into the working array.

          DO J = 2, NDIG+1
             MWA(J+1) = MPMA(J)
          ENDDO
          MWA(2) = 0
          DO J = NDIG+3, NG+4
             MWA(J) = 0
          ENDDO
          CALL FMDIV3(MPMB,NG)
          KT3 = N21 - 1
          IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN
              DO J = 2+NDIG+NGRDN, 3, -1
                 KT1 = MWA(J)
                 KT = 2 + (J-2)*N21
                 KT2 = N21 + KT - 1
                 DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3)
                    MWA(K-KT3) = IBITS(KT1,KT2-K,1)
                 ENDDO
              ENDDO
          ELSE
              MS = MBASEL**(N21-1)
              DO J = 2+NDIG+NGRDN, 3, -1
                 MR = MS
                 MT1 = MWA(J)
                 DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3)
                    MWA(K-KT3) = AINT (MT1/MR)
                    MT1 = MT1 - MWA(K-KT3)*MR
                    MR = AINT (MR/MBASEL)
                 ENDDO
              ENDDO
          ENDIF
          NDIG = NDIGL
          MBASE = MBASEL
      ELSE

!             Copy MA into the working array.

          DO J = 2, N1
             MWA(J+1) = MA(J)
          ENDDO
          MWA(2) = 0
          NL = N1 + NGUARD + 3
          DO J = NDIG+3, NL
             MWA(J) = 0
          ENDDO
          CALL FMDIV3(MB,NG)
      ENDIF

!             Round, affix the sign, and return.

      IF (MWA(2) == 0) THEN
          MLR = 2*MWA(NDIG+3) + 1
          IF (KROUND == -1 .OR. KROUND == 2) THEN
              CALL FMRND(MWA,NDIG,NGUARD,1)
          ELSE IF (MLR >= MBASE) THEN
              IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN
                  IF (KROUND /= 0 .OR. NCALL > 1) THEN
                      MWA(N1+1) = MWA(N1+1) + 1
                      MWA(N1+2) = 0
                  ENDIF
              ELSE
                  CALL FMRND(MWA,NDIG,NGUARD,1)
              ENDIF
          ENDIF
      ELSE
          MLR = 2*MWA(NDIG+2) + 1
          IF (KROUND == -1 .OR. KROUND == 2) THEN
              CALL FMRND(MWA,NDIG,NGUARD,0)
          ELSE IF (MLR >= MBASE) THEN
              IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
                  IF (KROUND /= 0 .OR. NCALL > 1) THEN
                      MWA(N1) = MWA(N1) + 1
                      MWA(N1+1) = 0
                  ENDIF
              ELSE
                  CALL FMRND(MWA,NDIG,NGUARD,0)
              ENDIF
          ENDIF
      ENDIF
      CALL FMMOVE(MWA,MC)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'FMDIV '
          CALL FMWARN
      ENDIF

      MC(-1) = 1
      IF (MAS*MBS < 0 .AND. MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1

      IF (KACCSW == 1) THEN
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)
          MC(0) = MIN(MACCA,MACCB,MD2B)
      ELSE
          MC(0) = MIN(MACCA,MACCB)
      ENDIF
      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMDIV2

      SUBROUTINE FMDIV_R1(MA,MB)

!  MA = MA / MB

!  This routine performs the trace printing for division.
!  FMDIV2_R1 is used to do the arithmetic.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMDIV '
          CALL FMNTR(2,MA,MB,2,1)

          CALL FMDIV2_R1(MA,MB)

          CALL FMNTR(1,MA,MA,1,1)
      ELSE
          CALL FMDIV2_R1(MA,MB)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMDIV_R1

      SUBROUTINE FMDIV2_R1(MA,MB)

!  Internal division routine.  MA = MA / MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MLR,MR,MS,MT1,MT2
      INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KT3,L,N1,NG,NGUARD,NL

      IF (MBLOGS /= MBASE) CALL FMCONS
      JRSSAV = JRSIGN
      MACCA = MA(0)
      MACCB = MB(0)
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR.  &
          KDEBUG == 1) THEN
          CALL FMARGS('FMDIV ',2,MA,MB,KRESLT)
          IF (KRESLT /= 0) THEN
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'FMDIV '
              CALL FMRSLT(MA,MB,M07,KRESLT)
              CALL FMEQ(M07,MA)
              JRSIGN = JRSSAV
              NCALL = NCALL - 1
              RETURN
          ENDIF
      ELSE
          IF (MB(2) == 0) THEN
              NAMEST(NCALL) = 'FMDIV '
              CALL FMIM(0,MA)
              KFLAG = -4
              CALL FMWARN
              MA(1) = MUNKNO
              MA(2) = 1
              MA(0) = NINT(NDIG*ALOGM2)
              JRSIGN = JRSSAV
              RETURN
          ENDIF
          IF (MA(2) == 0) THEN
              CALL FMIM(0,MA)
              MA(0) = MIN(MACCA,MACCB)
              JRSIGN = JRSSAV
              RETURN
          ENDIF
      ENDIF
      KFLAG = 0

!             NGUARD is the number of guard digits used.

      IF (NCALL > 1) THEN
          NGUARD = NGRD21
          IF (NGUARD > NDIG) NGUARD = NDIG
      ELSE
          NGUARD = NGRD52 - 1
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 10
          ENDIF
      ENDIF
      N1 = NDIG + 1
      NG = NDIG + NGUARD

!             Save the sign of MA and MB and then work only with
!             positive numbers.

      MAS = MA(-1)
      MBS = MB(-1)
      IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      MWA(1) = MA(1) - MB(1) + 1

      IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
          IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN
              MBASEL = MBASE
              NDIGL = NDIG
              NGUARL = NGUARD
              DO J = 2, 1000
                 MR = MBASE*MBASEL
                 IF (4*MR > MXBASE) THEN
                     N21 = J - 1
                     NDIG = (NDIGL-1)/N21 + 1
                     IF (NDIG < 2) NDIG = 2
                     NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG
                     IF (NGRDN < 1) NGRDN = 1
                     EXIT
                 ENDIF
                 MBASE = MR
              ENDDO
              MBASEN = MBASE
              NDIGN = NDIG
          ELSE
              MBASE = MBASEN
              NDIG = NDIGN
          ENDIF
          MPMA(1) = 0
          MPMB(1) = 0
          L = 2 - N21
          DO J = 2, NDIGL+2-N21, N21
             MT1 = MA(J)
             MT2 = MB(J)
             DO K = J+1, J+N21-1
                MT1 = MT1*MBASEL + MA(K)
                MT2 = MT2*MBASEL + MB(K)
             ENDDO
             MPMA(2+J/N21) = MT1
             MPMB(2+J/N21) = MT2
             L = J
          ENDDO
          DO J = 3+L/N21, NDIG+NGRDN+2
             MPMA(J) = 0
             MPMB(J) = 0
          ENDDO
          IF (L+N21 <= NDIGL+1) THEN
              MT1 = 0
              MT2 = 0
              DO J = L+N21, L+2*N21-1
                 IF (J <= NDIGL+1) THEN
                     MT1 = MT1*MBASEL + MA(J)
                     MT2 = MT2*MBASEL + MB(J)
                 ELSE
                     MT1 = MT1*MBASEL
                     MT2 = MT2*MBASEL
                 ENDIF
              ENDDO
              MPMA(2+(L+N21)/N21) = MT1
              MPMB(2+(L+N21)/N21) = MT2
          ENDIF
          NG = NDIG + NGRDN + 1
          IF (MPMA(2) >= MPMB(2)) NG = NG + 1

!             Copy MA into the working array.

          DO J = 2, NDIG+1
             MWA(J+1) = MPMA(J)
          ENDDO
          MWA(2) = 0
          DO J = NDIG+3, NG+4
             MWA(J) = 0
          ENDDO
          CALL FMDIV3(MPMB,NG)
          KT3 = N21 - 1
          IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN
              DO J = 2+NDIG+NGRDN, 3, -1
                 KT1 = MWA(J)
                 KT = 2 + (J-2)*N21
                 KT2 = N21 + KT - 1
                 DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3)
                    MWA(K-KT3) = IBITS(KT1,KT2-K,1)
                 ENDDO
              ENDDO
          ELSE
              MS = MBASEL**(N21-1)
              DO J = 2+NDIG+NGRDN, 3, -1
                 MR = MS
                 MT1 = MWA(J)
                 DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3)
                    MWA(K-KT3) = AINT (MT1/MR)
                    MT1 = MT1 - MWA(K-KT3)*MR
                    MR = AINT (MR/MBASEL)
                 ENDDO
              ENDDO
          ENDIF
          NDIG = NDIGL
          MBASE = MBASEL
      ELSE

!             Copy MA into the working array.

          DO J = 2, N1
             MWA(J+1) = MA(J)
          ENDDO
          MWA(2) = 0
          NL = N1 + NGUARD + 3
          DO J = NDIG+3, NL
             MWA(J) = 0
          ENDDO
          CALL FMDIV3(MB,NG)
      ENDIF

!             Round, affix the sign, and return.

      IF (MWA(2) == 0) THEN
          MLR = 2*MWA(NDIG+3) + 1
          IF (KROUND == -1 .OR. KROUND == 2) THEN
              CALL FMRND(MWA,NDIG,NGUARD,1)
          ELSE IF (MLR >= MBASE) THEN
              IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN
                  IF (KROUND /= 0 .OR. NCALL > 1) THEN
                      MWA(N1+1) = MWA(N1+1) + 1
                      MWA(N1+2) = 0
                  ENDIF
              ELSE
                  CALL FMRND(MWA,NDIG,NGUARD,1)
              ENDIF
          ENDIF
      ELSE
          MLR = 2*MWA(NDIG+2) + 1
          IF (KROUND == -1 .OR. KROUND == 2) THEN
              CALL FMRND(MWA,NDIG,NGUARD,0)
          ELSE IF (MLR >= MBASE) THEN
              IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
                  IF (KROUND /= 0 .OR. NCALL > 1) THEN
                      MWA(N1) = MWA(N1) + 1
                      MWA(N1+1) = 0
                  ENDIF
              ELSE
                  CALL FMRND(MWA,NDIG,NGUARD,0)
              ENDIF
          ENDIF
      ENDIF
      CALL FMMOVE(MWA,MA)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'FMDIV '
          CALL FMWARN
      ENDIF

      MA(-1) = 1
      IF (MAS*MBS < 0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1

      IF (KACCSW == 1) THEN
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315)
          MA(0) = MIN(MACCA,MACCB,MD2B)
      ELSE
          MA(0) = MIN(MACCA,MACCB)
      ENDIF
      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMDIV2_R1

      SUBROUTINE FMDIV_R2(MA,MB)

!  MB = MA / MB

!  This routine performs the trace printing for division.
!  FMDIV2_R2 is used to do the arithmetic.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMDIV '
          CALL FMNTR(2,MA,MB,2,1)

          CALL FMDIV2_R2(MA,MB)

          CALL FMNTR(1,MB,MB,1,1)
      ELSE
          CALL FMDIV2_R2(MA,MB)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMDIV_R2

      SUBROUTINE FMDIV2_R2(MA,MB)

!  Internal division routine.  MB = MA / MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MLR,MR,MS,MT1,MT2
      INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KT3,L,N1,NG,NGUARD,NL

      IF (MBLOGS /= MBASE) CALL FMCONS
      JRSSAV = JRSIGN
      MACCA = MA(0)
      MACCB = MB(0)
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR.  &
          KDEBUG == 1) THEN
          CALL FMARGS('FMDIV ',2,MA,MB,KRESLT)
          IF (KRESLT /= 0) THEN
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'FMDIV '
              CALL FMRSLT(MA,MB,M07,KRESLT)
              CALL FMEQ(M07,MB)
              JRSIGN = JRSSAV
              NCALL = NCALL - 1
              RETURN
          ENDIF
      ELSE
          IF (MB(2) == 0) THEN
              NAMEST(NCALL) = 'FMDIV '
              CALL FMIM(0,MB)
              KFLAG = -4
              CALL FMWARN
              MB(1) = MUNKNO
              MB(2) = 1
              MB(0) = NINT(NDIG*ALOGM2)
              JRSIGN = JRSSAV
              RETURN
          ENDIF
          IF (MA(2) == 0) THEN
              CALL FMIM(0,MB)
              MB(0) = MIN(MACCA,MACCB)
              JRSIGN = JRSSAV
              RETURN
          ENDIF
      ENDIF
      KFLAG = 0

!             NGUARD is the number of guard digits used.

      IF (NCALL > 1) THEN
          NGUARD = NGRD21
          IF (NGUARD > NDIG) NGUARD = NDIG
      ELSE
          NGUARD = NGRD52 - 1
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 10
          ENDIF
      ENDIF
      N1 = NDIG + 1
      NG = NDIG + NGUARD

!             Save the sign of MA and MB and then work only with
!             positive numbers.

      MAS = MA(-1)
      MBS = MB(-1)
      IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      MWA(1) = MA(1) - MB(1) + 1

      IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
          IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN
              MBASEL = MBASE
              NDIGL = NDIG
              NGUARL = NGUARD
              DO J = 2, 1000
                 MR = MBASE*MBASEL
                 IF (4*MR > MXBASE) THEN
                     N21 = J - 1
                     NDIG = (NDIGL-1)/N21 + 1
                     IF (NDIG < 2) NDIG = 2
                     NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG
                     IF (NGRDN < 1) NGRDN = 1
                     EXIT
                 ENDIF
                 MBASE = MR
              ENDDO
              MBASEN = MBASE
              NDIGN = NDIG
          ELSE
              MBASE = MBASEN
              NDIG = NDIGN
          ENDIF
          MPMA(1) = 0
          MPMB(1) = 0
          L = 2 - N21
          DO J = 2, NDIGL+2-N21, N21
             MT1 = MA(J)
             MT2 = MB(J)
             DO K = J+1, J+N21-1
                MT1 = MT1*MBASEL + MA(K)
                MT2 = MT2*MBASEL + MB(K)
             ENDDO
             MPMA(2+J/N21) = MT1
             MPMB(2+J/N21) = MT2
             L = J
          ENDDO
          DO J = 3+L/N21, NDIG+NGRDN+2
             MPMA(J) = 0
             MPMB(J) = 0
          ENDDO
          IF (L+N21 <= NDIGL+1) THEN
              MT1 = 0
              MT2 = 0
              DO J = L+N21, L+2*N21-1
                 IF (J <= NDIGL+1) THEN
                     MT1 = MT1*MBASEL + MA(J)
                     MT2 = MT2*MBASEL + MB(J)
                 ELSE
                     MT1 = MT1*MBASEL
                     MT2 = MT2*MBASEL
                 ENDIF
              ENDDO
              MPMA(2+(L+N21)/N21) = MT1
              MPMB(2+(L+N21)/N21) = MT2
          ENDIF
          NG = NDIG + NGRDN + 1
          IF (MPMA(2) >= MPMB(2)) NG = NG + 1

!             Copy MA into the working array.

          DO J = 2, NDIG+1
             MWA(J+1) = MPMA(J)
          ENDDO
          MWA(2) = 0
          DO J = NDIG+3, NG+4
             MWA(J) = 0
          ENDDO
          CALL FMDIV3(MPMB,NG)
          KT3 = N21 - 1
          IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN
              DO J = 2+NDIG+NGRDN, 3, -1
                 KT1 = MWA(J)
                 KT = 2 + (J-2)*N21
                 KT2 = N21 + KT - 1
                 DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3)
                    MWA(K-KT3) = IBITS(KT1,KT2-K,1)
                 ENDDO
              ENDDO
          ELSE
              MS = MBASEL**(N21-1)
              DO J = 2+NDIG+NGRDN, 3, -1
                 MR = MS
                 MT1 = MWA(J)
                 DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3)
                    MWA(K-KT3) = AINT (MT1/MR)
                    MT1 = MT1 - MWA(K-KT3)*MR
                    MR = AINT (MR/MBASEL)
                 ENDDO
              ENDDO
          ENDIF
          NDIG = NDIGL
          MBASE = MBASEL
      ELSE

!             Copy MA into the working array.

          DO J = 2, N1
             MWA(J+1) = MA(J)
          ENDDO
          MWA(2) = 0
          NL = N1 + NGUARD + 3
          DO J = NDIG+3, NL
             MWA(J) = 0
          ENDDO
          CALL FMDIV3(MB,NG)
      ENDIF

!             Round, affix the sign, and return.

      IF (MWA(2) == 0) THEN
          MLR = 2*MWA(NDIG+3) + 1
          IF (KROUND == -1 .OR. KROUND == 2) THEN
              CALL FMRND(MWA,NDIG,NGUARD,1)
          ELSE IF (MLR >= MBASE) THEN
              IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN
                  IF (KROUND /= 0 .OR. NCALL > 1) THEN
                      MWA(N1+1) = MWA(N1+1) + 1
                      MWA(N1+2) = 0
                  ENDIF
              ELSE
                  CALL FMRND(MWA,NDIG,NGUARD,1)
              ENDIF
          ENDIF
      ELSE
          MLR = 2*MWA(NDIG+2) + 1
          IF (KROUND == -1 .OR. KROUND == 2) THEN
              CALL FMRND(MWA,NDIG,NGUARD,0)
          ELSE IF (MLR >= MBASE) THEN
              IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
                  IF (KROUND /= 0 .OR. NCALL > 1) THEN
                      MWA(N1) = MWA(N1) + 1
                      MWA(N1+1) = 0
                  ENDIF
              ELSE
                  CALL FMRND(MWA,NDIG,NGUARD,0)
              ENDIF
          ENDIF
      ENDIF
      CALL FMMOVE(MWA,MB)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'FMDIV '
          CALL FMWARN
      ENDIF

      MB(-1) = 1
      IF (MAS*MBS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1

      IF (KACCSW == 1) THEN
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
          MB(0) = MIN(MACCA,MACCB,MD2B)
      ELSE
          MB(0) = MIN(MACCA,MACCB)
      ENDIF
      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMDIV2_R2

      SUBROUTINE FMDIV3(MB,NG)

!  Internal division routine.  Divide MA/MB and return the
!  quotient in MWA.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MB(-1:LUNPCK)

      DOUBLE PRECISION XB,XBR,XBASE,XMWA
      REAL (KIND(1.0D0)) :: MAXMWA,MBM1,MCARRY,MKT,MLMAX,MQD
      INTEGER J,JB,JL,KA,KB,KL,KPTMWA,N1,NG,NL,NMBWDS,NZDMB
      N1 = NDIG + 1
      NL = NG + 4

!             NMBWDS is the number of words of MB used to
!             compute the estimated quotient digit MQD.

      NMBWDS = 4
      IF (MBASE < 100) NMBWDS = 7

!             XB is an approximation of MB used in
!             estimating the quotient digits.

      XBASE = DBLE(MBASE)
      XB = 0
      JL = NMBWDS
      IF (JL <= N1) THEN
          DO J = 2, JL
             XB = XB*XBASE + DBLE(MB(J))
          ENDDO
      ELSE
          DO J = 2, JL
             IF (J <= N1) THEN
                 XB = XB*XBASE + DBLE(MB(J))
             ELSE
                 XB = XB*XBASE
             ENDIF
          ENDDO
      ENDIF
      IF (JL+1 <= N1) THEN
          XB = XB + DBLE(MB(JL+1))/XBASE
      ENDIF
      XBR = 1.0D0/XB

!             MLMAX determines when to normalize all of MWA.

      MBM1 = MBASE - 1
      MLMAX = MAXINT/MBM1
      MKT = INTMAX - MBASE
      MLMAX = MIN(MLMAX,MKT)

!             Count the trailing zero digits of MB.

      DO J = N1, 2, -1
         IF (MB(J) /= 0) THEN
             NZDMB = N1 - J
             GO TO 110
         ENDIF
      ENDDO

!             MAXMWA is an upper bound on the size of values in MWA
!             divided by MBASE-1.  It is used to determine whether
!             normalization can be postponed.

  110 MAXMWA = 0

!             KPTMWA points to the next digit in the quotient.

      KPTMWA = 2

!             This is the start of the division loop.

!             XMWA is an approximation of the active part of MWA
!             used in estimating quotient digits.

  120 KL = KPTMWA + NMBWDS - 1
      IF (KL <= NL) THEN
          XMWA = ((DBLE(MWA(KPTMWA))*XBASE  &
                 + DBLE(MWA(KPTMWA+1)))*XBASE  &
                 + DBLE(MWA(KPTMWA+2)))*XBASE  &
                 + DBLE(MWA(KPTMWA+3))
          DO J = KPTMWA+4, KL
             XMWA = XMWA*XBASE + DBLE(MWA(J))
          ENDDO
      ELSE
          XMWA = DBLE(MWA(KPTMWA))
          DO J = KPTMWA+1, KL
             IF (J <= NL) THEN
                 XMWA = XMWA*XBASE + DBLE(MWA(J))
             ELSE
                 XMWA = XMWA*XBASE
             ENDIF
          ENDDO
      ENDIF

!             MQD is the estimated quotient digit.

      MQD = AINT(XMWA*XBR)
      IF (MQD < 0) MQD = MQD - 1

      IF (MQD > 0) THEN
          MAXMWA = MAXMWA + MQD
      ELSE
          MAXMWA = MAXMWA - MQD
      ENDIF

!             See if MWA must be normalized.

      KA = KPTMWA + 1
      KB = MIN(KA+NDIG-1-NZDMB,NL)
      IF (MAXMWA >= MLMAX) THEN
          DO J = KB, KA, -1
             IF (MWA(J) < 0) THEN
                 MCARRY = INT((-MWA(J)-1)/MBASE) + 1
                 MWA(J) = MWA(J) + MCARRY*MBASE
                 MWA(J-1) = MWA(J-1) - MCARRY
             ELSE IF (MWA(J) >= MBASE) THEN
                 MCARRY = -INT(MWA(J)/MBASE)
                 MWA(J) = MWA(J) + MCARRY*MBASE
                 MWA(J-1) = MWA(J-1) - MCARRY
             ENDIF
          ENDDO
          XMWA = 0
          IF (KL <= NL) THEN
              DO J = KPTMWA, KL
                 XMWA = XMWA*XBASE + DBLE(MWA(J))
              ENDDO
          ELSE
              DO J = KPTMWA, KL
                 IF (J <= NL) THEN
                     XMWA = XMWA*XBASE + DBLE(MWA(J))
                 ELSE
                     XMWA = XMWA*XBASE
                 ENDIF
              ENDDO
          ENDIF
          MQD = AINT(XMWA*XBR)
          IF (MQD < 0) MQD = MQD - 1
          IF (MQD > 0) THEN
              MAXMWA = MQD
          ELSE
              MAXMWA = -MQD
          ENDIF
      ENDIF

!             Subtract MQD*MB from MWA.

      JB = KA - 2
      IF (MQD /= 0) THEN

!             Major (Inner Loop)

          DO J = KA, KB
             MWA(J) = MWA(J) - MQD*MB(J-JB)
          ENDDO
      ENDIF

      MWA(KA) = MWA(KA) + MWA(KA-1)*MBASE
      MWA(KPTMWA) = MQD

      KPTMWA = KPTMWA + 1
      IF (KPTMWA <= NG) GO TO 120
      IF (MWA(2) == 0 .AND. KPTMWA <= NG+1) GO TO 120

      KL = KPTMWA + NMBWDS - 1
      IF (KL <= NL) THEN
          XMWA = ((DBLE(MWA(KPTMWA))*XBASE  &
                 + DBLE(MWA(KPTMWA+1)))*XBASE  &
                 + DBLE(MWA(KPTMWA+2)))*XBASE  &
                 + DBLE(MWA(KPTMWA+3))
          DO J = KPTMWA+4, KL
             XMWA = XMWA*XBASE + DBLE(MWA(J))
          ENDDO
      ELSE
          XMWA = DBLE(MWA(KPTMWA))
          DO J = KPTMWA+1, KL
             IF (J <= NL) THEN
                 XMWA = XMWA*XBASE + DBLE(MWA(J))
             ELSE
                 XMWA = XMWA*XBASE
             ENDIF
          ENDDO
      ENDIF
      MQD = AINT(XMWA*XBR)
      IF (MQD < 0) MQD = MQD - 1
      MWA(KPTMWA) = MQD
      MWA(KPTMWA+1) = 0
      MWA(KPTMWA+2) = 0

!             Final normalization.

      DO J = KPTMWA, 3, -1
         IF (MWA(J) < 0) THEN
             MCARRY = INT((-MWA(J)-1)/MBASE) + 1
             MWA(J) = MWA(J) + MCARRY*MBASE
             MWA(J-1) = MWA(J-1) - MCARRY
         ELSE IF (MWA(J) >= MBASE) THEN
             MCARRY = -INT(MWA(J)/MBASE)
             MWA(J) = MWA(J) + MCARRY*MBASE
             MWA(J-1) = MWA(J-1) - MCARRY
         ENDIF
      ENDDO

      RETURN
      END SUBROUTINE FMDIV3

      SUBROUTINE FMDIVD(MA,MB,MC,MD,ME)

!  Double division routine.  MD = MA / MC,   ME = MB / MC

!  It is usually slightly faster to do two divisions that
!  have a common denominator with one call.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK),  &
                            MD(-1:LUNPCK),ME(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MA2P,MACCA,MACCB,MACCC,MAS,MAXMWA,MB2P,MBS,  &
                            MBM1,MC2P,MCARRY,MCS,MD2B,MKT,MLMAX,MLR,  &
                            MQDMWA,MQDMWD,MTEMP
      DOUBLE PRECISION XB,XBR,XBASE,XMWA,XMWD
      INTEGER J,JB,JL,JRSSAV,KA,KB,KL,KOVUN,KPTMW,N1,NG,NGUARD,NL,  &
              NMBWDS,NZDMB

      NCALL = NCALL + 1
      JRSSAV = JRSIGN
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMDIVD'
          CALL FMNTR(2,MA,MB,2,1)
          IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
              IF (NTRACE < 0) THEN
                  CALL FMNTRJ(MC,NDIG)
              ELSE
                  CALL FMPRNT(MC)
              ENDIF
          ENDIF
      ENDIF

      IF (MBLOGS /= MBASE) CALL FMCONS
      MACCA = MA(0)
      MACCB = MB(0)
      MACCC = MC(0)
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR.  &
          ABS(MC(1)) > MEXPAB .OR. MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN .OR.  &
              MB(1) == MEXPOV .OR. MB(1) == MEXPUN .OR.  &
              MC(1) == MEXPOV .OR. MC(1) == MEXPUN) KOVUN = 1
          IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR.  &
              MC(1) == MUNKNO) KOVUN = 2
          NCALL = NCALL + 1
          CALL FMDIV2(MA,MC,MWD)
          KB = KFLAG
          CALL FMDIV2(MB,MC,ME)
          NCALL = NCALL - 1
          IF (((KFLAG < 0 .OR. KB < 0) .AND. KOVUN == 0) .OR.  &
              ((KFLAG == -4 .OR. KB == -4) .AND. KOVUN == 1)) THEN
              IF (KFLAG == -4 .OR. KB == -4) THEN
                  KFLAG = -4
              ELSE IF (KFLAG == -5 .OR. KB == -5) THEN
                  KFLAG = -5
              ELSE
                  KFLAG = MIN(KFLAG,KB)
              ENDIF
              NAMEST(NCALL) = 'FMDIVD'
              CALL FMWARN
          ENDIF
          CALL FMEQ(MWD,MD)
          GO TO 130
      ENDIF
      IF (MC(2) == 0) THEN
          NAMEST(NCALL) = 'FMDIVD'
          KFLAG = -4
          CALL FMWARN
          CALL FMST2M('UNKNOWN',MD)
          CALL FMST2M('UNKNOWN',ME)
          GO TO 130
      ENDIF
      IF (MA(2) == 0 .OR. MB(2) == 0) THEN
          CALL FMDIV2(MA,MC,MWD)
          CALL FMDIV2(MB,MC,ME)
          CALL FMEQ(MWD,MD)
          GO TO 130
      ENDIF
      KFLAG = 0

!             NGUARD is the number of guard digits used.

      IF (NCALL > 1) THEN
          NGUARD = NGRD21
          IF (NGUARD > NDIG) NGUARD = NDIG
      ELSE
          NGUARD = NGRD52 - 1
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 10
          ENDIF
      ENDIF
      MA2P = ABS(MA(2))
      MB2P = ABS(MB(2))
      MC2P = ABS(MC(2))
      IF ((MC2P >= MA2P .OR. MC2P >= MB2P) .AND. NGUARD < 2) NGUARD = 2
      N1 = NDIG + 1
      NG = NDIG + NGUARD

!             Copy MA and MB into the working arrays.

      DO J = 3, N1
         MWA(J+1) = MA(J)
         MWD(J+1) = MB(J)
      ENDDO
      MWA(1) = MA(1) - MC(1) + 1
      MWD(1) = MB(1) - MC(1) + 1
      MWA(2) = 0
      MWD(2) = 0
      NL = N1 + NGUARD + 3
      DO J = NDIG+3, NL
         MWA(J) = 0
         MWD(J) = 0
      ENDDO

!             Save the signs and then work only with
!             positive numbers.

      MAS = MA(-1)
      MBS = MB(-1)
      MCS = MC(-1)
      MWA(3) = MA(2)
      MWD(3) = MB(2)

!             NMBWDS is the number of words used to compute
!             the estimated quotient digits.

      NMBWDS = 4
      IF (MBASE < 100) NMBWDS = 7

!             XB is an approximation of MC used in selecting
!             estimated quotients.

      XBASE = DBLE(MBASE)
      XB = 0
      JL = NMBWDS
      IF (JL <= N1) THEN
          DO J = 2, JL
             XB = XB*XBASE + DBLE(MC(J))
          ENDDO
      ELSE
          DO J = 2, JL
             IF (J <= N1) THEN
                 XB = XB*XBASE + DBLE(MC(J))
             ELSE
                 XB = XB*XBASE
             ENDIF
          ENDDO
      ENDIF
      IF (JL+1 <= N1) XB = XB + DBLE(MC(JL+1))/XBASE
      XBR = 1.0D0/XB

!             MLMAX determines when to normalize all of MWA.

      MBM1 = MBASE - 1
      MLMAX = MAXINT/MBM1
      MKT = INTMAX - MBASE
      MLMAX = MIN(MLMAX,MKT)

!             Count the trailing zero digits of MC.

      DO J = N1, 2, -1
         IF (MC(J) /= 0) THEN
             NZDMB = N1 - J
             GO TO 110
         ENDIF
      ENDDO

!             MAXMWA is an upper bound on the size of values in MWA
!             divided by MBASE-1.  It is used to determine whether
!             normalization can be postponed.

  110 MAXMWA = 0

!             KPTMW points to the next digit in the quotient.

      KPTMW = 2

!             This is the start of the division loop.

!             XMWA is an approximation of the active part of MWA
!             used in selecting estimated quotients.

  120 KL = KPTMW + NMBWDS - 1
      IF (KL <= NL) THEN
          XMWA = ((DBLE(MWA(KPTMW))*XBASE  &
                 + DBLE(MWA(KPTMW+1)))*XBASE  &
                 + DBLE(MWA(KPTMW+2)))*XBASE  &
                 + DBLE(MWA(KPTMW+3))
          XMWD = ((DBLE(MWD(KPTMW))*XBASE  &
                 + DBLE(MWD(KPTMW+1)))*XBASE  &
                 + DBLE(MWD(KPTMW+2)))*XBASE  &
                 + DBLE(MWD(KPTMW+3))
          DO J = KPTMW+4, KL
             XMWA = XMWA*XBASE + DBLE(MWA(J))
             XMWD = XMWD*XBASE + DBLE(MWD(J))
          ENDDO
      ELSE
          XMWA = DBLE(MWA(KPTMW))
          XMWD = DBLE(MWD(KPTMW))
          DO J = KPTMW+1, KL
             IF (J <= NL) THEN
                 XMWA = XMWA*XBASE + DBLE(MWA(J))
                 XMWD = XMWD*XBASE + DBLE(MWD(J))
             ELSE
                 XMWA = XMWA*XBASE
                 XMWD = XMWD*XBASE
             ENDIF
          ENDDO
      ENDIF

!             MQDMWA and MQDMWD are the estimated quotient digits.

      MQDMWA = AINT(XMWA*XBR)
      IF (MQDMWA < 0) MQDMWA = MQDMWA - 1
      MQDMWD = AINT(XMWD*XBR)
      IF (MQDMWD < 0) MQDMWD = MQDMWD - 1

      MAXMWA = MAXMWA + MAX(ABS(MQDMWA),ABS(MQDMWD))

!             See if MWA and MWD must be normalized.

      KA = KPTMW + 1
      KB = MIN(KA+NDIG-1-NZDMB,NL)
      IF (MAXMWA >= MLMAX) THEN
          DO J = KB, KA, -1
             IF (MWA(J) < 0) THEN
                 MCARRY = INT((-MWA(J)-1)/MBASE) + 1
                 MWA(J) = MWA(J) + MCARRY*MBASE
                 MWA(J-1) = MWA(J-1) - MCARRY
             ELSE IF (MWA(J) >= MBASE) THEN
                 MCARRY = -INT(MWA(J)/MBASE)
                 MWA(J) = MWA(J) + MCARRY*MBASE
                 MWA(J-1) = MWA(J-1) - MCARRY
             ENDIF
             IF (MWD(J) < 0) THEN
                 MCARRY = INT((-MWD(J)-1)/MBASE) + 1
                 MWD(J) = MWD(J) + MCARRY*MBASE
                 MWD(J-1) = MWD(J-1) - MCARRY
             ELSE IF (MWD(J) >= MBASE) THEN
                 MCARRY = -INT(MWD(J)/MBASE)
                 MWD(J) = MWD(J) + MCARRY*MBASE
                 MWD(J-1) = MWD(J-1) - MCARRY
             ENDIF
          ENDDO
          XMWA = 0
          XMWD = 0
          IF (KL <= NL) THEN
              DO J = KPTMW, KL
                 XMWA = XMWA*XBASE + DBLE(MWA(J))
                 XMWD = XMWD*XBASE + DBLE(MWD(J))
              ENDDO
          ELSE
              DO J = KPTMW, KL
                 IF (J <= NL) THEN
                     XMWA = XMWA*XBASE + DBLE(MWA(J))
                     XMWD = XMWD*XBASE + DBLE(MWD(J))
                 ELSE
                     XMWA = XMWA*XBASE
                     XMWD = XMWD*XBASE
                 ENDIF
              ENDDO
          ENDIF
          MQDMWA = AINT(XMWA*XBR)
          IF (MQDMWA < 0) MQDMWA = MQDMWA - 1
          MQDMWD = AINT(XMWD*XBR)
          IF (MQDMWD < 0) MQDMWD = MQDMWD - 1
          MAXMWA = MAX(ABS(MQDMWA),ABS(MQDMWD))
      ENDIF

!             Subtract MQDMWA*MC from MWA and MQDMWD*MC from MWD.

      JB = KA - 2

!             Major (Inner Loop)

      DO J = KA, KB
         MTEMP = MC(J-JB)
         MWA(J) = MWA(J) - MQDMWA*MTEMP
         MWD(J) = MWD(J) - MQDMWD*MTEMP
      ENDDO

      MWA(KA) = MWA(KA) + MWA(KA-1)*MBASE
      MWD(KA) = MWD(KA) + MWD(KA-1)*MBASE
      MWA(KPTMW) = MQDMWA
      MWD(KPTMW) = MQDMWD

      KPTMW = KPTMW + 1
      IF (KPTMW <= NG) GO TO 120

      KL = KPTMW + NMBWDS - 1
      IF (KL <= NL) THEN
          XMWA = ((DBLE(MWA(KPTMW))*XBASE  &
                 + DBLE(MWA(KPTMW+1)))*XBASE  &
                 + DBLE(MWA(KPTMW+2)))*XBASE  &
                 + DBLE(MWA(KPTMW+3))
          XMWD = ((DBLE(MWD(KPTMW))*XBASE  &
                 + DBLE(MWD(KPTMW+1)))*XBASE  &
                 + DBLE(MWD(KPTMW+2)))*XBASE  &
                 + DBLE(MWD(KPTMW+3))
          DO J = KPTMW+4, KL
             XMWA = XMWA*XBASE + DBLE(MWA(J))
             XMWD = XMWD*XBASE + DBLE(MWD(J))
          ENDDO
      ELSE
          XMWA = DBLE(MWA(KPTMW))
          XMWD = DBLE(MWD(KPTMW))
          DO J = KPTMW+1, KL
             IF (J <= NL) THEN
                 XMWA = XMWA*XBASE + DBLE(MWA(J))
                 XMWD = XMWD*XBASE + DBLE(MWD(J))
             ELSE
                 XMWA = XMWA*XBASE
                 XMWD = XMWD*XBASE
             ENDIF
          ENDDO
      ENDIF
      MQDMWA = AINT(XMWA*XBR)
      IF (MQDMWA < 0) MQDMWA = MQDMWA - 1
      MQDMWD = AINT(XMWD*XBR)
      IF (MQDMWD < 0) MQDMWD = MQDMWD - 1
      MWA(KPTMW) = MQDMWA
      MWA(KPTMW+1) = 0
      MWA(KPTMW+2) = 0
      MWD(KPTMW) = MQDMWD
      MWD(KPTMW+1) = 0
      MWD(KPTMW+2) = 0

!             Final normalization.

      DO J = KPTMW-1, 3, -1
         IF (MWA(J) < 0) THEN
             MCARRY = INT((-MWA(J)-1)/MBASE) + 1
             MWA(J) = MWA(J) + MCARRY*MBASE
             MWA(J-1) = MWA(J-1) - MCARRY
         ELSE IF (MWA(J) >= MBASE) THEN
             MCARRY = -INT(MWA(J)/MBASE)
             MWA(J) = MWA(J) + MCARRY*MBASE
             MWA(J-1) = MWA(J-1) - MCARRY
         ENDIF
         IF (MWD(J) < 0) THEN
             MCARRY = INT((-MWD(J)-1)/MBASE) + 1
             MWD(J) = MWD(J) + MCARRY*MBASE
             MWD(J-1) = MWD(J-1) - MCARRY
         ELSE IF (MWD(J) >= MBASE) THEN
             MCARRY = -INT(MWD(J)/MBASE)
             MWD(J) = MWD(J) + MCARRY*MBASE
             MWD(J-1) = MWD(J-1) - MCARRY
         ENDIF
      ENDDO

!             Round, affix the sign, and return.

      IF ((MAS > 0 .AND. MCS > 0) .OR. (MAS < 0 .AND. MCS < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      IF (MWA(2) == 0) THEN
          MLR = 2*MWA(NDIG+3) + 1
          IF (KROUND == -1 .OR. KROUND == 2) THEN
              CALL FMRND(MWA,NDIG,NGUARD,1)
          ELSE IF (MLR >= MBASE) THEN
              IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN
                  IF (KROUND /= 0 .OR. NCALL > 1) THEN
                      MWA(N1+1) = MWA(N1+1) + 1
                      MWA(N1+2) = 0
                  ENDIF
              ELSE
                  CALL FMRND(MWA,NDIG,NGUARD,1)
              ENDIF
          ENDIF
      ELSE
          MLR = 2*MWA(NDIG+2) + 1
          IF (KROUND == -1 .OR. KROUND == 2) THEN
              CALL FMRND(MWA,NDIG,NGUARD,0)
          ELSE IF (MLR >= MBASE) THEN
              IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
                  IF (KROUND /= 0 .OR. NCALL > 1) THEN
                      MWA(N1) = MWA(N1) + 1
                      MWA(N1+1) = 0
                  ENDIF
              ELSE
                  CALL FMRND(MWA,NDIG,NGUARD,0)
              ENDIF
          ENDIF
      ENDIF
      CALL FMMOVE(MWA,MD)

      IF ((MBS > 0 .AND. MCS > 0) .OR. (MBS < 0 .AND. MCS < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      IF (MWD(2) == 0) THEN
          MLR = 2*MWD(NDIG+3) + 1
          IF (KROUND == -1 .OR. KROUND == 2) THEN
              CALL FMRND(MWD,NDIG,NGUARD,1)
          ELSE IF (MLR >= MBASE) THEN
              IF (MLR-1 > MBASE .AND. MWD(N1+1) < MBASE-1) THEN
                  IF (KROUND /= 0 .OR. NCALL > 1) THEN
                      MWD(N1+1) = MWD(N1+1) + 1
                      MWD(N1+2) = 0
                  ENDIF
              ELSE
                  CALL FMRND(MWD,NDIG,NGUARD,1)
              ENDIF
          ENDIF
      ELSE
          MLR = 2*MWD(NDIG+2) + 1
          IF (KROUND == -1 .OR. KROUND == 2) THEN
              CALL FMRND(MWD,NDIG,NGUARD,0)
          ELSE IF (MLR >= MBASE) THEN
              IF (MLR-1 > MBASE .AND. MWD(N1) < MBASE-1) THEN
                  IF (KROUND /= 0 .OR. NCALL > 1) THEN
                      MWD(N1) = MWD(N1) + 1
                      MWD(N1+1) = 0
                  ENDIF
              ELSE
                  CALL FMRND(MWD,NDIG,NGUARD,0)
              ENDIF
          ENDIF
      ENDIF
      CALL FMMOVE(MWD,ME)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'FMDIVD'
          CALL FMWARN
      ENDIF

      MD(-1) = 1
      IF (MAS*MCS < 0 .AND. MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -1
      ME(-1) = 1
      IF (MBS*MCS < 0 .AND. ME(1) /= MUNKNO .AND. ME(2) /= 0) ME(-1) = -1

      IF (KACCSW == 1) THEN
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MD(2))+1))/0.69315)
          MD(0) = MIN(MACCA,MACCC,MD2B)
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(ME(2))+1))/0.69315)
          ME(0) = MIN(MACCB,MACCC,MD2B)
      ELSE
          MD(0) = MIN(MACCA,MACCC)
          ME(0) = MIN(MACCB,MACCC)
      ENDIF

  130 IF (NTRACE /= 0) THEN
          CALL FMNTR(1,MD,MD,1,1)
          IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN
              IF (NTRACE < 0) THEN
                  CALL FMNTRJ(ME,NDIG)
              ELSE
                  CALL FMPRNT(ME)
              ENDIF
          ENDIF
      ENDIF
      NCALL = NCALL - 1
      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMDIVD

      SUBROUTINE FMDIVI(MA,IVAL,MB)

!  MB = MA / IVAL

!  Divide FM number MA by one word integer IVAL.

!  This routine is faster than FMDIV when the divisor is less than
!  MXBASE (the square root of the largest integer).
!  When IVAL is not less than MXBASE, FMDIV2 is used.  In this case,
!  if IVAL is known to be a product of two integers less than
!  MXBASE, it is usually faster to make two calls to FMDIVI with
!  half-word factors than one call with their product.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER IVAL
      REAL (KIND(1.0D0)) :: MACCA,MD2B

      KFLAG = 0
      MACCA = MA(0)
      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMDIVI'
          CALL FMNTR(2,MA,MA,1,1)
          CALL FMNTRI(2,IVAL,0)
          CALL FMDIVN(MA,IVAL,MB)
          IF (KACCSW == 1) THEN
              MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/  &
                     0.69315)
              MB(0) = MIN(MACCA,MD2B)
          ELSE
              MB(0) = MACCA
          ENDIF
          CALL FMNTR(1,MB,MB,1,1)
      ELSE
          CALL FMDIVN(MA,IVAL,MB)
          IF (KACCSW == 1) THEN
              MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/  &
                     0.69315)
              MB(0) = MIN(MACCA,MD2B)
          ELSE
              MB(0) = MACCA
          ENDIF
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMDIVI

      SUBROUTINE FMDIVN(MA,IVAL,MB)

!  Internal divide by integer routine.  MB = MA / IVAL

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER IVAL
      REAL (KIND(1.0D0)) :: MA1,MAS,MKT,MLR,MODINT,MVALP
      INTEGER J,JRSSAV,KA,KB,KL,KPT,KPTWA,N1,NGUARD,NMVAL,NV2

!             Check for special cases.

      IF (MBLOGS /= MBASE) CALL FMCONS
      JRSSAV = JRSIGN
      N1 = NDIG + 1
      IF (MA(1) == MUNKNO .OR. IVAL == 0) THEN
          MA1 = MA(1)
          CALL FMIM(0,MB)
          MB(0) = NINT(NDG2MX*ALOGM2)
          MB(1) = MUNKNO
          MB(2) = 1
          KFLAG = -4
          IF (MA1 /= MUNKNO) THEN
              NAMEST(NCALL) = 'FMDIVI'
              CALL FMWARN
          ENDIF
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (MA(2) == 0) THEN
          CALL FMEQ(MA,MB)
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (ABS(MA(1)) < MEXPOV .AND. ABS(IVAL) > 1) GO TO 110

      IF (ABS(IVAL) == 1) THEN
          DO J = 0, N1
             MB(J) = MA(J)
          ENDDO
          MB(-1) = MA(-1)*IVAL
          IF (MA(1) == MEXPOV) KFLAG = -5
          IF (MA(1) == MEXPUN) KFLAG = -6
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (MA(1) == MEXPUN) THEN
          MAS = MA(-1)
          CALL FMIM(0,MB)
          MB(1) = MEXPUN
          MB(2) = 1
          MB(0) = NINT(NDIG*ALOGM2)
          IF ((MAS < 0 .AND. IVAL > 0) .OR.  &
              (MAS > 0 .AND. IVAL < 0))      MB(-1) = -1
          KFLAG = -6
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (MA(1) == MEXPOV) THEN
          NAMEST(NCALL) = 'FMDIVI'
          CALL FMIM(0,MB)
          MB(1) = MUNKNO
          MB(2) = 1
          MB(0) = NINT(NDIG*ALOGM2)
          KFLAG = -4
          CALL FMWARN
          JRSIGN = JRSSAV
          RETURN
      ENDIF

!             NGUARD is the number of guard digits used.

  110 IF (NCALL > 1) THEN
          NGUARD = NGRD21
      ELSE
          NGUARD = NGRD52
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 10
          ENDIF
      ENDIF

!             If ABS(IVAL) >= MXBASE use FMDIV.

      MVALP = ABS(IVAL)
      NMVAL = INT(MVALP)
      NV2 = NMVAL - 1
      IF (ABS(IVAL) > MXBASE .OR. NMVAL /= ABS(IVAL) .OR.  &
          NV2 /= ABS(IVAL)-1) THEN
          CALL FMIM(IVAL,M01)
          CALL FMDIV2(MA,M01,MB)
          JRSIGN = JRSSAV
          RETURN
      ENDIF

!             Work with positive numbers.

      MAS = MA(-1)

!             Find the first significant digit of the quotient.

      MKT = MA(2)
      IF (MKT >= MVALP) THEN
          KPT = 2
          GO TO 130
      ENDIF
      DO J = 3, N1
         MKT = MKT*MBASE + MA(J)
         IF (MKT >= MVALP) THEN
             KPT = J
             GO TO 130
         ENDIF
      ENDDO
      KPT = N1

  120 KPT = KPT + 1
      MKT = MKT*MBASE
      IF (MKT < MVALP) GO TO 120

!             Do the rest of the division.

  130 KA = KPT + 1
      MWA(1) = MA(1) + 2 - KPT
      MWA(2) = INT (MKT/MVALP)
      MODINT = MKT - MWA(2)*MVALP
      KPTWA = 2
      IF (KA <= N1) THEN
          KL = 3 - KA

!             (Inner Loop)

          DO J = KA, N1
             MKT = MODINT*MBASE + MA(J)
             MWA(KL+J) = INT (MKT/MVALP)
             MODINT = MKT - MWA(KL+J)*MVALP
          ENDDO
          KPTWA = KL + N1
      ENDIF

      KA = KPTWA + 1
      KB = N1 + NGUARD
      DO J = KA, KB
         MKT = MODINT*MBASE
         MWA(J) = INT (MKT/MVALP)
         MODINT = MKT - MWA(J)*MVALP
      ENDDO

!             Round the result, put the sign on MB and return.

      MLR = 2*MWA(NDIG+2) + 1
      IF ((MAS > 0 .AND. IVAL > 0) .OR. (MAS < 0 .AND. IVAL < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      IF (KROUND == -1 .OR. KROUND == 2) THEN
          CALL FMRND(MWA,NDIG,NGUARD,0)
      ELSE IF (MLR >= MBASE) THEN
          IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
              IF (KROUND /= 0 .OR. NCALL > 1) THEN
                  MWA(N1) = MWA(N1) + 1
                  MWA(N1+1) = 0
              ENDIF
          ELSE
              CALL FMRND(MWA,NDIG,NGUARD,0)
          ENDIF
      ENDIF
      CALL FMMOVE(MWA,MB)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'FMDIVI'
          CALL FMWARN
      ENDIF
      MB(-1) = JRSIGN
      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMDIVN

      SUBROUTINE FMDIVI_R1(MA,IVAL)

!  MA = MA / IVAL

!  Divide FM number MA by one word integer IVAL.

!  This routine is faster than FMDIV when the divisor is less than
!  MXBASE (the square root of the largest integer).
!  When IVAL is not less than MXBASE, FMDIV2 is used.  In this case,
!  if IVAL is known to be a product of two integers less than
!  MXBASE, it is usually faster to make two calls to FMDIVI with
!  half-word factors than one call with their product.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER IVAL
      REAL (KIND(1.0D0)) :: MACCA,MD2B

      KFLAG = 0
      MACCA = MA(0)
      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMDIVI'
          CALL FMNTR(2,MA,MA,1,1)
          CALL FMNTRI(2,IVAL,0)
          CALL FMDIVN_R1(MA,IVAL)
          IF (KACCSW == 1) THEN
              MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/  &
                     0.69315)
              MA(0) = MIN(MACCA,MD2B)
          ELSE
              MA(0) = MACCA
          ENDIF
          CALL FMNTR(1,MA,MA,1,1)
      ELSE
          CALL FMDIVN_R1(MA,IVAL)
          IF (KACCSW == 1) THEN
              MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/  &
                     0.69315)
              MA(0) = MIN(MACCA,MD2B)
          ELSE
              MA(0) = MACCA
          ENDIF
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMDIVI_R1

      SUBROUTINE FMDIVN_R1(MA,IVAL)

!  Internal divide by integer routine.  MA = MA / IVAL

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER IVAL
      REAL (KIND(1.0D0)) :: MA1,MAS,MKT,MLR,MODINT,MVALP
      INTEGER J,JRSSAV,KA,KB,KL,KPT,KPTWA,N1,NGUARD,NMVAL,NV2

!             Check for special cases.

      IF (MBLOGS /= MBASE) CALL FMCONS
      JRSSAV = JRSIGN
      N1 = NDIG + 1
      IF (MA(1) == MUNKNO .OR. IVAL == 0) THEN
          MA1 = MA(1)
          CALL FMIM(0,MA)
          MA(0) = NINT(NDG2MX*ALOGM2)
          MA(1) = MUNKNO
          MA(2) = 1
          KFLAG = -4
          IF (MA1 /= MUNKNO) THEN
              NAMEST(NCALL) = 'FMDIVI'
              CALL FMWARN
          ENDIF
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (MA(2) == 0) THEN
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (ABS(MA(1)) < MEXPOV .AND. ABS(IVAL) > 1) GO TO 110

      IF (ABS(IVAL) == 1) THEN
          MA(-1) = MA(-1)*IVAL
          IF (MA(1) == MEXPOV) KFLAG = -5
          IF (MA(1) == MEXPUN) KFLAG = -6
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (MA(1) == MEXPUN) THEN
          MAS = MA(-1)
          CALL FMIM(0,MA)
          MA(1) = MEXPUN
          MA(2) = 1
          MA(0) = NINT(NDIG*ALOGM2)
          IF ((MAS < 0 .AND. IVAL > 0) .OR.  &
              (MAS > 0 .AND. IVAL < 0))      MA(-1) = -1
          KFLAG = -6
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (MA(1) == MEXPOV) THEN
          NAMEST(NCALL) = 'FMDIVI'
          CALL FMIM(0,MA)
          MA(1) = MUNKNO
          MA(2) = 1
          MA(0) = NINT(NDIG*ALOGM2)
          KFLAG = -4
          CALL FMWARN
          JRSIGN = JRSSAV
          RETURN
      ENDIF

!             NGUARD is the number of guard digits used.

  110 IF (NCALL > 1) THEN
          NGUARD = NGRD21
      ELSE
          NGUARD = NGRD52
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 10
          ENDIF
      ENDIF

!             If ABS(IVAL) >= MXBASE use FMDIV.

      MVALP = ABS(IVAL)
      NMVAL = INT(MVALP)
      NV2 = NMVAL - 1
      IF (ABS(IVAL) > MXBASE .OR. NMVAL /= ABS(IVAL) .OR.  &
          NV2 /= ABS(IVAL)-1) THEN
          CALL FMIM(IVAL,M01)
          CALL FMDIV2_R1(MA,M01)
          JRSIGN = JRSSAV
          RETURN
      ENDIF

!             Work with positive numbers.

      MAS = MA(-1)

!             Find the first significant digit of the quotient.

      MKT = MA(2)
      IF (MKT >= MVALP) THEN
          KPT = 2
          GO TO 130
      ENDIF
      DO J = 3, N1
         MKT = MKT*MBASE + MA(J)
         IF (MKT >= MVALP) THEN
             KPT = J
             GO TO 130
         ENDIF
      ENDDO
      KPT = N1

  120 KPT = KPT + 1
      MKT = MKT*MBASE
      IF (MKT < MVALP) GO TO 120

!             Do the rest of the division.

  130 KA = KPT + 1
      MWA(1) = MA(1) + 2 - KPT
      MWA(2) = INT (MKT/MVALP)
      MODINT = MKT - MWA(2)*MVALP
      KPTWA = 2
      IF (KA <= N1) THEN
          KL = 3 - KA

!             (Inner Loop)

          DO J = KA, N1
             MKT = MODINT*MBASE + MA(J)
             MWA(KL+J) = INT (MKT/MVALP)
             MODINT = MKT - MWA(KL+J)*MVALP
          ENDDO
          KPTWA = KL + N1
      ENDIF

      KA = KPTWA + 1
      KB = N1 + NGUARD
      DO J = KA, KB
         MKT = MODINT*MBASE
         MWA(J) = INT (MKT/MVALP)
         MODINT = MKT - MWA(J)*MVALP
      ENDDO

!             Round the result, put the sign on MA and return.

      MLR = 2*MWA(NDIG+2) + 1
      IF ((MAS > 0 .AND. IVAL > 0) .OR. (MAS < 0 .AND. IVAL < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      IF (KROUND == -1 .OR. KROUND == 2) THEN
          CALL FMRND(MWA,NDIG,NGUARD,0)
      ELSE IF (MLR >= MBASE) THEN
          IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
              IF (KROUND /= 0 .OR. NCALL > 1) THEN
                  MWA(N1) = MWA(N1) + 1
                  MWA(N1+1) = 0
              ENDIF
          ELSE
              CALL FMRND(MWA,NDIG,NGUARD,0)
          ENDIF
      ENDIF
      CALL FMMOVE(MWA,MA)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'FMDIVI'
          CALL FMWARN
      ENDIF
      MA(-1) = JRSIGN
      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMDIVN_R1

      SUBROUTINE FMDM(X,MA)

!  Internal routine for converting double precision to multiple
!  precision.  Called by FMDPM.

      USE FMVALS
      IMPLICIT NONE

      DOUBLE PRECISION X
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      DOUBLE PRECISION ONE,XBASE,Y,Y2,YT
      REAL (KIND(1.0D0)) :: MK,MN
      INTEGER J,K,N1,NE

      IF (MBLOGS /= MBASE) CALL FMCONS
      KFLAG = 0
      N1 = NDIG + 1

      ONE = 1.0D0
      XBASE = MBASE
      K = 0

!             NE-1 is the number of words at the current precision and
!             base roughly equal to machine precision.

      NE = INT(DLOGEB) + 3
      Y = X
      IF (X < 0.0) Y = -X

      IF (X == 0.0) THEN
          DO J = 1, N1
             MA(J) = 0
          ENDDO
          GO TO 160
      ENDIF

!             Get the exponent.

      IF (Y > ONE) THEN
          IF (Y/XBASE < Y) THEN
  110         K = K + 1
              Y = Y/XBASE
              IF (Y > ONE) GO TO 110
              IF (Y < ONE) THEN
                  MA(1) = K
                  GO TO 140
              ENDIF
              GO TO 130
          ELSE
              KFLAG = -4
              CALL FMWARN
              DO J = 1, N1
                 MA(J) = 0
              ENDDO
              MA(1) = MUNKNO
              MA(2) = 1
              MA(-1) = 1
              MA(0) = NINT(NDIG*ALOGM2)
              RETURN
          ENDIF
      ENDIF

      IF (Y < ONE) THEN
          IF (Y*XBASE > Y) THEN
  120         K = K - 1
              Y = Y*XBASE
              IF (Y < ONE) GO TO 120
              IF (Y > ONE) THEN
                  K = K + 1
                  Y = Y/XBASE
                  MA(1) = K
                  GO TO 140
              ENDIF
          ELSE
              KFLAG = -4
              CALL FMWARN
              DO J = 1, N1
                 MA(J) = 0
              ENDDO
              MA(1) = MUNKNO
              MA(2) = 1
              MA(-1) = 1
              MA(0) = NINT(NDIG*ALOGM2)
              RETURN
          ENDIF
      ENDIF

  130 MA(1) = K + 1
      MA(2) = 1
      DO J = 3, N1
         MA(J) = 0
      ENDDO
      GO TO 160

!             Build the rest of the number.

  140 DO J = 2, NE
         Y = Y*XBASE
         MK = AINT(Y)
         YT = -MK
         CALL FMDBL(Y,YT,Y2)
         Y = Y2
         MA(J) = MK
         IF (J >= N1) GO TO 150
      ENDDO
      K = NE + 1
      DO J = K, N1
         MA(J) = 0
      ENDDO

!             Normalize.

  150 IF (ABS(MA(2)) >= MBASE) THEN
          K = N1 + 1
          DO J = 3, N1
             K = K - 1
             MA(K) = MA(K-1)
          ENDDO
          MN = AINT (MA(2)/MBASE)
          MA(3) = MA(2) - MN*MBASE
          MA(2) = MN
          MA(1) = MA(1) + 1
          GO TO 160
      ENDIF

      IF (MA(2) == 0) THEN
          DO J = 2, NDIG
             MA(J) = MA(J+1)
          ENDDO
          MA(1) = MA(1) - 1
          MA(N1) = 0
      ENDIF

  160 MA(-1) = 1
      IF (X < 0.0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1
      MA(0) = MIN(NINT((NE-1)*ALOGM2),NINT(NDIG*ALOGM2))
      RETURN
      END SUBROUTINE FMDM

      SUBROUTINE FMDM2(X,MA)

!  Internal routine for converting double precision to multiple
!  precision.  Called by FMDP2M.

      USE FMVALS
      IMPLICIT NONE

      DOUBLE PRECISION X
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      DOUBLE PRECISION Y,TWO20
      INTEGER J,JEXP,K,KEXP,KRESLT,N1,NDSAVE

!             Increase the working precision.

      NDSAVE = NDIG
      IF (NCALL == 1) THEN
          K = MAX(NGRD21,1)
          NDIG = MAX(NDIG+K,2)
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWARN
              NDIG = NDSAVE
              KRESLT = 12
              CALL FMRSLT(MA,MA,M07,KRESLT)
              CALL FMEQ(M07,MA)
              IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
              NCALL = NCALL - 1
              RETURN
          ENDIF
      ENDIF

      IF (MBLOGS /= MBASE) CALL FMCONS
      KFLAG = 0
      N1 = NDIG + 1

      IF (X == 0.0D0) THEN
          DO J = 1, N1
             MA(J) = 0
          ENDDO
          GO TO 140
      ENDIF

      Y = ABS(X)
      TWO20 = 1048576.0D0

!             If this power of two is not representable at the current
!             base and precision, use a smaller one.

      IF (INT(NDIG*ALOGM2) < 20) THEN
          K = INT(NDIG*ALOGM2)
          TWO20 = 1.0D0
          DO J = 1, K
             TWO20 = TWO20*2.0D0
          ENDDO
      ENDIF

      KEXP = 0
      IF (Y > TWO20) THEN
  110     Y = Y/TWO20
          KEXP = KEXP + 1
          IF (Y > TWO20) GO TO 110
      ELSE IF (Y < 1.0D0) THEN
  120     Y = Y*TWO20
          KEXP = KEXP - 1
          IF (Y < 1.0D0) GO TO 120
      ENDIF

      K = INT(TWO20)
      CALL FMI2M(K,M04)
      K = INT(Y)
      CALL FMI2M(K,M02)
      Y = (Y-DBLE(K))*TWO20
      JEXP = 0

  130 K = INT(Y)
      CALL FMI2M(K,M03)
      CALL FMMPY_R1(M02,M04)
      JEXP = JEXP + 1
      CALL FMADD_R1(M02,M03)
      Y = (Y-DBLE(K))*TWO20
      IF (JEXP <= 1000 .AND. Y /= 0.0D0) GO TO 130

      K = KEXP - JEXP
      CALL FMIPWR(M04,K,M03)
      CALL FMMPY(M02,M03,MA)

  140 MA(-1) = 1
      IF (X < 0.0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1
      MA(0) = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315)
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE FMDM2

      SUBROUTINE FMDP2M(X,MA)

!  MA = X

!  Convert a double precision floating point number to FM format.

!  This version tries to convert the REAL (KIND(1.0D0)) :: Machine
!  number to FM with accuracy of nearly full FM precision.
!  If conversion to FM with approximately double precision accuracy
!  is good enough, FMDPM is faster and uses less scratch space.

!  This routine assumes the machine's base for double precision is
!  a power of two.

      USE FMVALS
      IMPLICIT NONE

      DOUBLE PRECISION X
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMDP2M'
      IF (NTRACE /= 0) CALL FMNTRR(2,X,1)

      CALL FMDM2(X,MA)

      IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMDP2M

      SUBROUTINE FMDPM(X,MA)

!  MA = X

!  Convert a double precision floating point number to FM format.

!  In general, the relative accuracy of the FM number returned is only
!  the relative accuracy of a machine precision number.  This may be
!  true even if X can be represented exactly in the machine floating
!  point number system.

!  This version is faster than FMDP2M, but often less accurate.
!  No scratch arrays are used.

      USE FMVALS
      IMPLICIT NONE

      DOUBLE PRECISION X
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      DOUBLE PRECISION Y,YT
      INTEGER K

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMDPM '
      IF (NTRACE /= 0) CALL FMNTRR(2,X,1)

!             Check to see if X is exactly a small integer.  If so,
!             converting as an integer is better.
!             Also see if X is exactly a small integer divided by
!             a small power of two.

      Y = 1048576.0D0
      IF (ABS(X) < Y) THEN
          K = INT(X)
          Y = K
          IF (Y == X) THEN
              CALL FMIM(K,MA)
              GO TO 110
          ENDIF
      ENDIF
      IF (ABS(X) < 1.0D0) THEN
          Y = 4096.0D0*X
          K = INT(Y)
          YT = K
          IF (Y == YT) THEN
              CALL FMIM(K,MA)
              CALL FMDIVI_R1(MA,4096)
              GO TO 110
          ENDIF
      ENDIF

      CALL FMDM(X,MA)

  110 IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMDPM

      SUBROUTINE FMENTR(NROUTN,MA,MB,NARGS,KNAM,MC,KRESLT,NDSAVE,MXSAVE,  &
                        KASAVE,KOVUN)

!  Do the argument checking and increasing of precision and overflow
!  threshold upon entry to an FM routine.

!  NROUTN - routine name of calling routine
!  MA     - first input argument
!  MB     - second input argument (optional)
!  NARGS  - number of input arguments
!  KNAM   - positive if the routine name is to be printed.
!  MC     - result argument
!  KRESLT - returned nonzero if the input arguments give the result
!           immediately (e.g., MA*0 or OVERFLOW*MB)
!  NDSAVE - saves the value of NDIG after NDIG is increased
!  MXSAVE - saves the value of MXEXP
!  KASAVE - saves the value of KACCSW
!  KOVUN  - returned nonzero if an input argument is (+ or -) overflow
!           or underflow.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(6) :: NROUTN
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK),MXSAVE
      INTEGER KNAM,NARGS,KRESLT,NDSAVE,KASAVE,KOVUN

      REAL (KIND(1.0D0)) :: MACCAB
      INTEGER K

      NCALL = NCALL + 1
      NAMEST(NCALL) = NROUTN
      IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,NARGS,KNAM)
      CALL FMARGS(NROUTN,NARGS,MA,MB,KRESLT)

      IF (MBLOGS /= MBASE) CALL FMCONS
      KOVUN = 0
      IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
      IF (NARGS == 2) THEN
          IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1
      ENDIF

!             Increase the working precision.

      NDSAVE = NDIG
      IF (NCALL == 1) THEN
          K = MAX(NGRD52-1,2)
          NDIG = MAX(NDIG+K,2)
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWARN
              KRESLT = 12
              NDIG = NDSAVE
          ENDIF
      ENDIF

      IF (KRESLT /= 0) THEN
          MACCAB = MA(0)
          IF (NARGS == 2) MACCAB = MIN(MACCAB,MB(0))
          IF (KRESLT == 9 .OR. KRESLT == 10 .OR. KRESLT >= 13) THEN
              IF (KRAD == 1) THEN
                  CALL FMPI(MC)
              ELSE
                  CALL FMI2M(180,MC)
              ENDIF
              IF (KRESLT <= 10) CALL FMDIVI_R1(MC,2)
              IF (KRESLT >= 14) CALL FMDIVI_R1(MC,4)
              CALL FMEQ2_R1(MC,NDIG,NDSAVE)
              NDIG = NDSAVE
              IF ((KRESLT == 9 .OR. KRESLT == 14) .AND.  &
                  MC(1) /= MUNKNO .AND. MC(2) /= 0)  &
                  MC(-1) = -MC(-1)
              MC(0) = MACCAB
              IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
              KASAVE = KACCSW
              MXSAVE = MXEXP
              NCALL = NCALL - 1
              RETURN
          ENDIF

          NDIG = NDSAVE
          CALL FMRSLT(MA,MB,MC,KRESLT)
          IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
          KASAVE = KACCSW
          MXSAVE = MXEXP
          NCALL = NCALL - 1
          RETURN
      ENDIF

      KASAVE = KACCSW
      KACCSW = 0

!             Extend the overflow/underflow threshold.

      MXSAVE = MXEXP
      MXEXP = MXEXP2
      RETURN
      END SUBROUTINE FMENTR

      SUBROUTINE FMEQ(MA,MB)

!  MB = MA

!  This is the standard form of equality, where MA and MB both
!  have precision NDIG.  Use FMEQU for assignments that also
!  change precision.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      INTEGER J

      DO J = -1, NDIG+1
         MB(J) = MA(J)
      ENDDO

!             Check for overflow or underflow.

      IF (ABS(MB(1)) > MXEXP) THEN
          IF (MB(1) /= MUNKNO .OR. MB(2) /= 1) THEN
              NCALL = NCALL + 1
              CALL FMTRAP(MB)
              NCALL = NCALL - 1
          ENDIF
          IF (MB(1) == MUNKNO) KFLAG = -4
      ENDIF

      RETURN
      END SUBROUTINE FMEQ

      SUBROUTINE FMEQ2(MA,MB,NDA,NDB)

!  Set MB (having NDB digits) equal to MA (having NDA digits).

!  If MB has less precision than MA the result is rounded to NDB digits.

!  If MB has more precision the result has zero digits padded on the
!  right.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER NDA,NDB

      REAL (KIND(1.0D0)) :: M2,MACCA,MBS,MKT
      INTEGER J,JT,K,KB,L,N1

      IF (MBLOGS /= MBASE) CALL FMCONS
      MACCA = MA(0)

!             Check for precision in range.

      IF (NDA < 1 .OR. NDA > NDG2MX .OR. NDB < 1 .OR.  &
                                           NDB > NDG2MX) THEN
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMEQU '
          KFLAG = -1
          CALL FMWARN
          WRITE (KW,  &
                 "(/' The two precisions in FMEQU were NDA =',I10,"  //  &
                  "' NDB =',I10/)"                                       &
                ) NDA,NDB
          CALL FMIM(0,MB)
          KFLAG = -1
          MB(1) = MUNKNO
          MB(2) = 1
          MB(0) = NINT(NDIG*ALOGM2)
          NCALL = NCALL - 1
          RETURN
      ENDIF
      MBS = MA(-1)
      MB(-1) = MBS

!             Check for special symbols.

      KFLAG = 0
      IF (ABS(MA(1)) >= MEXPOV) THEN
          DO J = 2, NDB
             MB(J+1) = 0
          ENDDO
          MB(1) = MA(1)
          MB(2) = MA(2)
          GO TO 150
      ENDIF

      IF (NDB == NDA) GO TO 130

      IF (NDB > NDA) GO TO 140

!             Round to NDB digits.

      N1 = NDB + 1
      DO J = 1, N1
         MB(J) = MA(J)
      ENDDO
      IF (KROUND == -1 .AND. NCALL <= 1) THEN
          IF (MA(-1) > 0) GO TO 150
          DO J = NDB+2, NDA+1
             IF (MA(J) > 0) GO TO 110
          ENDDO
          GO TO 150
      ENDIF
      IF (KROUND == 2 .AND. NCALL <= 1) THEN
          IF (MA(-1) < 0) GO TO 150
          DO J = NDB+2, NDA+1
             IF (MA(J) > 0) GO TO 110
          ENDDO
          GO TO 150
      ENDIF
      IF (KROUND == 0 .AND. NCALL <= 1) GO TO 150

      L = NDB + 2
      IF (2*(MA(L)+1) < MBASE) GO TO 150
      M2 = 2
      IF (INT(MBASE-AINT (MBASE/M2)*M2) == 0) THEN
          IF (2*MA(L) < MBASE) GO TO 150
          IF (2*MA(L) == MBASE) THEN
              IF (L <= NDA) THEN
                  DO J = L, NDA
                     IF (MA(J+1) > 0) GO TO 110
                  ENDDO
              ENDIF

!                       Round to even.

              IF (INT(MB(N1)-AINT (MB(N1)/M2)*M2) == 0) GO TO 150
          ENDIF
      ELSE
          IF (2*MA(L)+1 == MBASE) THEN
              IF (L <= NDA) THEN
                  DO J = L, NDA
                     IF (2*(MA(J+1)+1) < MBASE) GO TO 150
                     IF (2*MA(J+1) > MBASE) GO TO 110
                  ENDDO
                  GO TO 150
              ENDIF
          ENDIF
      ENDIF

  110 MB(NDB+1) = MB(NDB+1) + 1
      MB(NDB+2) = 0

!             Check whether there was a carry in the rounded digit.

      KB = NDB + 1
      IF (KB >= 3) THEN
          K = KB + 1
          DO J = 3, KB
             K = K - 1
             IF (MB(K) < MBASE) GO TO 120
             MKT = AINT (MB(K)/MBASE)
             MB(K-1) = MB(K-1) + MKT
             MB(K) = MB(K) - MKT*MBASE
          ENDDO
      ENDIF

!             If there is a carry in the first digit then the exponent
!             must be adjusted and the number shifted right.

      IF (MB(2) < MBASE) GO TO 120
      IF (KB >= 4) THEN
          K = KB + 1
          DO J = 4, KB
             K = K - 1
             MB(K) = MB(K-1)
          ENDDO
      ENDIF

      MKT = AINT (MB(2)/MBASE)
      IF (KB >= 3) MB(3) = MB(2) - MKT*MBASE
      MB(2) = MKT
      MB(1) = MB(1) + 1

  120 IF (MBS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1
      GO TO 150

!             MA and MB have the same precision.

  130 DO J = 1, NDA+1
         MB(J) = MA(J)
      ENDDO
      GO TO 150

!             Extend to NDB digits by padding with zeros.

  140 DO J = 1, NDA+1
         MB(J) = MA(J)
      ENDDO
      DO J = NDA+2, NDB+1
         MB(J) = 0
      ENDDO

!             Check for overflow or underflow.

  150 IF (ABS(MB(1)) > MXEXP) THEN
          IF (MB(1) /= MUNKNO .OR. MB(2) /= 1) THEN
              NCALL = NCALL + 1
              CALL FMTRAP(MB)
              NCALL = NCALL - 1
          ENDIF
          IF (MB(1) == MUNKNO) KFLAG = -4
      ENDIF

      IF (KACCSW == 1) THEN
          JT = NINT(LOG(REAL(ABS(MB(2))+1))/0.69315)
          IF (NDB > NDA) THEN
              MB(0) = NINT((NDB-1)*ALOGM2 + JT)
          ELSE
              MB(0) = MIN(NINT((NDB-1)*ALOGM2+JT),INT(MACCA))
          ENDIF
      ELSE
          MB(0) = MA(0)
      ENDIF
      RETURN
      END SUBROUTINE FMEQ2

      SUBROUTINE FMEQ2_R1(MA,NDA,NDB)

!  Change precision of MA from NDA digits on input to NDB digits on output.

!  If NDB is less than NDA the result is rounded to NDB digits.

!  If NDB is greater than NDA the result has zero digits padded on the
!  right.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER NDA,NDB

      REAL (KIND(1.0D0)) :: M2,MACCA,MBS,MKT
      INTEGER J,JT,K,KB,L,N1

      IF (MBLOGS /= MBASE) CALL FMCONS
      MACCA = MA(0)

!             Check for precision in range.

      IF (NDA < 1 .OR. NDA > NDG2MX .OR. NDB < 1 .OR.  &
                                           NDB > NDG2MX) THEN
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMEQU '
          KFLAG = -1
          CALL FMWARN
          WRITE (KW,  &
                 "(/' The two precisions in FMEQU were NDA =',I10,"  //  &
                  "' NDB =',I10/)"                                       &
                ) NDA,NDB
          CALL FMIM(0,MA)
          KFLAG = -1
          MA(1) = MUNKNO
          MA(2) = 1
          MA(0) = NINT(NDIG*ALOGM2)
          NCALL = NCALL - 1
          RETURN
      ENDIF
      MBS = MA(-1)

!             Check for special symbols.

      KFLAG = 0
      IF (ABS(MA(1)) >= MEXPOV) THEN
          DO J = 2, NDB
             MA(J+1) = 0
          ENDDO
          GO TO 140
      ENDIF

      IF (NDB == NDA) GO TO 140

      IF (NDB > NDA) GO TO 130

!             Round to NDB digits.

      N1 = NDB + 1
      IF (KROUND == -1 .AND. NCALL <= 1) THEN
          IF (MA(-1) > 0) GO TO 140
          DO J = NDB+2, NDA+1
             IF (MA(J) > 0) GO TO 110
          ENDDO
          GO TO 140
      ENDIF
      IF (KROUND == 2 .AND. NCALL <= 1) THEN
          IF (MA(-1) < 0) GO TO 140
          DO J = NDB+2, NDA+1
             IF (MA(J) > 0) GO TO 110
          ENDDO
          GO TO 140
      ENDIF
      IF (KROUND == 0 .AND. NCALL <= 1) GO TO 140

      L = NDB + 2
      IF (2*(MA(L)+1) < MBASE) GO TO 140
      M2 = 2
      IF (INT(MBASE-AINT (MBASE/M2)*M2) == 0) THEN
          IF (2*MA(L) < MBASE) GO TO 140
          IF (2*MA(L) == MBASE) THEN
              IF (L <= NDA) THEN
                  DO J = L, NDA
                     IF (MA(J+1) > 0) GO TO 110
                  ENDDO
              ENDIF

!                       Round to even.

              IF (INT(MA(N1)-AINT (MA(N1)/M2)*M2) == 0) GO TO 140
          ENDIF
      ELSE
          IF (2*MA(L)+1 == MBASE) THEN
              IF (L <= NDA) THEN
                  DO J = L, NDA
                     IF (2*(MA(J+1)+1) < MBASE) GO TO 140
                     IF (2*MA(J+1) > MBASE) GO TO 110
                  ENDDO
                  GO TO 140
              ENDIF
          ENDIF
      ENDIF

  110 MA(NDB+1) = MA(NDB+1) + 1
      MA(NDB+2) = 0

!             Check whether there was a carry in the rounded digit.

      KB = NDB + 1
      IF (KB >= 3) THEN
          K = KB + 1
          DO J = 3, KB
             K = K - 1
             IF (MA(K) < MBASE) GO TO 120
             MKT = AINT (MA(K)/MBASE)
             MA(K-1) = MA(K-1) + MKT
             MA(K) = MA(K) - MKT*MBASE
          ENDDO
      ENDIF

!             If there is a carry in the first digit then the exponent
!             must be adjusted and the number shifted right.

      IF (MA(2) < MBASE) GO TO 120
      IF (KB >= 4) THEN
          K = KB + 1
          DO J = 4, KB
             K = K - 1
             MA(K) = MA(K-1)
          ENDDO
      ENDIF

      MKT = AINT (MA(2)/MBASE)
      IF (KB >= 3) MA(3) = MA(2) - MKT*MBASE
      MA(2) = MKT
      MA(1) = MA(1) + 1

  120 IF (MBS < 0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1
      GO TO 140

!             Extend to NDB digits by padding with zeros.

  130 DO J = NDA+2, NDB+1
         MA(J) = 0
      ENDDO

!             Check for overflow or underflow.

  140 IF (ABS(MA(1)) > MXEXP) THEN
          IF (MA(1) /= MUNKNO .OR. MA(2) /= 1) THEN
              NCALL = NCALL + 1
              CALL FMTRAP(MA)
              NCALL = NCALL - 1
          ENDIF
          IF (MA(1) == MUNKNO) KFLAG = -4
      ENDIF

      IF (KACCSW == 1) THEN
          JT = NINT(LOG(REAL(ABS(MA(2))+1))/0.69315)
          IF (NDB > NDA) THEN
              MA(0) = NINT((NDB-1)*ALOGM2 + JT)
          ELSE
              MA(0) = MIN(NINT((NDB-1)*ALOGM2+JT),INT(MACCA))
          ENDIF
      ENDIF
      RETURN
      END SUBROUTINE FMEQ2_R1

      SUBROUTINE FMEQU(MA,MB,NDA,NDB)

!  Set MB (having NDB digits) equal to MA (having NDA digits).

!  If MB has less precision than MA, the result is rounded to
!  NDB digits.

!  If MB has more precision, the result has its precision extended
!  by padding with zero digits on the right.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER NDA,NDB

      CALL FMEQ2(MA,MB,NDA,NDB)

      RETURN
      END SUBROUTINE FMEQU

      SUBROUTINE FMEXIT(MT,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)

!  Upon exit from an FM routine the result MT (having precision NDIG)
!  is rounded and returned in MC (having precision NDSAVE).
!  The values of NDIG, MXEXP, and KACCSW are restored.
!  KOVUN is nonzero if one of the routine's input arguments was overflow
!  or underflow.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MT(-1:LUNPCK),MC(-1:LUNPCK),MXSAVE
      INTEGER NDSAVE,KASAVE,KOVUN

      INTEGER KFSAVE,KWRNSV

      KWRNSV = KWARN
      KWARN = 0
      MXEXP = MXSAVE
      KFSAVE = KFLAG
      CALL FMEQ2(MT,MC,NDIG,NDSAVE)
      IF (KFLAG /= -5 .AND. KFLAG /= -6) KFLAG = KFSAVE
      NDIG = NDSAVE
      KWARN = KWRNSV
      IF (KFLAG == 1) KFLAG = 0
      IF ((MC(1) == MUNKNO .AND. KFLAG /= -9)  &
         .OR. (MC(1) == MEXPUN .AND. KOVUN == 0)  &
         .OR. (MC(1) == MEXPOV .AND. KOVUN == 0)) CALL FMWARN
      IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
      NCALL = NCALL - 1
      KACCSW = KASAVE
      RETURN
      END SUBROUTINE FMEXIT

      SUBROUTINE FMEXP(MA,MB)

!  MB = EXP(MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      CHARACTER(155) :: STRING
      REAL (KIND(1.0D0)) :: M1,MA1,MA2,MACCA,MACMAX,MAS,MXSAVE
      INTEGER IEXTRA,J,K,KASAVE,KOVUN,KRESLT,KT,KWRNSV,NDMB,  &
              NDSAVE,NDSV,NMETHD
      REAL XMA,XOV

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN
          CALL FMENTR('FMEXP ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMEXP '
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52-1,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,MB,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      MA1 = MA(1)
      MA2 = MA(2)
      MAS = MA(-1)

      MACCA = MA(0)
      CALL FMEQ2(MA,MB,NDSAVE,NDIG)
      MB(0) = NINT(NDIG*ALOGM2)

!             Check for obvious underflow or overflow.
!             XOV is LN(LN(slightly above overflow))
!             XMA is LN(LN(EXP(MA))) approximately.

      XOV = LOG(1.01*REAL(MXEXP)) + LOG(ALOGMB)
      M1 = 1
      XMA = LOG(REAL(MAX(ABS(MA2),M1))) - ALOGMB +  &
            REAL(MA1)*ALOGMB

  110 IF (XMA >= XOV) THEN
          CALL FMIM(0,MB)
          IF (MAS > 0) THEN
              KFLAG = -5
              CALL FMST2M('OVERFLOW',MB)
          ELSE
              KFLAG = -6
              CALL FMST2M('UNDERFLOW',MB)
          ENDIF
          NDIG = NDSAVE
          MXEXP = MXSAVE
          KACCSW = KASAVE
          CALL FMWARN
          IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF

!             Split MA into integer and fraction parts.
!             Work with a positive argument.
!             M02 = integer part of ABS(MA)
!             MB  = fraction part of ABS(MA)

      MB(-1) = 1
      CALL FMINT(MB,M02)
      CALL FMSUB_R1(MB,M02)

!             If the integer part is not zero, use FMIPWR to compute
!             E**(M02).  If M02 is too large to represent as a one word
!             integer, the definition of MXEXP insures that E**(M02)
!             overflows or underflows.

      KWRNSV = KWARN
      KWARN = 0
      CALL FMM2I(M02,KT)
      KWARN = KWRNSV
      IF (KFLAG /= 0) THEN
          XMA = XOV
          GO TO 110
      ENDIF
      IF (KT > 0) THEN

!             Compute IEXTRA, the number of extra digits required
!             to get EXP(KT) correct to the current precision.

          IEXTRA = INT(LOG(REAL(KT))/ALOGMB + 0.5)
          IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
              CALL FMEQ2_R1(MB,NDIG,NDIG+IEXTRA)
          ENDIF
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              IF (NCALL == 1) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDIG - IEXTRA
                  CALL FMST2M('UNKNOWN',MB)
                  DO J = -1, NDIG+1
                     M01(J) = MB(J)
                  ENDDO
                  CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
                  RETURN
              ELSE
                  CALL FMEQ2_R1(MB,NDIG-IEXTRA,NDG2MX)
                  NDIG = NDG2MX
              ENDIF
          ENDIF

!             Check whether the current precision of e is large
!             enough.

          IF (MBSE /= MBASE .OR. NDIG > NDIGE) THEN
            NDMB = INT(150.0*2.302585/ALOGMB)
            IF (NDMB >= NDIG) THEN
              NDSV = NDIG
              NDIG = MIN(NDMB,NDG2MX)
              STRING = '2.718281828459045235360287471352662497757247'//  &
              '09369995957496696762772407663035354759457138217852516'//  &
              '6427427466391932003059921817413596629043572900334295261'
              CALL FMST2M(STRING,MESAV)
              MESAV(0) = NINT(NDIG*ALOGM2)
              MBSE = MBASE
              NDIGE = NDIG
              IF (ABS(MESAV(1)) > 10) NDIGE = 0
              NDIG = NDSV
            ELSE
              NDSV = NDIG
              NDIG = MIN(NDIG+2,NDG2MX)
              CALL FMI2M(1,MESAV)
              CALL FMEXP2(MESAV,M09)
              CALL FMEQ(M09,MESAV)
              MESAV(0) = NINT(NDIG*ALOGM2)
              MBSE = MBASE
              NDIGE = NDIG
              IF (ABS(MESAV(1)) > 10) NDIGE = 0
              NDIG = NDSV
            ENDIF
          ENDIF

      ENDIF

!             Now do the fraction part of MA and combine the results.

      KWRNSV = KWARN
      KWARN = 0
      NMETHD = 1
      IF (NDIG > 50) NMETHD = 2
      IF (MB(2) /= 0 .AND. KT > 0 .AND. NMETHD == 1) THEN
          CALL FMEXP2(MB,M09)
          CALL FMEQ(M09,MB)
          CALL FMIPWR(MESAV,KT,M03)
          CALL FMMPY_R1(MB,M03)
      ELSE IF (MB(2) /= 0 .AND. KT == 0 .AND. NMETHD == 1) THEN
          CALL FMEXP2(MB,M09)
          CALL FMEQ(M09,MB)
      ELSE IF (MB(2) /= 0 .AND. KT > 0 .AND. NMETHD == 2) THEN
          NDSV = NDIG
          NDIG = MIN(NDIG+NGRD21,NDG2MX)
          CALL FMEQ2_R1(MB,NDSV,NDIG)
          IF (MB(1) >= 0) THEN
              CALL FMCSH2(MB,M09)
              CALL FMEQ(M09,MB)
              CALL FMSQR(MB,M03)
              CALL FMI2M(-1,M02)
              CALL FMADD_R1(M03,M02)
              CALL FMSQRT_R1(M03)
              CALL FMADD_R1(MB,M03)
          ELSE
              CALL FMSNH2(MB,M09)
              CALL FMEQ(M09,MB)
              CALL FMSQR(MB,M03)
              CALL FMI2M(1,M02)
              CALL FMADD_R1(M03,M02)
              CALL FMSQRT_R1(M03)
              CALL FMADD_R1(MB,M03)
          ENDIF
          NDIG = NDSV
          CALL FMIPWR(MESAV,KT,M03)
          CALL FMMPY_R1(MB,M03)
      ELSE IF (MB(2) /= 0 .AND. KT == 0 .AND. NMETHD == 2) THEN
          NDSV = NDIG
          NDIG = MIN(NDIG+NGRD21,NDG2MX)
          CALL FMEQ2_R1(MB,NDSV,NDIG)
          IF (MB(1) >= 0) THEN
              CALL FMCSH2(MB,M09)
              CALL FMEQ(M09,MB)
              CALL FMSQR(MB,M03)
              CALL FMI2M(-1,M02)
              CALL FMADD_R1(M03,M02)
              CALL FMSQRT_R1(M03)
              CALL FMADD_R1(MB,M03)
          ELSE
              CALL FMSNH2(MB,M09)
              CALL FMEQ(M09,MB)
              CALL FMSQR(MB,M03)
              CALL FMI2M(1,M02)
              CALL FMADD_R1(M03,M02)
              CALL FMSQRT_R1(M03)
              CALL FMADD_R1(MB,M03)
          ENDIF
          NDIG = NDSV
      ELSE IF (MB(2) == 0 .AND. KT > 0) THEN
          CALL FMIPWR(MESAV,KT,MB)
      ELSE
          CALL FMI2M(1,MB)
      ENDIF

!             Invert if MA was negative.

      IF (MAS < 0) THEN
          CALL FMI2M(1,M02)
          CALL FMDIV_R2(M02,MB)
      ENDIF
      KWARN = KWRNSV

!             Round the result and return.

      MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
      MB(0) = MIN(MB(0),MACCA,MACMAX)
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMEXP

      SUBROUTINE FMEXP2(MA,MB)

!  MB = EXP(MA)

!  Internal exponential routine (called with 0 < MA <= 1).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
!             LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent
!             sums.  Increasing this value will begin to improve the
!             speed of EXP when the base is large and precision exceeds
!             about 1,500 decimal digits.

      REAL (KIND(1.0D0)) :: MAXVAL
      INTEGER J,J2,K,K2,KPT,KTWO,L,L2,N2,NBIG,NBOT,NDSAV1,NDSAVE,  &
              NTERM,NTOP
      REAL ALOG2,ALOGT,B,T,TJ,XN

      IF (MBLOGS /= MBASE) CALL FMCONS
      NDSAVE = NDIG
      IF (MA(1) == 1) THEN

!             Here the special case EXP(1.0) is computed.
!             Use the direct series  e = 1/0! + 1/1! + 1/2! + ...
!             Do as much of the work as possible using small integers
!             to minimize the number of FM calls.
!             Reduce NDIG while computing each term in the
!             sum as the terms get smaller.

          T = NDIG
          XN = T*ALOGMB/LOG(T)
          K = INT(LOG(XN)/ALOGMB)
          NDIG = MAX(NDIG+K,2)
          IF (NDIG > NDG2MX) THEN
              IF (NCALL == 1) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  CALL FMST2M('UNKNOWN',MB)
                  RETURN
              ELSE
                  NDIG = NDG2MX
              ENDIF
          ENDIF
          NDSAV1 = NDIG

          CALL FMI2M(2,MB)
          CALL FMI2M(1,M02)
          J = 2
          NBIG = INT(MXBASE)

  110     NTOP = 1
          NBOT = J
  120     IF (NBOT > NBIG/(J+1)) GO TO 130
          J = J + 1
          NTOP = J*NTOP + 1
          NBOT = J*NBOT
          GO TO 120

  130     CALL FMDIVI_R1(M02,NBOT)
          IF (NTOP > 1) THEN
              CALL FMMPYI(M02,NTOP,M03)
              NDIG = NDSAV1
              CALL FMADD_R1(MB,M03)
              NDIG = NDSAV1 - INT(MB(1)-M03(1))
          ELSE
              NDIG = NDSAV1
              CALL FMADD_R1(MB,M02)
              NDIG = NDSAV1 - INT(MB(1)-M02(1))
          ENDIF
          IF (NDIG < 2) NDIG = 2
          IF (KFLAG /= 1) THEN
              J = J + 1
              GO TO 110
          ENDIF
          NDIG = NDSAVE
          CALL FMI2M(-1,M02)
          CALL FMADD(MB,M02,M03)
          KFLAG = 0
          RETURN
      ENDIF

!             Here is the general case.  Compute EXP(MA) where
!             0 < MA < 1.

!             Use the direct series
!                  EXP(X) = 1 + X + X**2/2! + X**3/3! + ...

!             The argument will be halved K2 times before the series
!             is summed.  The series will be added as J2 concurrent
!             series.  The approximately optimal values of K2 and J2
!             are now computed to try to minimize the time required.
!             N2 is the approximate number of terms of the series that
!             will be needed, and L2 guard digits will be carried.

      B = REAL(MBASE)
      K = NGRD52
      T = MAX(NDIG-K,2)
      ALOG2 = REAL(DLOGTW)
      ALOGT = LOG(T)
      TJ = 0.051*ALOGMB*T**0.3333 + 1.85
      J2 = INT(TJ)
      J2 = MAX(1,MIN(J2,LJSUMS/NDG2MX))
      K2 = INT(1.13*SQRT(T*ALOGMB/TJ) - 0.5*ALOGT + 4.5)

      L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B +  &
                REAL(MA(3))/(B*B)))/ALOG2 - 0.3)
      K2 = K2 - L
      IF (L < 0) L = 0
      IF (K2 < 0) THEN
          K2 = 0
          J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) + .33)
      ENDIF
      IF (J2 <= 1) J2 = 1

      N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2))
      L2 = INT(LOG(REAL(N2)+2.0**K2)/ALOGMB)
      NDIG = NDIG + L2
      IF (NDIG > NDG2MX) THEN
          IF (NCALL == 1) THEN
              KFLAG = -9
              CALL FMWARN
              NDIG = NDSAVE
              CALL FMST2M('UNKNOWN',MB)
              RETURN
          ELSE
              NDIG = NDG2MX
          ENDIF
      ENDIF
      NDSAV1 = NDIG

!             Halve the argument K2 times.

      CALL FMEQ2(MA,M02,NDSAVE,NDIG)
      KTWO = 1
      MAXVAL = MXBASE/2
      IF (K2 > 0) THEN
          DO J = 1, K2
             KTWO = 2*KTWO
             IF (KTWO > MAXVAL) THEN
                 CALL FMDIVI_R1(M02,KTWO)
                 KTWO = 1
             ENDIF
          ENDDO
          IF (KTWO > 1) CALL FMDIVI_R1(M02,KTWO)
      ENDIF

!             Sum the series X + X**2/2! + X**3/3! + ....
!             Split into J2 concurrent sums and reduce NDIG while
!             computing each term in the sum as the terms get smaller.

      CALL FMEQ(M02,MB)
      NTERM = 1
      DO J = 1, J2
         CALL FMDIVI_R1(MB,NTERM)
         NTERM = NTERM + 1
         KPT = (J-1)*(NDIG+3)
         CALL FMEQ(MB,MJSUMS(KPT-1))
      ENDDO
      IF (M02(1) < -NDIG) GO TO 150
      CALL FMIPWR(M02,J2,M03)

  140 CALL FMMPY_R1(MB,M03)
      DO J = 1, J2
         CALL FMDIVI_R1(MB,NTERM)
         KPT = (J-1)*(NDSAV1+3)
         NDIG = NDSAV1
         CALL FMADD_R1(MJSUMS(KPT-1),MB)
         IF (KFLAG /= 0) GO TO 150
         NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-MB(1))
         IF (NDIG < 2) NDIG = 2
         NTERM = NTERM + 1
      ENDDO
      GO TO 140

!             Put the J2 separate sums back together.

  150 KFLAG = 0
      KPT = (J2-1)*(NDIG+3)
      CALL FMEQ(MJSUMS(KPT-1),M03)
      IF (J2 >= 2) THEN
          DO J = 2, J2
             CALL FMMPY_R2(M02,M03)
             KPT = (J2-J)*(NDIG+3)
             CALL FMADD_R1(M03,MJSUMS(KPT-1))
          ENDDO
      ENDIF

!             Reverse the effect of halving the argument to
!             compute EXP(MA).

      NDIG = NDSAV1
      IF (K2 > 0) THEN
          IF (NDSAVE <= 20) THEN
              CALL FMI2M(2,M02)
              DO J = 1, K2
                 CALL FMADD(M03,M02,MB)
                 CALL FMMPY_R2(MB,M03)
              ENDDO
          ELSE
              DO J = 1, K2
                 CALL FMSQR(M03,MB)
                 CALL FMADD(M03,M03,M02)
                 CALL FMADD(MB,M02,M03)
              ENDDO
          ENDIF
      ENDIF
      CALL FMI2M(1,M02)
      CALL FMADD(M02,M03,MB)

      CALL FMEQ2_R1(MB,NDSAV1,NDSAVE)
      NDIG = NDSAVE

      RETURN
      END SUBROUTINE FMEXP2

      SUBROUTINE FMFLAG(K)

!  Return the internal condition variable KFLAG to the user.

      USE FMVALS
      IMPLICIT NONE
      INTEGER K
      K = KFLAG
      RETURN
      END SUBROUTINE FMFLAG

      SUBROUTINE FMFORM(FORM,MA,STRING)

!  Convert an FM number (MA) to a character string base 10 (STRING)
!  using character string FORM format.

!  FORM can be one of these types:  Iw,  Fw.d,  Ew.d,  1PEw.d
!       for positive integers w,d.

!  If Iw format is used and MA is not exactly an integer, then the
!  nearest integer to MA is printed.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(*) :: FORM,STRING
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      CHARACTER(20) :: FORMB
      INTEGER J,JF1SAV,JF2SAV,JPT,K1,K2,K3,KD,KSAVE,KWD,KWI,LAST,  &
              LB,LENGFM,LENGST,LFIRST,ND,NEXP

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMFORM'

      KSAVE = KFLAG
      JF1SAV = JFORM1
      JF2SAV = JFORM2
      STRING = ' '
      LENGFM = LEN(FORM)
      LENGST = LEN(STRING)
      KWI = 75
      KWD = 40

      IF (INDEX(FORM,'I') > 0 .OR. INDEX(FORM,'i') > 0) THEN
          K1 = MAX(INDEX(FORM,'I'),INDEX(FORM,'i')) + 1
          K2 = LENGFM
          WRITE (FORMB,"('(I',I5,')')") K2-K1+1
          IF (K2 >= K1) THEN
              READ (FORM(K1:K2),FORMB) KWI
          ELSE
              KWI = LENGST
          ENDIF
          KWI = MAX(1,MIN(KWI,LENGST))
          JFORM1 = 2
          JFORM2 = 0
          KWD = KWI + 21
          IF (KWD > LMBUFF) GO TO 120
          CALL FMNINT(MA,M02)
          IF (M02(2) /= 0) THEN
              CALL FMOUT(M02,CMBUFF,KWD)
          ELSE
              DO J = 1, KWD
                 CMBUFF(J) = ' '
              ENDDO
              CMBUFF(2) = '0'
          ENDIF
          LFIRST = 1
          LAST = 1
          DO J = 1, KWD
             IF (CMBUFF(KWD+1-J) /= ' ') LFIRST = KWD+1-J
             IF (CMBUFF(J) /= ' ') LAST = J
          ENDDO
          JPT = 1
          IF (LAST-LFIRST+1 > KWI) GO TO 120
          IF (LAST <= KWI) THEN
              DO J = LAST, LFIRST, -1
                 JPT = KWI - LAST + J
                 STRING(JPT:JPT) = CMBUFF(J)
              ENDDO
              DO J = 1, JPT-1
                 STRING(J:J) = ' '
              ENDDO
          ELSE
              DO J = LFIRST, LAST
                 JPT = KWI - LAST + J
                 STRING(JPT:JPT) = CMBUFF(J)
              ENDDO
          ENDIF
      ELSE IF (INDEX(FORM,'F') > 0 .OR. INDEX(FORM,'f') > 0) THEN
          K1 = MAX(INDEX(FORM,'F'),INDEX(FORM,'f')) + 1
          K2 = INDEX(FORM,'.')
          K3 = LENGFM
          IF (K2 > K1) THEN
              WRITE (FORMB,"('(I',I5,')')") K2-K1
              READ (FORM(K1:K2-1),FORMB) KWI
          ELSE
              KWI = 50
          ENDIF
          IF (K3 > K2) THEN
              WRITE (FORMB,"('(I',I5,')')") K3-K2
              READ (FORM(K2+1:K3),FORMB) KD
          ELSE
              KD = 0
          ENDIF
          KWI = MAX(1,MIN(KWI,LENGST))
          KD = MAX(0,MIN(KD,KWI-2))
          JFORM1 = 2
          JFORM2 = KD
          ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
          IF (ND < 2) ND = 2
          NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
          LB = MAX(JFORM2+NEXP,ND+NEXP)
          LB = MIN(LB,LMBUFF)
          KWD = LB
          CALL FMOUT(MA,CMBUFF,KWD)
          LFIRST = 1
          LAST = 1
          DO J = 1, KWD
             IF (CMBUFF(KWD+1-J) /= ' ') LFIRST = KWD+1-J
             IF (CMBUFF(J) /= ' ') LAST = J
          ENDDO
          IF (LAST-LFIRST+1 > KWI) THEN

!             Not enough room for this F format, or FMOUT converted
!             it to E format to avoid showing no significant digits.
!             See if a shortened form will fit in E format.

              NEXP = INT(LOG10((ABS(REAL(MA(1)))+1)*LOG10(REAL(MBASE))+1)+1)
              ND = KWI - NEXP - 5
              IF (ND < 1) THEN
                  GO TO 120
              ELSE
                  JFORM1 = 0
                  JFORM2 = ND
                  CALL FMOUT(MA,CMBUFF,KWI)
                  LFIRST = 1
                  LAST = 1
                  DO J = 1, KWI
                     IF (CMBUFF(KWI+1-J) /= ' ') LFIRST = KWI+1-J
                     IF (CMBUFF(J) /= ' ') LAST = J
                  ENDDO
              ENDIF
          ENDIF
          JPT = 1
          IF (LAST <= KWI) THEN
              DO J = LAST, LFIRST, -1
                 JPT = KWI - LAST + J
                 STRING(JPT:JPT) = CMBUFF(J)
              ENDDO
              DO J = 1, JPT-1
                 STRING(J:J) = ' '
              ENDDO
          ELSE
              DO J = LFIRST, LAST
                 JPT = KWI - LAST + J
                 STRING(JPT:JPT) = CMBUFF(J)
              ENDDO
          ENDIF
      ELSE IF (INDEX(FORM,'1PE') > 0 .OR. INDEX(FORM,'1pe') > 0) THEN
          K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1
          K2 = INDEX(FORM,'.')
          K3 = LENGFM
          IF (K2 > K1) THEN
              WRITE (FORMB,"('(I',I5,')')") K2-K1
              READ (FORM(K1:K2-1),FORMB) KWI
          ELSE
              KWI = 50
          ENDIF
          IF (K3 > K2) THEN
              WRITE (FORMB,"('(I',I5,')')") K3-K2
              READ (FORM(K2+1:K3),FORMB) KD
          ELSE
              KD = 0
          ENDIF
          KWI = MAX(1,MIN(KWI,LENGST))
          KD = MAX(0,MIN(KD,KWI-2))
          JFORM1 = 1
          JFORM2 = KD
          IF (KWI > LMBUFF) GO TO 120
          CALL FMOUT(MA,CMBUFF,KWI)
          DO J = KWI, 1, -1
             IF (J > LENGST) THEN
                 IF (CMBUFF(J) /= ' ') GO TO 120
             ELSE
                 STRING(J:J) = CMBUFF(J)
             ENDIF
          ENDDO
      ELSE IF (INDEX(FORM,'E') > 0 .OR. INDEX(FORM,'e') > 0) THEN
          K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1
          K2 = INDEX(FORM,'.')
          K3 = LENGFM
          IF (K2 > K1) THEN
              WRITE (FORMB,"('(I',I5,')')") K2-K1
              READ (FORM(K1:K2-1),FORMB) KWI
          ELSE
              KWI = 50
          ENDIF
          IF (K3 > K2) THEN
              WRITE (FORMB,"('(I',I5,')')") K3-K2
              READ (FORM(K2+1:K3),FORMB) KD
          ELSE
              KD = 0
          ENDIF
          KWI = MAX(1,MIN(KWI,LENGST))
          KD = MAX(0,MIN(KD,KWI-2))
          JFORM1 = 0
          JFORM2 = KD
          IF (KWI > LMBUFF) GO TO 120
          CALL FMOUT(MA,CMBUFF,KWI)
          DO J = KWI, 1, -1
             IF (J > LENGST) THEN
                 IF (CMBUFF(J) /= ' ') GO TO 120
             ELSE
                 STRING(J:J) = CMBUFF(J)
             ENDIF
          ENDDO
      ELSE
          GO TO 120
      ENDIF

  110 KFLAG = KSAVE
      JFORM1 = JF1SAV
      JFORM2 = JF2SAV
      NCALL = NCALL - 1
      RETURN

!             Error condition.

  120 KFLAG = -8
      DO J = 1, LENGST
         STRING(J:J) = '*'
      ENDDO
      GO TO 110
      END SUBROUTINE FMFORM

      SUBROUTINE FMFPRT(FORM,MA)

!  Print an FM number (MA) on unit KW using character
!  string FORM format.

!  FORM can be one of these types:  Iw,  Fw.d,  Ew.d,  1PEw.d
!       for positive integers w,d.

!  If Iw format is used and MA is not exactly an integer, then the
!  nearest integer to MA is printed.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(*) :: FORM
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      CHARACTER(20) :: FORM2,FORMB
      INTEGER J,JF1SAV,JF2SAV,JPT,K,K1,K2,K3,KD,KSAVE,KWD,KWI,  &
              LAST,LB,LENGFM,LFIRST,ND,NEXP

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMFPRT'

      KSAVE = KFLAG
      JF1SAV = JFORM1
      JF2SAV = JFORM2
      LENGFM = LEN(FORM)
      KWI = 75
      KWD = 40

      IF (INDEX(FORM,'I') > 0 .OR. INDEX(FORM,'i') > 0) THEN
          K1 = MAX(INDEX(FORM,'I'),INDEX(FORM,'i')) + 1
          K2 = LENGFM
          WRITE (FORMB,"('(I',I5,')')") K2-K1+1
          IF (K2 >= K1) THEN
              READ (FORM(K1:K2),FORMB) KWI
          ELSE
              KWI = 50
          ENDIF
          KWI = MAX(1,MIN(KWI,LMBUFF-11))
          JFORM1 = 2
          JFORM2 = 0
          KWD = KWI + 21
          CALL FMNINT(MA,M02)
          IF (M02(2) /= 0) THEN
              CALL FMOUT(M02,CMBUFF,KWD)
          ELSE
              DO J = 1, KWD
                 CMBUFF(J) = ' '
              ENDDO
              CMBUFF(2) = '0'
          ENDIF
          LFIRST = 1
          LAST = 1
          DO J = 1, KWD
             IF (CMBUFF(KWD+1-J) /= ' ') LFIRST = KWD+1-J
             IF (CMBUFF(J) /= ' ') LAST = J
          ENDDO
          JPT = 1
          IF (LAST-LFIRST+1 > KWI) GO TO 120
          IF (LAST <= KWI) THEN
              DO J = LAST, LFIRST, -1
                 JPT = KWI - LAST + J
                 IF (JPT /= J) CMBUFF(JPT) = CMBUFF(J)
              ENDDO
              DO J = 1, JPT-1
                 CMBUFF(J) = ' '
              ENDDO
          ELSE
              DO J = LFIRST, LAST
                 JPT = KWI - LAST + J
                 IF (JPT /= J) CMBUFF(JPT) = CMBUFF(J)
              ENDDO
          ENDIF
      ELSE IF (INDEX(FORM,'F') > 0 .OR. INDEX(FORM,'f') > 0) THEN
          K1 = MAX(INDEX(FORM,'F'),INDEX(FORM,'f')) + 1
          K2 = INDEX(FORM(1:LENGFM),'.')
          K3 = LENGFM
          IF (K2 > K1) THEN
              WRITE (FORMB,"('(I',I5,')')") K2-K1
              READ (FORM(K1:K2-1),FORMB) KWI
          ELSE
              KWI = 50
          ENDIF
          IF (K3 > K2) THEN
              WRITE (FORMB,"('(I',I5,')')") K3-K2
              READ (FORM(K2+1:K3),FORMB) KD
          ELSE
              KD = 0
          ENDIF
          KWI = MAX(1,MIN(KWI,LMBUFF))
          KD = MAX(0,MIN(KD,KWI-2))
          JFORM1 = 2
          JFORM2 = KD
          ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
          IF (ND < 2) ND = 2
          NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
          LB = MAX(JFORM2+NEXP,ND+NEXP)
          LB = MIN(LB,LMBUFF)
          KWD = LB
          CALL FMOUT(MA,CMBUFF,KWD)
          LFIRST = 1
          LAST = 1
          DO J = 1, KWD
             IF (CMBUFF(KWD+1-J) /= ' ') LFIRST = KWD+1-J
             IF (CMBUFF(J) /= ' ') LAST = J
          ENDDO
          IF (LAST-LFIRST+1 > KWI) THEN

!             Not enough room for this F format, or FMOUT converted
!             it to E format to avoid showing no significant digits.
!             See if a shortened form will fit in E format.

              NEXP = INT(LOG10((ABS(REAL(MA(1)))+1)*LOG10(REAL(MBASE))+1)+1)
              ND = KWI - NEXP - 5
              IF (ND < 1) THEN
                  GO TO 120
              ELSE
                  JFORM1 = 0
                  JFORM2 = ND
                  CALL FMOUT(MA,CMBUFF,KWI)
                  LFIRST = 1
                  LAST = 1
                  DO J = 1, KWI
                     IF (CMBUFF(KWI+1-J) /= ' ') LFIRST = KWI+1-J
                     IF (CMBUFF(J) /= ' ') LAST = J
                  ENDDO
              ENDIF
          ENDIF
          JPT = 1
          IF (LAST <= KWI) THEN
              DO J = LAST, LFIRST, -1
                 JPT = KWI - LAST + J
                 IF (JPT /= J) CMBUFF(JPT) = CMBUFF(J)
              ENDDO
              DO J = 1, JPT-1
                 CMBUFF(J) = ' '
              ENDDO
          ELSE
              DO J = LFIRST, LAST
                 JPT = KWI - LAST + J
                 IF (JPT /= J) CMBUFF(JPT) = CMBUFF(J)
              ENDDO
          ENDIF
      ELSE IF (INDEX(FORM,'1PE') > 0 .OR. INDEX(FORM,'1pe') > 0) THEN
          K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1
          K2 = INDEX(FORM(1:LENGFM),'.')
          K3 = LENGFM
          IF (K2 > K1) THEN
              WRITE (FORMB,"('(I',I5,')')") K2-K1
              READ (FORM(K1:K2-1),FORMB) KWI
          ELSE
              KWI = 50
          ENDIF
          IF (K3 > K2) THEN
              WRITE (FORMB,"('(I',I5,')')") K3-K2
              READ (FORM(K2+1:K3),FORMB) KD
          ELSE
              KD = 0
          ENDIF
          KWI = MAX(1,MIN(KWI,LMBUFF))
          KD = MAX(0,MIN(KD,KWI-2))
          JFORM1 = 1
          JFORM2 = KD
          CALL FMOUT(MA,CMBUFF,KWI)
      ELSE IF (INDEX(FORM,'E') > 0 .OR. INDEX(FORM,'e') > 0) THEN
          K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1
          K2 = INDEX(FORM(1:LENGFM),'.')
          K3 = LENGFM
          IF (K2 > K1) THEN
              WRITE (FORMB,"('(I',I5,')')") K2-K1
              READ (FORM(K1:K2-1),FORMB) KWI
          ELSE
              KWI = 50
          ENDIF
          IF (K3 > K2) THEN
              WRITE (FORMB,"('(I',I5,')')") K3-K2
              READ (FORM(K2+1:K3),FORMB) KD
          ELSE
              KD = 0
          ENDIF
          KWI = MAX(1,MIN(KWI,LMBUFF))
          KD = MAX(0,MIN(KD,KWI-2))
          JFORM1 = 0
          JFORM2 = KD
          CALL FMOUT(MA,CMBUFF,KWI)
      ELSE
          GO TO 120
      ENDIF

  110 LAST = KWI + 1
      WRITE (FORM2,"(' (6X,',I3,'A1) ')") KSWIDE-7
      IF (KFLAG /= -8) KFLAG = KSAVE
      JFORM1 = JF1SAV
      JFORM2 = JF2SAV
      DO J = KWI, 1, -1
         IF (CMBUFF(J) /= ' ' .OR. J == 1) THEN
             WRITE (KW,FORM2) (CMBUFF(K),K=1,J)
             NCALL = NCALL - 1
             RETURN
         ENDIF
      ENDDO
      NCALL = NCALL - 1
      RETURN

!             Error condition.

  120 KFLAG = -8
      DO J = 1, KWI
         CMBUFF(J) = '*'
      ENDDO
      GO TO 110
      END SUBROUTINE FMFPRT

      SUBROUTINE FMGCDI(N1,N2)

!  Find the Greatest Common Divisor of N1 and N2, and return both
!  having been divided by their GCD.  Both must be positive.

      USE FMVALS
      IMPLICIT NONE
      INTEGER K1,K2,K3,N1,N2

      K1 = MAX(N1,N2)
      K2 = MIN(N1,N2)
  110 K3 = MOD(K1,K2)
      IF (K3 == 0) THEN
          N1 = N1/K2
          N2 = N2/K2
          RETURN
      ELSE
          K1 = K2
          K2 = K3
          GO TO 110
      ENDIF
      END SUBROUTINE FMGCDI

      SUBROUTINE FMHTBL

!  Initialize two hash tables that are used for character
!  look-up during input conversion.

      USE FMVALS
      IMPLICIT NONE

      INTEGER J,KPT

      CHARACTER :: LCHARS(21) = (/  &
                  '+','-','0','1','2','3','4','5','6','7','8','9',  &
                  '.','E','D','Q','M','e','d','q','m' /)
      INTEGER :: LTYPES(21) = (/ 1,1,2,2,2,2,2,2,2,2,2,2,3,4,4,4,4,4,4,4,4 /)
      INTEGER :: LVALS(21) = (/ 1,-1,0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0,0,0,0 /)

      DO J = LHASH1, LHASH2
         KHASHT(J) = 5
         KHASHV(J) = 0
      ENDDO
      DO J = 1, 21
         KPT = ICHAR(LCHARS(J))
         IF (KPT < LHASH1 .OR. KPT > LHASH2) THEN
             WRITE (KW,  &
                "(/' Error in input conversion.'/"                        //  &
                "' ICHAR function was out of range for the current',"     //  &
                "' dimensions.'/' ICHAR(''',A,''') gave the value ',"     //  &
                "I12,', which is outside the currently'/' dimensioned',"  //  &
                "' bounds of (',I5,':',I5,') for variables KHASHT ',"     //  &
                "'and KHASHV.'/' Re-define the two parameters ',"         //  &
                "'LHASH1 and LHASH2 so the dimensions will'/' contain',"  //  &
                "' all possible output values from ICHAR.'//)"                &
                   ) LCHARS(J),KPT,LHASH1,LHASH2
         ELSE
             KHASHT(KPT) = LTYPES(J)
             KHASHV(KPT) = LVALS(J)
         ENDIF
      ENDDO
      LHASH = 1
      END SUBROUTINE FMHTBL

      SUBROUTINE FMI2M(IVAL,MA)

!  MA = IVAL

!  Convert an integer to FM format.

!  The conversion is exact if IVAL is less than MBASE**NDIG,
!  otherwise the result is an approximation.

!  This routine performs the trace printing for the conversion.
!  FMIM is used to do the arithmetic.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER IVAL

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMI2M '
          CALL FMNTRI(2,IVAL,1)

          CALL FMIM(IVAL,MA)

          CALL FMNTR(1,MA,MA,1,1)
      ELSE
          CALL FMIM(IVAL,MA)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMI2M

      SUBROUTINE FMIM(IVAL,MA)

!  MA = IVAL.  Internal integer conversion routine.

!  The conversion is exact if IVAL is less than MBASE**NDIG.
!  Otherwise FMDM is used to get an approximation.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER IVAL

      DOUBLE PRECISION X
      REAL (KIND(1.0D0)) :: MK,ML,MVAL
      INTEGER J,JM2,KB,KB1,N1,NMVAL,NV2

      IF (MBLOGS /= MBASE) CALL FMCONS
      KFLAG = 0
      N1 = NDIG + 1

      MVAL = ABS(IVAL)
      NMVAL = INT(MVAL)
      NV2 = NMVAL - 1
      IF (ABS(IVAL) > MXBASE .OR. NMVAL /= ABS(IVAL) .OR.  &
          NV2 /= ABS(IVAL)-1) THEN
          CALL FMIMS(IVAL,MA)
          GO TO 120
      ENDIF

!              Check for small IVAL.

      IF (MVAL < MBASE) THEN
          DO J = 3, N1
             MA(J) = 0
          ENDDO
          IF (IVAL >= 0) THEN
              MA(2) = IVAL
              MA(-1) = 1
          ELSE
              MA(2) = -IVAL
              MA(-1) = -1
          ENDIF
          IF (IVAL == 0) THEN
              MA(1) = 0
          ELSE
              MA(1) = 1
          ENDIF
          GO TO 120
      ENDIF

!             Compute and store the digits, right to left.

      MA(1) = 0
      J = NDIG + 1

  110 MK = AINT (MVAL/MBASE)
      ML = MVAL - MK*MBASE
      MA(1) = MA(1) + 1
      MA(J) = ML
      IF (MK > 0) THEN
          MVAL = MK
          J = J - 1
          IF (J >= 2) GO TO 110

!             Here IVAL cannot be expressed exactly.

          X = IVAL
          CALL FMDM(X,MA)
          RETURN
      ENDIF

!             Normalize MA.

      KB = N1 - J + 2
      JM2 = J - 2
      DO J = 2, KB
         MA(J) = MA(J+JM2)
      ENDDO
      KB1 = KB + 1
      IF (KB1 <= N1) THEN
          DO J = KB1, N1
             MA(J) = 0
          ENDDO
      ENDIF

      MA(-1) = 1
      IF (IVAL < 0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1

  120 MA(0) = NINT(NDIG*ALOGM2)
      RETURN
      END SUBROUTINE FMIM

      SUBROUTINE FMIMS(IVAL,MA)

!  MA = IVAL.  Internal integer conversion routine.

!  This routine is called when M-variable precision is less than
!  Integer precision.  This often happens when single precision
!  is chosen for M-variables.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER IVAL

      DOUBLE PRECISION X
      REAL (KIND(1.0D0)) :: ML
      INTEGER J,JM2,KB,KB1,KBASE,KMK,KVAL,N1

      IF (MBLOGS /= MBASE) CALL FMCONS
      KFLAG = 0
      N1 = NDIG + 1

!              Check for small IVAL.

      KVAL = ABS(IVAL)
      KBASE = INT(MBASE)
      IF (KVAL < KBASE) THEN
          DO J = 3, N1
             MA(J) = 0
          ENDDO
          IF (IVAL >= 0) THEN
              MA(2) = IVAL
              MA(-1) = 1
          ELSE
              MA(2) = -IVAL
              MA(-1) = -1
          ENDIF
          IF (IVAL == 0) THEN
              MA(1) = 0
          ELSE
              MA(1) = 1
          ENDIF
          GO TO 120
      ENDIF

!             Compute and store the digits, right to left.

      MA(1) = 0
      J = NDIG + 1

  110 KMK = (KVAL/KBASE)
      ML = KVAL - KMK*KBASE
      MA(1) = MA(1) + 1
      MA(J) = ML
      IF (KMK > 0) THEN
          KVAL = KMK
          J = J - 1
          IF (J >= 2) GO TO 110

!             Here IVAL cannot be expressed exactly.

          X = IVAL
          CALL FMDM(X,MA)
          RETURN
      ENDIF

!             Normalize MA.

      KB = N1 - J + 2
      JM2 = J - 2
      DO J = 2, KB
         MA(J) = MA(J+JM2)
      ENDDO
      KB1 = KB + 1
      IF (KB1 <= N1) THEN
          DO J = KB1, N1
             MA(J) = 0
          ENDDO
      ENDIF

      MA(-1) = 1
      IF (IVAL < 0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1

  120 MA(0) = NINT(NDIG*ALOGM2)
      RETURN
      END SUBROUTINE FMIMS

      SUBROUTINE FMINP(LINE,MA,LA,LB)

!  Convert an array of characters to floating point multiple precision
!  format.

!  LINE is an A1 character array of length LB to be converted
!       to FM format and returned in MA.
!  LA is a pointer telling the routine where in the array to begin
!     the conversion.  This allows more than one number to be stored
!     in an array and converted in place.
!  LB is a pointer to the last character of the field for that number.

!  The input number may be in integer or any real format.

!  KESWCH = 1  causes input to FMINP with no digits before the exponent
!              letter to be treated as if there were a leading '1'.
!              This is sometimes better for interactive input:
!              'E7' converts to 10.0**7.
!         = 0  causes a leading zero to be assumed.  This gives
!              compatibility with Fortran:
!              'E7' converts to 0.0.

!  In exponential format the 'E' may also be 'D', 'Q', or 'M'.

!  So that FMINP will convert any output from FMOUT, LINE is tested
!  to see if the input is one of the special symbols +OVERFLOW,
!  -OVERFLOW, +UNDERFLOW, -UNDERFLOW, or UNKNOWN.
!  For user input the abbreviations OVFL, UNFL, UNKN may be used.

      USE FMVALS
      IMPLICIT NONE

      INTEGER LA,LB
      CHARACTER LINE(LB)
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: M2,MNDSV1,MXSAV1,MXSAV2
      INTEGER J,JSTATE,K,K10PWR,KASAVE,KDFLAG,KEXP,KF1,KF2,KMN,KOF,KPOWER,  &
              KPT,KRSAVE,KSIGN,KSIGNX,KSTART,KSTOP,KTENEX,KTENF1,KTENF2,    &
              KTYPE,KUF,KUK,KVAL,KWRNSV,LARGE,N2,NDSAV1,NDSAVE

!  Simulate a finite-state automaton to scan the input line
!  and build the number.  States of the machine:

!  1.  Initial entry to the subroutine
!  2.  Sign of the number
!  3.  Scanning digits before a decimal point
!  4.  Decimal point
!  5.  Scanning digits after a decimal point
!  6.  E, D, Q, or M -- precision indicator before the exponent
!  7.  Sign of the exponent
!  8.  Scanning exponent
!  9.  Syntax error

!  Character types recognized by the machine:

!  1.  Sign (+,-)
!  2.  Numeral (0,1,...,9)
!  3.  Decimal point (.)
!  4.  Precision indicator (E,D,Q,M)
!  5.  Illegal character for number

!  All blanks are ignored.  The analysis of the number proceeds as
!  follows:  If the simulated machine is in state JSTATE and a character
!  of type JTYPE is encountered the new state of the machine is given by
!  JTRANS(JSTATE,JTYPE).

!  In this initialization note the array is loaded by columns.

!          State   1  2  3  4  5  6  7  8

      INTEGER :: JTRANS(8,4) = RESHAPE(  (/     &
                   2, 9, 9, 9, 9, 7, 9, 9,      &
                   3, 3, 3, 5, 5, 8, 8, 8,      &
                   4, 4, 4, 9, 9, 9, 9, 9,      &
                   6, 6, 6, 6, 6, 9, 9, 9   /)  &
        , (/ 8,4 /) )

      CHARACTER :: KOVFL(4) = (/ 'O','V','F','L' /)
      CHARACTER :: KUNFL(4) = (/ 'U','N','F','L' /)
      CHARACTER :: KUNKN(4) = (/ 'U','N','K','N' /)
      CHARACTER :: LOVFL(4) = (/ 'o','v','f','l' /)
      CHARACTER :: LUNFL(4) = (/ 'u','n','f','l' /)
      CHARACTER :: LUNKN(4) = (/ 'u','n','k','n' /)

!             To avoid recursion, FMINP calls only internal arithmetic
!             routines (FMADD2, FMMPY2, ...), so no trace printout is
!             done during a call to FMINP.

      IF (MBLOGS /= MBASE) CALL FMCONS
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMINP '

!             Raise the call stack again, since the internal
!             routines don't.

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMINP '
      NDSAVE = NDIG
      KASAVE = KACCSW
      KACCSW = 0
      KRSAVE = KROUND
      KROUND = 1
      KFLAG = 0
      MXSAV1 = MXEXP
      MXSAV2 = MXEXP2
      IF (MXEXP < 100000) THEN
          MXEXP  = 100000
          MXEXP2 = 201000
      ENDIF

!             Initialize two hash tables that are used for character
!             look-up during input conversion.

      IF (LHASH == 0) CALL FMHTBL

!             Check for special symbols.

      KMN = 1
      KOF = 1
      KUF = 1
      KUK = 1
      DO J = LA, LB
         KPT = ICHAR(LINE(J))
         IF (KPT >= LHASH1 .AND. KPT <= LHASH2) THEN
             KTYPE = KHASHT(KPT)
             IF (KTYPE == 2) GO TO 110
         ENDIF
         IF (LINE(J) == '-') KMN = -1
         IF (LINE(J) == KOVFL(KOF) .OR. LINE(J) == LOVFL(KOF)) THEN
             KOF = KOF + 1
             IF (KOF == 5) THEN
                 CALL FMIM(0,MA)
                 MA(1) = MEXPOV
                 MA(2) = 1
                 MA(-1) = KMN
                 MA(0) = NINT(NDIG*ALOGM2)
                 GO TO 150
             ENDIF
         ENDIF
         IF (LINE(J) == KUNFL(KUF) .OR. LINE(J) == LUNFL(KOF)) THEN
             KUF = KUF + 1
             IF (KUF == 5) THEN
                 CALL FMIM(0,MA)
                 MA(1) = MEXPUN
                 MA(2) = 1
                 MA(-1) = KMN
                 MA(0) = NINT(NDIG*ALOGM2)
                 GO TO 150
             ENDIF
         ENDIF
         IF (LINE(J) == KUNKN(KUK) .OR. LINE(J) == LUNKN(KOF)) THEN
             KUK = KUK + 1
             IF (KUK == 5) THEN
                 CALL FMIM(0,MA)
                 MA(1) = MUNKNO
                 MA(2) = 1
                 MA(0) = NINT(NDIG*ALOGM2)
                 GO TO 150
             ENDIF
         ENDIF
      ENDDO

!             Increase the working precision.

  110 K = NGRD52
      NDIG = MAX(NDIG+K,2)
      IF (NDIG > NDG2MX) NDIG = NDG2MX
      NDSAV1 = NDIG
      M2 = 2
      MNDSV1 = NDSAV1
      KSTART = LA
      KSTOP = LB
      JSTATE = 1
      KSIGN = 1
      CALL FMIM(0,MLV2)
      CALL FMIM(0,MLV3)
      CALL FMIM(0,MLV4)
      CALL FMIM(0,MLV5)

!             If MBASE is a power of ten then call FMINP2 for
!             faster input conversion.

      KPOWER = INT(LOG10(DBLE(MBASE)) + 0.5D0)
      IF (MBASE == 10**KPOWER) THEN
          CALL FMINP2(MA,LINE,KSTART,KSTOP,JTRANS,KPOWER)
          GO TO 140
      ENDIF

      N2 = 0
      KSIGNX = 1
      KF1 = 0
      KF2 = 0
      KEXP = 0
      KTENF1 = 1
      KTENF2 = 1
      KTENEX = 1
      K10PWR = 0

!             LARGE is a threshold used in order to do as much of the
!             conversion as possible in one-word integer arithmetic.

      LARGE = INT((INTMAX - 10)/10)

!             KDFLAG will be 1 if any digits are found before 'E'.

      KDFLAG = 0

!             Scan the number.

      DO J = KSTART, KSTOP
         IF (LINE(J) == ' ') CYCLE
         KPT = ICHAR(LINE(J))
         IF (KPT < LHASH1 .OR. KPT > LHASH2) THEN
             WRITE (KW,  &
                "(/' Error in input conversion.'/"                        //  &
                "' ICHAR function was out of range for the current',"     //  &
                "' dimensions.'/' ICHAR(''',A,''') gave the value ',"     //  &
                "I12,', which is outside the currently'/' dimensioned',"  //  &
                "' bounds of (',I5,':',I5,') for variables KHASHT ',"     //  &
                "'and KHASHV.'/' Re-define the two parameters ',"         //  &
                "'LHASH1 and LHASH2 so the dimensions will'/' contain',"  //  &
                "' all possible output values from ICHAR.'//)"                &
                   ) LINE(J),KPT,LHASH1,LHASH2
             KTYPE = 5
             KVAL  = 0
         ELSE
             KTYPE = KHASHT(KPT)
             KVAL  = KHASHV(KPT)
         ENDIF

         IF (KTYPE >= 5) GO TO 160

         JSTATE = JTRANS(JSTATE,KTYPE)

         SELECT CASE (JSTATE)

!             State 2.  Sign of the number.

         CASE (2)
             KSIGN = KVAL

!             State 3.  Digits before a decimal point.

         CASE (3)
             KDFLAG = 1
             KF1 = 10*KF1 + KVAL
             KTENF1 = 10*KTENF1
             IF (KTENF1 > LARGE) THEN
                 IF (KTENF1 /= K10PWR .AND. MLV3(2) /= 0) THEN
                     CALL FMIM(KTENF1,MA)
                     K10PWR = KTENF1
                 ENDIF
                 IF (MLV3(2) == 0) THEN
                     CALL FMIM(KF1,MLV3)
                 ELSE
                     NDIG = INT(MAX(M2,MIN(MLV3(1)+MA(1),MNDSV1)))
                     CALL FMMPY2_R1(MLV3,MA)
                     NDIG = NDSAV1
                     CALL FMIM(KF1,MLV2)
                     NDIG = INT(MAX(M2,MIN(MAX(MLV3(1),MLV2(1))+1,MNDSV1)))
                     IF (KF1 /= 0) CALL FMADD2_R1(MLV3,MLV2)
                     NDIG = NDSAV1
                 ENDIF
                 KF1 = 0
                 KTENF1 = 1
             ENDIF

!             State 4.  Decimal point

         CASE (4)
             CYCLE

!             State 5.  Digits after a decimal point.

         CASE (5)
             KDFLAG = 1
             N2 = N2 + 1
             KF2 = 10*KF2 + KVAL
             KTENF2 = 10*KTENF2
             IF (KTENF2 > LARGE) THEN
                 IF (KTENF2 /= K10PWR .AND. MLV4(2) /= 0) THEN
                     CALL FMIM(KTENF2,MA)
                     K10PWR = KTENF2
                 ENDIF
                 IF (MLV4(2) == 0) THEN
                     CALL FMIM(KF2,MLV4)
                 ELSE
                     NDIG = INT(MAX(M2,MIN(MLV4(1)+MA(1),MNDSV1)))
                     CALL FMMPY2_R1(MLV4,MA)
                     NDIG = NDSAV1
                     CALL FMIM(KF2,MLV2)
                     NDIG = INT(MAX(M2,MIN(MAX(MLV4(1),MLV2(1))+1,MNDSV1)))
                     IF (KF2 /= 0) CALL FMADD2_R1(MLV4,MLV2)
                     NDIG = NDSAV1
                 ENDIF
                 KF2 = 0
                 KTENF2 = 1
             ENDIF

!             State 6.  Precision indicator.

         CASE (6)
             IF (KDFLAG == 0 .AND. KESWCH == 1) CALL FMIM(1,MLV3)

!             State 7.  Sign of the exponent.

         CASE (7)
             KSIGNX = KVAL

!             State 8.  Digits of the exponent.

         CASE (8)
             KEXP = 10*KEXP + KVAL
             KTENEX = 10*KTENEX
             IF (KTENEX > LARGE) THEN
                 IF (KTENEX /= K10PWR .AND. MLV5(2) /= 0) THEN
                     CALL FMIM(KTENEX,MA)
                     K10PWR = KTENEX
                 ENDIF
                 IF (MLV5(2) == 0) THEN
                     CALL FMIM(KEXP,MLV5)
                 ELSE
                     NDIG = INT(MAX(M2,MIN(MLV5(1)+MA(1),MNDSV1)))
                     CALL FMMPY2_R1(MLV5,MA)
                     NDIG = NDSAV1
                     CALL FMIM(KEXP,MLV2)
                     NDIG = INT(MAX(M2,MIN(MAX(MLV5(1),MLV2(1))+1,MNDSV1)))
                     IF (KEXP /= 0) CALL FMADD2_R1(MLV5,MLV2)
                     NDIG = NDSAV1
                 ENDIF
                 KEXP = 0
                 KTENEX = 1
             ENDIF

         CASE DEFAULT
             GO TO 160

         END SELECT

      ENDDO

!             Form the number and return.
!             MA = KSIGN*(MLV3 + MLV4/10.0**N2)*10.0**MLV5

      IF (KTENF1 > 1) THEN
          IF (KTENF1 /= K10PWR .AND. MLV3(2) /= 0) THEN
              CALL FMIM(KTENF1,MA)
              K10PWR = KTENF1
          ENDIF
          IF (MLV3(2) == 0) THEN
              CALL FMIM(KF1,MLV3)
          ELSE
              NDIG = INT(MAX(M2,MIN(MLV3(1)+MA(1),MNDSV1)))
              CALL FMMPY2_R1(MLV3,MA)
              NDIG = NDSAV1
              CALL FMIM(KF1,MLV2)
              NDIG = INT(MAX(M2,MIN(MAX(MLV3(1),MLV2(1))+1,MNDSV1)))
              IF (KF1 /= 0) CALL FMADD2_R1(MLV3,MLV2)
              NDIG = NDSAV1
          ENDIF
      ENDIF
      IF (KTENF2 > 1) THEN
          IF (KTENF2 /= K10PWR .AND. MLV4(2) /= 0) THEN
              CALL FMIM(KTENF2,MA)
              K10PWR = KTENF2
          ENDIF
          IF (MLV4(2) == 0) THEN
              CALL FMIM(KF2,MLV4)
          ELSE
              NDIG = INT(MAX(M2,MIN(MLV4(1)+MA(1),MNDSV1)))
              CALL FMMPY2_R1(MLV4,MA)
              NDIG = NDSAV1
              CALL FMIM(KF2,MLV2)
              NDIG = INT(MAX(M2,MIN(MAX(MLV4(1),MLV2(1))+1,MNDSV1)))
              IF (KF2 /= 0) CALL FMADD2_R1(MLV4,MLV2)
              NDIG = NDSAV1
          ENDIF
      ENDIF
      IF (KTENEX > 1) THEN
          IF (KTENEX /= K10PWR .AND. MLV5(2) /= 0) THEN
              CALL FMIM(KTENEX,MA)
              K10PWR = KTENEX
          ENDIF
          IF (MLV5(2) == 0) THEN
              CALL FMIM(KEXP,MLV5)
          ELSE
              NDIG = INT(MAX(M2,MIN(MLV5(1)+MA(1),MNDSV1)))
              CALL FMMPY2_R1(MLV5,MA)
              NDIG = NDSAV1
              CALL FMIM(KEXP,MLV2)
              NDIG = INT(MAX(M2,MIN(MAX(MLV5(1),MLV2(1))+1,MNDSV1)))
              IF (KEXP /= 0) CALL FMADD2_R1(MLV5,MLV2)
              NDIG = NDSAV1
          ENDIF
      ENDIF

      IF (KSIGNX == -1 .AND. MLV5(1) /= MUNKNO .AND. MLV5(2) /= 0)  &
          MLV5(-1) = -MLV5(-1)
      IF (MLV4(2) /= 0) THEN
          CALL FMIM(10,MLV2)
          K = N2
          IF (MOD(K,2) == 0) THEN
              CALL FMIM(1,MA)
          ELSE
              CALL FMEQ(MLV2,MA)
          ENDIF

  120     K = K/2
          NDIG = INT(MAX(M2,MIN(2*MLV2(1),MNDSV1)))
          CALL FMSQR2_R1(MLV2)
          IF (MOD(K,2) == 1) THEN
              NDIG = INT(MAX(M2,MIN(MLV2(1)+MA(1),MNDSV1)))
              CALL FMMPY2_R2(MLV2,MA)
          ENDIF
          IF (K > 1) GO TO 120
          NDIG = NDSAV1
          CALL FMDIV2_R1(MLV4,MA)
      ENDIF
      IF (MLV5(2) /= 0) THEN
          CALL FMIM(10,MLV2)
          KWRNSV = KWARN
          KWARN = 0
          CALL FMMI(MLV5,KEXP)
          KWARN = KWRNSV
          IF (KFLAG /= 0) GO TO 160
          K = ABS(KEXP)
          IF (MOD(K,2) == 0) THEN
              CALL FMIM(1,MLV5)
          ELSE
              CALL FMEQ(MLV2,MLV5)
          ENDIF

  130     K = K/2
          NDIG = INT(MAX(M2,MIN(2*MLV2(1),MNDSV1)))
          CALL FMSQR2_R1(MLV2)
          IF (MOD(K,2) == 1) THEN
              NDIG = INT(MAX(M2,MIN(MLV2(1)+MLV5(1),MNDSV1)))
              CALL FMMPY2_R2(MLV2,MLV5)
          ENDIF
          IF (K > 1) GO TO 130
          NDIG = NDSAV1
          IF (KEXP < 0) THEN
              CALL FMIM(1,MLV2)
              CALL FMDIV2_R2(MLV2,MLV5)
          ENDIF
      ENDIF
      CALL FMADD2(MLV3,MLV4,MA)
      IF (MLV5(2) /= 0) CALL FMMPY2_R1(MA,MLV5)
      IF (KSIGN == -1 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -MA(-1)
  140 CALL FMEQ2_R1(MA,NDIG,NDSAVE)
      IF (MA(1) == MUNKNO) GO TO 160

  150 NDIG = NDSAVE
      KACCSW = KASAVE
      KROUND = KRSAVE
      MXEXP = MXSAV1
      MXEXP2 = MXSAV2
      IF (KFLAG == 1) KFLAG = 0
      MA(0) = NINT(NDIG*ALOGM2)
      IF (MA(2) == 0) MA(-1) = 1
      NCALL = NCALL - 2
      RETURN

!             Error in converting the number.

  160 CALL FMIM(0,MA)
      MA(1) = MUNKNO
      MA(2) = 1
      MA(0) = NINT(NDIG*ALOGM2)
      KFLAG = -7
      NCALL = NCALL - 1
      CALL FMWARN
      NCALL = NCALL + 1
      GO TO 150
      END SUBROUTINE FMINP

      SUBROUTINE FMINP2(MA,LINE,KSTART,KSTOP,JTRANS,KPOWER)

!  Internal routine for input conversion for a power of ten MBASE.

      USE FMVALS
      IMPLICIT NONE

      INTEGER KSTART,KSTOP,KPOWER,JTRANS(8,4)
      CHARACTER LINE(KSTOP)
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      INTEGER J,JSTATE,KDFLAG,KEXP,KF1,KF1DIG,KF2,KF2DIG,KF2PT,KNZDIG,  &
              KPT,KSHIFT,KSIGN,KSIGNX,KTYPE,KVAL,LARGE

      JSTATE = 1
      KDFLAG = 0
      KSIGN = 1
      KSIGNX = 1
      KF1 = 0
      KNZDIG = 0
      KF1DIG = 0
      KF2 = 0
      KF2DIG = 0
      KF2PT = 2
      KEXP = 0
      LARGE = INT(INTMAX/10)

!             Scan the number.

      DO J = KSTART, KSTOP
         IF (LINE(J) == ' ') CYCLE
         KPT = ICHAR(LINE(J))
         IF (KPT < LHASH1 .OR. KPT > LHASH2) THEN
             WRITE (KW,  &
                "(/' Error in input conversion.'/"                        //  &
                "' ICHAR function was out of range for the current',"     //  &
                "' dimensions.'/' ICHAR(''',A,''') gave the value ',"     //  &
                "I12,', which is outside the currently'/' dimensioned',"  //  &
                "' bounds of (',I5,':',I5,') for variables KHASHT ',"     //  &
                "'and KHASHV.'/' Re-define the two parameters ',"         //  &
                "'LHASH1 and LHASH2 so the dimensions will'/' contain',"  //  &
                "' all possible output values from ICHAR.'//)"                &
                   ) LINE(J),KPT,LHASH1,LHASH2
             KTYPE = 5
             KVAL  = 0
         ELSE
             KTYPE = KHASHT(KPT)
             KVAL  = KHASHV(KPT)
         ENDIF

         IF (KTYPE >= 5) GO TO 110

         JSTATE = JTRANS(JSTATE,KTYPE)

         SELECT CASE (JSTATE)

!             State 2.  Sign of the number.

         CASE (2)
             KSIGN = KVAL

!             State 3.  Digits before a decimal point.

         CASE (3)
             KDFLAG = 1
             KF1 = 10*KF1 + KVAL
             IF (KVAL > 0 .OR. KNZDIG /= 0) THEN
                 KNZDIG = 1
                 KF1DIG = KF1DIG + 1
             ENDIF
             IF (KF1DIG == KPOWER) THEN
                 MLV3(1) = MLV3(1) + 1
                 IF (MLV3(1) < NDIG) MLV3(INT(MLV3(1))+1) = KF1
                 KF1 = 0
                 KF1DIG = 0
             ENDIF

!             State 4.  Decimal point

         CASE (4)
             CYCLE

!             State 5.  Digits after a decimal point.

         CASE (5)
             KDFLAG = 1
             IF (KF2PT > NDIG+1) CYCLE
             KF2 = 10*KF2 + KVAL
             KF2DIG = KF2DIG + 1
             IF (KF2DIG == KPOWER) THEN
                 MLV4(KF2PT) = KF2
                 IF (KF2 == 0 .AND. KF2PT == 2) THEN
                     MLV4(1) = MLV4(1) - 1
                 ELSE
                     KF2PT = KF2PT + 1
                 ENDIF
                 KF2 = 0
                 KF2DIG = 0
             ENDIF

!             State 6.  Precision indicator.

         CASE (6)
             IF (KDFLAG == 0 .AND. KESWCH == 1) CALL FMIM(1,MLV3)

!             State 7.  Sign of the exponent.

         CASE (7)
             KSIGNX = KVAL

!             State 8.  Digits of the exponent.

         CASE (8)
             IF (KEXP >= LARGE) THEN
                 IF (MLV3(2) == 0 .AND. MLV4(2) == 0) THEN
                     CALL FMIM(0,MA)
                     RETURN
                 ENDIF
                 CALL FMIM(0,MA)
                 IF (KSIGNX == 1) THEN
                     MA(1) = MEXPOV
                     KFLAG = -4
                 ELSE
                     MA(1) = MEXPUN
                     KFLAG = -4
                 ENDIF
                 MA(2) = 1
                 MA(-1) = KSIGN
                 MA(0) = NINT(NDIG*ALOGM2)
                 NCALL = NCALL - 1
                 CALL FMWARN
                 NCALL = NCALL + 1
                 RETURN
             ENDIF
             KEXP = 10*KEXP + KVAL

         CASE DEFAULT
             GO TO 110

         END SELECT

      ENDDO

!             Form the number and return.
!             MA = KSIGN*(MLV3 + MLV4)*10.0**(KSIGNX*KEXP)

      IF (KF1DIG /= 0) THEN
          MLV3(1) = MLV3(1) + 1
          KSHIFT = 10**(KPOWER-KF1DIG)
          IF (MLV3(1) < NDIG) MLV3(INT(MLV3(1))+1) = KF1*KSHIFT
          IF (KSHIFT > 1) THEN
              CALL FMDIVN_R1(MLV3,KSHIFT)
          ENDIF
      ENDIF

      IF (KF2DIG /= 0) THEN
          KSHIFT = 10**(KPOWER-KF2DIG)
          MLV4(KF2PT) = KF2*KSHIFT
      ENDIF
      IF (MLV4(2) == 0) MLV4(1) = 0

      IF (KEXP /= 0) THEN
          IF (KSIGNX == 1) THEN
              MLV5(1) = INT(KEXP/KPOWER) + 1
              MLV5(2) = 10**(MOD(KEXP,KPOWER))
          ELSE
              MLV5(1) = -INT((KEXP-1)/KPOWER)
              KSHIFT = 10**(MOD(KEXP,KPOWER))
              IF (KSHIFT > 1) THEN
                  MLV5(2) = MBASE/KSHIFT
              ELSE
                  MLV5(2) = 1
              ENDIF
          ENDIF
      ENDIF

      CALL FMADD2(MLV3,MLV4,MA)
      IF (KEXP > 0) CALL FMMPY2_R1(MA,MLV5)
      MA(-1) = KSIGN

      RETURN

!             Error in converting the number.

  110 CALL FMIM(0,MA)
      MA(1) = MUNKNO
      MA(2) = 1
      MA(-1) = 1
      MA(0) = NINT(NDIG*ALOGM2)
      RETURN
      END SUBROUTINE FMINP2

      SUBROUTINE FMINT(MA,MB)

!  MB = INT(MA)

!  The integer part of MA is computed and returned in MB as a multiple
!  precision floating point number.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MACCA,MACMAX
      INTEGER J,KA,KB,KRESLT,N1

      IF (MBLOGS /= MBASE) CALL FMCONS
      MACCA = MA(0)
      KFLAG = 0
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMINT '
      IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
      IF (ABS(MA(1)) > MEXPAB) THEN
          CALL FMARGS('FMINT ',1,MA,MB,KRESLT)
          IF (KRESLT /= 0) THEN
              CALL FMRSLT(MA,MA,MB,KRESLT)
              IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
              NCALL = NCALL - 1
              RETURN
          ENDIF
      ENDIF

      N1 = NDIG + 1

!             If MA is less than one in magnitude, return zero.

      IF (MA(1) <= 0) THEN
          DO J = 1, N1
             MB(J) = 0
          ENDDO
          GO TO 110
      ENDIF

!             If the radix point is off the right end of MA then MA is
!             already an integer.  Return MA.

      IF (MA(1) >= NDIG) THEN
          DO J = 1, N1
             MB(J) = MA(J)
          ENDDO
          GO TO 110
      ENDIF

!             Here MA has both integer and fraction parts.  Replace
!             the digits right of the radix point by zeros.

      KA = INT(MA(1)) + 2
      KB = KA - 1
      DO J = 1, KB
         MB(J) = MA(J)
      ENDDO

      DO J = KA, N1
         MB(J) = 0
      ENDDO

  110 IF (KACCSW == 1) THEN
          MACMAX = NINT((NDIG-1)*ALOGM2 +  &
                   LOG(REAL(ABS(MB(2))+1))/0.69315)
          MB(0) = MIN(MACCA,MACMAX)
      ELSE
          MB(0) = MACCA
      ENDIF
      MB(-1) = MA(-1)
      IF (MB(2) == 0) MB(-1) = 1
      IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMINT

      SUBROUTINE FMIPWR(MA,IVAL,MB)

!  MB = MA ** IVAL

!  Raise an FM number to an integer power.
!  The binary multiplication method used requires an average of
!  1.5 * LOG2(IVAL) multiplications.  MA may be negative.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER IVAL
      REAL (KIND(1.0D0)) :: MACCA,MACMAX
      INTEGER JSIGN,K,KWRNSV,NDSAVE
      REAL XVAL

      IF (MBLOGS /= MBASE) CALL FMCONS
      KFLAG = 0
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMIPWR'
      IF (NTRACE /= 0) THEN
          CALL FMNTR(2,MA,MA,1,1)
          CALL FMNTRI(2,IVAL,0)
      ENDIF

!             Check for special cases.

      IF (MA(1) == MUNKNO .OR. (IVAL <= 0 .AND. MA(2) == 0)) THEN
          KFLAG = -4
          IF (IVAL <= 0 .AND. MA(2) == 0) CALL FMWARN
          CALL FMST2M('UNKNOWN',MB)
          IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF

      IF (IVAL == 0) THEN
          CALL FMIM(1,MB)
          IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF

      IF (ABS(IVAL) == 1) THEN
          KWRNSV = KWARN
          KWARN = 0
          IF (IVAL == 1) THEN
              CALL FMEQ(MA,MB)
          ELSE
              CALL FMIM(1,M01)
              CALL FMDIV(M01,MA,MB)
          ENDIF
          IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
          NCALL = NCALL - 1
          KWARN = KWRNSV
          RETURN
      ENDIF

      IF (MA(2) == 0) THEN
          CALL FMEQ(MA,MB)
          IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF

      IF (MA(1) == MEXPOV) THEN
          JSIGN = 1
          IF (MA(-1) < 0) JSIGN = -1
          CALL FMIM(0,MB)
          IF (IVAL > 0) THEN
              CALL FMST2M('OVERFLOW',MB)
              MB(-1) = JSIGN**MOD(IVAL,2)
              KFLAG = -5
          ELSE
              CALL FMST2M('UNDERFLOW',MB)
              MB(-1) = JSIGN**MOD(IVAL,2)
              KFLAG = -6
          ENDIF
          IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF

      IF (MA(1) == MEXPUN) THEN
          JSIGN = 1
          IF (MA(-1) < 0) JSIGN = -1
          CALL FMIM(0,MB)
          IF (IVAL > 0) THEN
              CALL FMST2M('UNDERFLOW',MB)
              MB(-1) = JSIGN**MOD(IVAL,2)
              KFLAG = -6
          ELSE
              CALL FMST2M('OVERFLOW',MB)
              MB(-1) = JSIGN**MOD(IVAL,2)
              KFLAG = -5
          ENDIF
          IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF

!             Increase the working precision.

      NDSAVE = NDIG
      IF (NCALL == 1) THEN
          XVAL = ABS(IVAL)
          K = INT((5.0*REAL(DLOGTN) + LOG(XVAL))/ALOGMB + 2.0)
          NDIG = MAX(NDIG+K,2)
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
          ENDIF
      ELSE
          XVAL = ABS(IVAL)
          IF (XVAL > 10.0 .OR. REAL(MBASE) <= 999.0) THEN
              K = INT(LOG(XVAL)/ALOGMB + 1.0)
              NDIG = NDIG + K
          ENDIF
      ENDIF
      IF (NDIG > NDG2MX) THEN
          IF (NCALL == 1) THEN
              KFLAG = -9
              CALL FMWARN
              NDIG = NDSAVE
              CALL FMST2M('UNKNOWN',MB)
              IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
              NCALL = NCALL - 1
              RETURN
          ELSE
              NDIG = NDG2MX
          ENDIF
      ENDIF

!             Initialize.

      K = ABS(IVAL)
      KWRNSV = KWARN
      KWARN = 0
      MACCA = MA(0)
      CALL FMEQ2(MA,M01,NDSAVE,NDIG)
      M01(0) = NINT(NDIG*ALOGM2)

!             Handle small exponents by hand.

      IF (K == 2) THEN
          CALL FMSQR(M01,MB)
          GO TO 120
      ENDIF
      IF (K == 3) THEN
          CALL FMSQR(M01,MB)
          CALL FMMPY_R1(MB,M01)
          GO TO 120
      ENDIF
      IF (K == 4) THEN
          CALL FMSQR(M01,MB)
          CALL FMSQR_R1(MB)
          GO TO 120
      ENDIF
      IF (K == 5) THEN
          CALL FMSQR(M01,MB)
          CALL FMSQR_R1(MB)
          CALL FMMPY_R1(MB,M01)
          GO TO 120
      ENDIF

      IF (MOD(K,2) == 0) THEN
          CALL FMI2M(1,MB)
      ELSE
          CALL FMEQ(M01,MB)
      ENDIF

!             This is the multiplication loop.

  110 K = K/2
      CALL FMSQR_R1(M01)
      IF (MOD(K,2) == 1) CALL FMMPY_R2(M01,MB)
      IF (K > 1) GO TO 110

!             Invert if the exponent is negative.

  120 IF (IVAL < 0) THEN
          CALL FMI2M(1,M01)
          CALL FMDIV_R2(M01,MB)
      ENDIF
      KWARN = KWRNSV

!             Round the result and return.

      CALL FMEQ2_R1(MB,NDIG,NDSAVE)
      NDIG = NDSAVE
      IF (KACCSW == 1) THEN
          MACMAX = NINT((NDSAVE-1)*ALOGM2 +  &
                   LOG(REAL(ABS(MB(2))+1))/0.69315)
          MB(0) = MIN(MB(0),MACCA,MACMAX)
      ELSE
          MB(0) = MACCA
      ENDIF
      IF (KFLAG < 0) CALL FMWARN
      IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMIPWR

      SUBROUTINE FMLG10(MA,MB)

!  MB = LOG10(MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
      INTEGER J,K,KASAVE,KOVUN,KRESLT,NDSAVE

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0 .OR. MA(-1) < 0) THEN
          CALL FMENTR('FMLG10',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMLG10'
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52-1,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,MB,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      MACCA = MA(0)
      CALL FMEQ2(MA,MB,NDSAVE,NDIG)
      MB(0) = NINT(NDIG*ALOGM2)

      CALL FMLN(MB,M13)
      CALL FMEQ(M13,MB)
      IF (MBASE /= MBSLI .OR. NDIG > NDIGLI) THEN
          CALL FMLNI(10,M03)
      ELSE
          CALL FMADD(MLN1,MLN3,M03)
      ENDIF
      CALL FMDIV_R1(MB,M03)

!             Round the result and return.

      MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
      MB(0) = MIN(MB(0),MACCA,MACMAX)
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMLG10

      SUBROUTINE FMLN(MA,MB)

!  MB = LOG(MA)     (Natural logarithm)

      USE FMVALS
      IMPLICIT NONE

      DOUBLE PRECISION Y
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER NSTACK(19)
      REAL (KIND(1.0D0)) :: MA1,MACCA,MACMAX,MXSAVE
      INTEGER IEXTRA,IVAL,J,K,K2,K2EXP,KASAVE,KBOT,KM1,KOVUN,KRESLT,  &
              KSCALE,KST,KWRNSV,LAST,N1,N3,NDSAV1,NDSAVE,NDSV
      REAL X

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0 .OR. MA(-1) < 0) THEN
          CALL FMENTR('FMLN  ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMLN  '
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52-1,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,MB,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

!             If MA is close to 1, use the Taylor series:
!                   LN(1+X) = X - X**2/2 + X**3/3 - ...
!             This is faster for small X and avoids cancellation error.

!             This method is faster for moderate sized NDIG, but is
!             asymptotically slower by a factor of NDIG**(2/3) than
!             using Newton and FMEXP.  For MBASE=10,000 the Taylor
!             series is faster for NDIG less than about 150 (and is
!             used only when MA is between .9999 and 1.0001).

      IF (MA(1) == 0 .OR. MA(1) == 1) THEN
          X = REAL(MBASE)
          X = X**(INT(MA(1))-1)*(REAL(MA(2))+REAL(MA(3))/X)
      ELSE
          X = 2.0
      ENDIF
      IF (X > 0.9999 .AND. X <= 1.0001) THEN
          MACCA = MA(0)
          CALL FMEQ2(MA,M03,NDSAVE,NDIG)
          M03(0) = NINT(NDIG*ALOGM2)

          CALL FMI2M(-1,M01)
          CALL FMADD_R1(M03,M01)

!             The sum will be done as two concurrent series.

          NDSAV1 = NDIG
          CALL FMEQ(M03,M04)
          CALL FMDIVI(M03,2,M05)
          CALL FMSQR(M03,MB)
          CALL FMEQ(M03,M02)
          KBOT = 2

  110     KBOT = KBOT + 1
          CALL FMMPY_R1(M02,MB)
          CALL FMDIVI(M02,KBOT,M01)
          NDIG = NDSAV1
          CALL FMADD_R1(M04,M01)
          NDIG = MAX(2,NDSAV1 - INT(M04(1)-M01(1)))
          KBOT = KBOT + 1
          CALL FMDIVI(M02,KBOT,M01)
          NDIG = NDSAV1
          CALL FMADD_R1(M05,M01)
          NDIG = MAX(2,NDSAV1 - INT(M04(1)-M01(1)))
          IF (KFLAG /= 1) GO TO 110

          NDIG = NDSAV1
          CALL FMMPY_R1(M05,M03)
          CALL FMSUB(M04,M05,MB)
          GO TO 140
      ENDIF

      MA1 = MA(1)
      MACCA = MA(0)
      CALL FMEQ2(MA,M05,NDSAVE,NDIG)
      M05(0) = NINT(NDIG*ALOGM2)

!             Compute IEXTRA, the number of extra digits required.

      CALL FMI2M(1,M04)
      CALL FMSUB_R1(M04,M05)
      IEXTRA = MAX(0-INT(M04(1)),0)
      IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
          CALL FMEQ2_R1(M05,NDIG,NDIG+IEXTRA)
      ENDIF
      NDIG = NDIG + IEXTRA
      IF (NDIG > NDG2MX) THEN
          IF (NCALL == 1) THEN
              KFLAG = -9
              CALL FMWARN
              NDIG = NDSAVE
              CALL FMST2M('UNKNOWN',MB)
              DO J = -1, NDIG+1
                 M01(J) = MB(J)
              ENDDO
              CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
              RETURN
          ELSE
              CALL FMEQ2_R1(M05,NDIG-IEXTRA,NDG2MX)
              NDIG = NDG2MX
          ENDIF
      ENDIF

!             Check to see if the argument is a small integer.
!             If so use FMLNI.

      KM1 = 0

      KWRNSV = KWARN
      KWARN = 0
      CALL FMM2I(M05,IVAL)
      KWARN = KWRNSV
      IF (KFLAG == 0 .AND. IVAL < MXBASE) THEN
          CALL FMLNI(IVAL,MB)
          GO TO 140
      ENDIF

!             See if the argument can be scaled to a small integer.

      N3 = NDIG + 3
      N1 = NDIG + 1
      DO J = 2, N1
         IF (M05(N3-J) /= 0) THEN
             LAST = N3 - J - 1
             GO TO 120
         ENDIF
      ENDDO

  120 KSCALE = INT(MA1) - LAST
      M05(1) = LAST
      KWRNSV = KWARN
      KWARN = 0
      CALL FMM2I(M05,IVAL)
      KWARN = KWRNSV
      IF (KFLAG == 0 .AND. IVAL < MXBASE) THEN
          CALL FMLNI(IVAL,M04)
          IF (IVAL == 1) KM1 = 1
          K2EXP = 0
          GO TO 130
      ENDIF

!             For the non-integer case, scale the argument to lie
!             between e/2 and e to speed up the calls to FMEXP.

      M05(1) = 1
      KSCALE = INT(MA1) - 1
      CALL FMM2DP(M05,Y)
      K2EXP = INT(LOG(2.0*REAL(Y)/2.71828)/0.693147)
      IF (Y < 1.359141) THEN
          K2EXP = -1
          CALL FMMPYI_R1(M05,2)
          Y = 2.0D0*Y
      ELSE
          K2 = 2**K2EXP
          CALL FMDIVI_R1(M05,K2)
          Y = Y/K2
      ENDIF

!             Generate the initial approximation.

      Y = LOG(Y)
      CALL FMDPM(Y,M04)
      CALL FMDIG(NSTACK,KST)

!             Newton iteration.

      DO J = 1, KST
         NDIG = NSTACK(J)
         CALL FMEXP(M04,MB)
         CALL FMSUB(M05,MB,M02)
         CALL FMDIV_R2(M02,MB)
         CALL FMADD_R1(M04,MB)
      ENDDO
      M04(0) = NINT(NDIG*ALOGM2)

!             Compute LN(MBASE**KSCALE).

  130 IF ((MBSLB /= MBASE .OR. NDIGLB < NDIG) .AND. KSCALE /= 0) THEN
          NDSV = NDIG
          NDIG = MIN(NDIG+2,NDG2MX)
          CALL FMLNI(INT(MBASE),MLBSAV)
          MBSLB = MBASE
          NDIGLB = NDIG
          IF (ABS(MLBSAV(1)) > 10) NDIGLB = 0
          NDIG = NDSV
      ENDIF

      IF (KSCALE /= 0 .AND. KM1 == 0) THEN
          CALL FMMPYI(MLBSAV,KSCALE,MB)
          CALL FMADD_R2(M04,MB)
      ELSE IF (KSCALE /= 0 .AND. KM1 == 1) THEN
          CALL FMMPYI(MLBSAV,KSCALE,MB)
      ELSE IF (KSCALE == 0 .AND. KM1 == 0) THEN
          CALL FMEQ(M04,MB)
      ELSE IF (KSCALE == 0 .AND. KM1 == 1) THEN
          CALL FMI2M(0,MB)
      ENDIF

      IF (K2EXP /= 0) THEN
          IF (MBASE /= MBSLI .OR. NDIG > NDIGLI) THEN
              CALL FMLNI(2,M04)
          ENDIF
          CALL FMMPYI(MLN1,K2EXP,M04)
          CALL FMADD_R1(MB,M04)
      ENDIF

!             Round the result and return.

  140 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
      MB(0) = MIN(MB(0),MACCA,MACMAX)
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMLN

      SUBROUTINE FMLNI(IVAL,MA)

!  MA = LOG(IVAL)

!  Compute the natural logarithm of an integer IVAL.

!  If IVAL has only powers of 2, 3, 5, and 7 in its factorization then
!  FMLNI is faster than FMLN.  Otherwise, if IVAL >= MXBASE (i.e., IVAL
!  does not fit in 1/2 word) then FMLN is usually faster.

!  Use FMLN instead of FMLNI if 10*IVAL would cause integer overflow.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER IVAL
      CHARACTER(155) :: STRING
      INTEGER INT2,J2,J3,J5,J7,JTEMP2,JTEMP3,JTEMP5,JTEMP7,K,K2,K3,  &
              K5,K7,KASAVE,KDELTA,LAST,ND,NDMB,NDSAVE,NDSV,NT
      REAL XVAL

      IF (MBLOGS /= MBASE) CALL FMCONS
      KFLAG = 0
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMLNI '
      IF (NTRACE /= 0) CALL FMNTRI(2,IVAL,1)

!             Check for special cases.

      IF (IVAL <= 0) THEN
          KFLAG = -4
          CALL FMWARN
          CALL FMST2M('UNKNOWN',MA)
          IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF

      IF (IVAL == 1) THEN
          CALL FMI2M(0,MA)
          IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF

!             Increase the working precision.

      NDSAVE = NDIG
      IF (NCALL == 1) THEN
          K = NGRD52
          NDIG = MAX(NDIG+K,2)
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWARN
              NDIG = NDSAVE
              CALL FMST2M('UNKNOWN',MA)
              IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
              NCALL = NCALL - 1
              RETURN
          ENDIF
      ENDIF
      KASAVE = KACCSW
      KACCSW = 0

!             Find integers K2, K3, K5, and K7 such that
!                NT = 2**K2 * 3**K3 * 5**K5 * 7**K7
!             is a good approximation of IVAL.
!             KDELTA = ABS(IVAL - NT).

      INT2 = IVAL
      IF (IVAL > INTMAX/100) INT2 = IVAL/100
      KDELTA = INT2
      NT = 0
      K2 = 0
      K3 = 0
      K5 = 0
      K7 = 0

!             Start the search loop.

      XVAL = INT2
      LAST = INT(LOG(DBLE(XVAL))/DLOGTW + 2.0D0)

      JTEMP7 = 1
      DO J7 = 1, LAST
         IF (JTEMP7 > INT2 .AND.  &
             ABS(JTEMP7-INT2) > KDELTA) GO TO 140

         JTEMP5 = JTEMP7
         DO J5 = 1, LAST
            IF (JTEMP5 > INT2 .AND.  &
                ABS(JTEMP5-INT2) > KDELTA) GO TO 130

            JTEMP3 = JTEMP5
            DO J3 = 1, LAST
               IF (JTEMP3 > INT2 .AND.  &
                   ABS(JTEMP3-INT2) > KDELTA) GO TO 120

               JTEMP2 = JTEMP3
               DO J2 = 1, LAST
                  IF (ABS(JTEMP2-INT2) <= KDELTA) THEN
                      IF (ABS(JTEMP2-INT2) == KDELTA .AND.  &
                          JTEMP2 < INT2) GO TO 110
                      KDELTA = ABS(JTEMP2-INT2)
                      NT = JTEMP2
                      K2 = J2 - 1
                      K3 = J3 - 1
                      K5 = J5 - 1
                      K7 = J7 - 1
                      IF (KDELTA == 0) GO TO 140
                  ENDIF
                  IF (JTEMP2 > INT2) GO TO 110

                  JTEMP2 = 2*JTEMP2
               ENDDO

  110          JTEMP3 = 3*JTEMP3
            ENDDO

  120       JTEMP5 = 5*JTEMP5
         ENDDO

  130    JTEMP7 = 7*JTEMP7
      ENDDO

!             If IVAL was too close to the integer overflow limit,
!             restore NT to an approximation of IVAL.

  140 IF (INT2 /= IVAL) THEN
          IF (NT <= INT2) THEN
              NT = NT*100
              K2 = K2 + 2
              K5 = K5 + 2
          ELSE IF (NT <= IVAL/98) THEN
              NT = NT*98
              K2 = K2 + 1
              K7 = K7 + 2
          ELSE
              NT = NT*70
              K2 = K2 + 1
              K5 = K5 + 1
              K7 = K7 + 1
          ENDIF
      ENDIF

!             End of the search.  Now compute LN(NT) as a linear
!             combination of LN(2), LN(3), LN(5), and LN(7).

      IF (MBASE /= MBSLI .OR. NDIG > NDIGLI) THEN
          NDMB = INT(150.0*2.302585/ALOGMB)
          IF (NDMB >= NDIG) THEN
              NDSV = NDIG
              NDIG = MIN(NDMB,NDG2MX)
              STRING = '0.693147180559945309417232121458176568075500'//  &
              '13436025525412068000949339362196969471560586332699641'//  &
              '8687542001481020570685733685520235758130557032670751635'
              CALL FMST2M(STRING,MLN1)
              STRING = '1.098612288668109691395245236922525704647490'//  &
              '55782274945173469433363749429321860896687361575481373'//  &
              '2088787970029065957865742368004225930519821052801870767'
              CALL FMST2M(STRING,MLN2)
              STRING = '1.609437912434100374600759333226187639525601'//  &
              '35426851772191264789147417898770765776463013387809317'//  &
              '9610799966303021715562899724005229324676199633616617464'
              CALL FMST2M(STRING,MLN3)
              STRING = '1.945910149055313305105352743443179729637084'//  &
              '72958186118845939014993757986275206926778765849858787'//  &
              '1526993061694205851140911723752257677786843148958095164'
              CALL FMST2M(STRING,MLN4)
              MBSLI = MBASE
              NDIGLI = NDIG
              IF (ABS(MLN1(1)) > 10 .OR. ABS(MLN2(1)) > 10 .OR.  &
                  ABS(MLN3(1)) > 10 .OR. ABS(MLN4(1)) > 10) NDIGLI = 0
          ELSE
              NDSV = NDIG
              NDIG = MIN(NDIG+2,NDG2MX)
              MBSLI = MBASE
              NDIGLI = NDIG

              CALL FMLNI2(1,126,MLN1)
              CALL FMLNI2(1,225,MLN2)
              CALL FMLNI2(1,2401,MLN3)
              CALL FMLNI2(1,4375,MLN4)

!                Get Ln(2).

              CALL FMMPYI_R1(MLN1,-72)
              CALL FMMPYI(MLN2,-27,MA)
              CALL FMADD_R1(MLN1,MA)
              CALL FMMPYI(MLN3,19,MA)
              CALL FMADD_R1(MLN1,MA)
              CALL FMMPYI(MLN4,-31,MA)
              CALL FMADD_R1(MLN1,MA)

!                Get Ln(3).

              CALL FMMPYI_R1(MLN2,-3)
              CALL FMMPYI(MLN1,19,MA)
              CALL FMADD_R1(MLN2,MA)
              CALL FMSUB_R1(MLN2,MLN3)
              CALL FMADD_R1(MLN2,MLN4)
              CALL FMDIVI_R1(MLN2,12)

!                Get Ln(5).

              CALL FMSUB_R1(MLN3,MLN1)
              CALL FMMPYI(MLN2,27,MA)
              CALL FMADD_R1(MLN3,MA)
              CALL FMMPYI(MLN4,-4,MA)
              CALL FMADD_R1(MLN3,MA)
              CALL FMDIVI_R1(MLN3,18)

!                Get Ln(7).

              CALL FMSUB_R2(MLN1,MLN4)
              CALL FMMPYI(MLN2,7,MA)
              CALL FMADD_R1(MLN4,MA)
              CALL FMMPYI(MLN3,-4,MA)
              CALL FMADD_R1(MLN4,MA)
          ENDIF
          MLN1(0) = NINT(NDIG*ALOGM2)
          MLN2(0) = MLN1(0)
          MLN3(0) = MLN1(0)
          MLN4(0) = MLN1(0)
          IF (ABS(MLN1(1)) > 10 .OR. ABS(MLN2(1)) > 10 .OR.  &
              ABS(MLN3(1)) > 10 .OR. ABS(MLN4(1)) > 10) NDIGLI = 0
          NDIG = NDSV
      ENDIF

!             If NT /= IVAL then the final step is to compute
!             LN(IVAL/NT) and then use LN(IVAL) = LN(IVAL/NT) + LN(NT).

      IF (NT /= IVAL) THEN
          ND = NT - IVAL
          CALL FMLNI2(ND,NT,MA)
      ENDIF

      CALL FMMPYI(MLN1,K2,M02)
      CALL FMMPYI(MLN2,K3,M01)
      CALL FMADD_R1(M02,M01)
      CALL FMMPYI(MLN3,K5,M01)
      CALL FMADD_R1(M02,M01)
      CALL FMMPYI(MLN4,K7,M01)
      IF (NT /= IVAL) CALL FMADD_R1(M02,MA)
      CALL FMADD(M02,M01,MA)

!             Round and move the result to MA.

      KACCSW = KASAVE
      CALL FMEQ2_R1(MA,NDIG,NDSAVE)
      NDIG = NDSAVE
      IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMLNI

      SUBROUTINE FMLNI2(INT1,INT2,MA)

!  MA = LN(1 - INT1/INT2)

!  Taylor series for computing the logarithm of a rational number
!  near 1.

      USE FMVALS
      IMPLICIT NONE

      INTEGER INT1,INT2
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER J,NDSAVE

      CALL FMI2M(INT1,M02)
      CALL FMDIVI_R1(M02,INT2)
      CALL FMEQ(M02,MA)
      NDSAVE = NDIG
      J = 1

  110 J = J + 1
      IF (INT1 /= 1) CALL FMMPYI_R1(M02,INT1)
      CALL FMDIVI_R1(M02,INT2)
      CALL FMDIVI(M02,J,M01)
      NDIG = NDSAVE
      CALL FMADD_R1(MA,M01)
      NDIG = NDSAVE - INT(MA(1)-M01(1))
      IF (NDIG < 2) NDIG = 2
      IF (KFLAG /= 1) GO TO 110

      NDIG = NDSAVE
      MA(0) = NINT(NDIG*ALOGM2)
      IF (MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -MA(-1)
      RETURN
      END SUBROUTINE FMLNI2

      SUBROUTINE FMM2DP(MA,X)

!  X = MA

!  Convert an FM number to double precision.

!  If KFLAG = -4 is returned for a value of MA that is in the range
!  of the machine's double precision number system, change the
!  definition of DPMAX in routine FMSET to reflect the current machine's
!  range.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      DOUBLE PRECISION X

      INTEGER KRESLT

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMM2DP'
      KRESLT = 0
      IF (ABS(MA(1)) > MEXPAB) THEN
          CALL FMARGS('FMM2DP',1,MA,MA,KRESLT)
      ENDIF
      IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
      IF (KRESLT /= 0) THEN

!             Here no valid result can be returned.  Set X to some
!             value that the user is likely to recognize as wrong.

          X = DBLE(RUNKNO)
          KFLAG = -4
          IF (MA(1) /= MUNKNO) CALL FMWARN
          IF (NTRACE /= 0) CALL FMNTRR(1,X,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF

      CALL FMMD(MA,X)

      IF (NTRACE /= 0) CALL FMNTRR(1,X,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMM2DP

      SUBROUTINE FMM2I(MA,IVAL)

!  IVAL = MA

!  Convert an FM number to integer.

!  KFLAG =  0 is returned if the conversion is exact.
!        = -4 is returned if MA is larger than INTMAX in magnitude.
!             IVAL = IUNKNO is returned as an indication that IVAL
!             could not be computed without integer overflow.
!        =  2 is returned if MA is smaller than INTMAX in magnitude
!             but MA is not an integer.  The next integer toward zero
!             is returned in IVAL.
!  It is sometimes convenient to call FMM2I to see if an FM number
!  can be represented as a one-word integer, by checking KFLAG upon
!  return.  To avoid an unwanted error message being printed in the
!  KFLAG=-4 case, set KWARN=0 before the call to FMM2I and reset it
!  after the call.

!  This routine performs the trace printing for the conversion.
!  FMMI is used to do the arithmetic.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER IVAL

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMM2I '
      IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)

      CALL FMMI(MA,IVAL)

      IF (NTRACE /= 0) CALL FMNTRI(1,IVAL,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMM2I

      SUBROUTINE FMM2SP(MA,X)

!  X = MA

!  Convert an FM number to single precision.

!  MA is converted and the result is returned in X.

!  If KFLAG = -4 is returned for a value of MA that is in the range
!  of the machine's single precision number system, change the
!  definition of SPMAX in routine FMSET to reflect the current machine's
!  range.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      REAL X

      DOUBLE PRECISION Y
      INTEGER KRESLT

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMM2SP'
      KRESLT = 0
      IF (ABS(MA(1)) > MEXPAB) THEN
          CALL FMARGS('FMM2SP',1,MA,MA,KRESLT)
      ENDIF
      IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
      IF (KRESLT /= 0) THEN

!             Here no valid result can be returned.  Set X to some
!             value that the user is likely to recognize as wrong.

          X = RUNKNO
          KFLAG = -4
          IF (MA(1) /= MUNKNO) CALL FMWARN
          Y = DBLE(X)
          IF (NTRACE /= 0) CALL FMNTRR(1,Y,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF

      CALL FMMD(MA,Y)
      X = REAL(Y)

      IF (NTRACE /= 0) THEN
          Y = DBLE(X)
          CALL FMNTRR(1,Y,1)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMM2SP

      SUBROUTINE FMMAX(MA,MB,MC)

!  MC = MAX(MA,MB)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      INTEGER KWRNSV
      LOGICAL FMCOMP

      KFLAG = 0
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMMAX '
      IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)

      KWRNSV = KWARN
      KWARN = 0
      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
          CALL FMST2M('UNKNOWN',MC)
          KFLAG = -4
      ELSE IF (FMCOMP(MA,'LT',MB)) THEN
          CALL FMEQ(MB,MC)
      ELSE
          CALL FMEQ(MA,MC)
      ENDIF

      KWARN = KWRNSV
      IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMMAX

      SUBROUTINE FMMD(MA,X)

!  X = MA

!  Internal routine for conversion to double precision.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      DOUBLE PRECISION X

      DOUBLE PRECISION Y,YT,XBASE,RZERO,ONE,PMAX,DLOGDP
      REAL (KIND(1.0D0)) :: MA1,MAS
      INTEGER J,KWRNSV,N1,NCASE

!             Check to see if MA is in range for single or double
!             precision.

      IF (MBLOGS /= MBASE) CALL FMCONS
      PMAX = DPMAX
      IF (NCALL > 0) THEN
          IF (NAMEST(NCALL) == 'FMM2SP') PMAX = DBLE(SPMAX)
      ENDIF
      DLOGDP = LOG(PMAX)
      MA1 = MA(1)
      NCASE = 0
      IF (DBLE(MA(1)-1)*DLOGMB > DLOGDP) THEN
          KFLAG = -4
          X = DBLE(RUNKNO)
          CALL FMWARN
          RETURN
      ELSE IF (DBLE(MA(1)+1)*DLOGMB > DLOGDP) THEN
          MA1 = MA1 - 2
          NCASE = 1
      ELSE IF (DBLE(MA(1)+1)*DLOGMB < -DLOGDP) THEN
          KFLAG = -10
          X = 0.0D0
          CALL FMWARN
          RETURN
      ELSE IF (DBLE(MA(1)-1)*DLOGMB < -DLOGDP) THEN
          MA1 = MA1 + 2
          NCASE = 2
      ENDIF

!             Try FMMI first so that small integers will be
!             converted exactly.

      KWRNSV = KWARN
      KWARN = 0
      CALL FMMI(MA,J)
      KWARN = KWRNSV
      IF (KFLAG == 0) THEN
          X = J
          RETURN
      ENDIF
      KFLAG = 0

      MAS = MA(-1)
      RZERO = 0.0D0
      ONE = 1.0D0
      N1 = NDIG + 1
      XBASE = MBASE
      X = RZERO
      Y = ONE
      DO J = 2, N1
         Y = Y/XBASE
         YT = MA(J)
         X = X + Y*YT
         YT = ONE + Y*XBASE
         IF (YT <= ONE) GO TO 110
      ENDDO

  110 X = X*XBASE**MA1
      IF (MAS < 0) X = -X

!             Check the result if it is near overflow or underflow.

      IF (NCASE == 1) THEN
          IF (X <= PMAX/(XBASE*XBASE)) THEN
              X = X*XBASE*XBASE
          ELSE
              KFLAG = -4
              X = DBLE(RUNKNO)
              CALL FMWARN
          ENDIF
      ELSE IF (NCASE == 2) THEN
          IF (X >= (1.0D0/PMAX)*XBASE*XBASE) THEN
              X = X/(XBASE*XBASE)
          ELSE
              KFLAG = -10
              X = 0.0D0
              CALL FMWARN
          ENDIF
      ENDIF
      RETURN
      END SUBROUTINE FMMD

      SUBROUTINE FMMI(MA,IVAL)

!  IVAL = MA.  Internal FM to integer conversion routine.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER IVAL

      INTEGER J,KA,KB,LARGE,N1

      KFLAG = 0
      N1 = NDIG + 1
      LARGE = INT(INTMAX/MBASE)
      IVAL = 0
      IF (MA(1) <= 0) THEN
          IF (MA(2) /= 0) KFLAG = 2
          RETURN
      ENDIF

      KB = INT(MA(1)) + 1
      IVAL = INT(ABS(MA(2)))
      IF (KB >= 3) THEN
          DO J = 3, KB
             IF (IVAL > LARGE) THEN
                 KFLAG = -4
                 IF (MA(1) /= MUNKNO) CALL FMWARN
                 IVAL = IUNKNO
                 RETURN
             ENDIF
             IF (J <= N1) THEN
                 IVAL = IVAL*INT(MBASE)
                 IF (IVAL > INTMAX-MA(J)) THEN
                     KFLAG = -4
                     IF (MA(1) /= MUNKNO) CALL FMWARN
                     IVAL = IUNKNO
                     RETURN
                 ELSE
                     IVAL = IVAL + INT(MA(J))
                 ENDIF
             ELSE
                 IVAL = IVAL*INT(MBASE)
             ENDIF
          ENDDO
      ENDIF

      IF (MA(-1) < 0) IVAL = -IVAL

!             Check to see if MA is an integer.

      KA = KB + 1
      IF (KA <= N1) THEN
          DO J = KA, N1
             IF (MA(J) /= 0) THEN
                 KFLAG = 2
                 RETURN
             ENDIF
          ENDDO
      ENDIF

      RETURN
      END SUBROUTINE FMMI

      SUBROUTINE FMMIN(MA,MB,MC)

!  MC = MIN(MA,MB)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      INTEGER KWRNSV
      LOGICAL FMCOMP

      KFLAG = 0
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMMIN '
      IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)

      KWRNSV = KWARN
      KWARN = 0
      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
          CALL FMST2M('UNKNOWN',MC)
          KFLAG = -4
      ELSE IF (FMCOMP(MA,'GT',MB)) THEN
          CALL FMEQ(MB,MC)
      ELSE
          CALL FMEQ(MA,MC)
      ENDIF

      KWARN = KWRNSV
      IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMMIN

      SUBROUTINE FMMOD(MA,MB,MC)

!  MC = MA(MOD MB).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MVB,MVC,MVY,MVZ,MXSAVE
      INTEGER J,K,KASAVE,KB,KE,KN,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV
      LOGICAL FMCOMP

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB) THEN
          CALL FMENTR('FMMOD ',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMMOD '
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52-1,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MB,MC,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF
      KWRNSV = KWARN
      KWARN = 0
      MACCA = MA(0)
      MACCB = MB(0)

      IF (MB(1) > MA(1) .AND. MB(2) /= 0) THEN
          CALL FMEQ2(MA,M01,NDSAVE,NDIG)
          M01(0) = NINT(NDIG*ALOGM2)
      ELSE

!             Special cases when MB is a small integer.

          CALL FMEQ2(MA,M02,NDSAVE,NDIG)
          M02(0) = NINT(NDIG*ALOGM2)
          CALL FMEQ2(MB,M03,NDSAVE,NDIG)
          M03(0) = NINT(NDIG*ALOGM2)
          M02(-1) = 1
          M03(-1) = 1

          CALL FMM2I(M03,KB)
          IF (KFLAG == 0 .AND. KB < MXBASE) THEN
              IF (KB == 1 .OR. KB == -1) THEN
                  IF (M02(1) >= NDIG) THEN
                      CALL FMI2M(0,M01)
                      GO TO 130
                  ELSE
                      CALL FMINT(M02,M03)
                      CALL FMSUB(M02,M03,M01)
                      IF (MA(-1) < 0 .AND. M01(1) /= MUNKNO .AND.  &
                          M01(2) /= 0) M01(-1) = -M01(-1)
                      GO TO 130
                  ENDIF
              ELSE IF (M02(1) == MEXPOV .OR. KB == 0) THEN
                  KFLAG = -4
                  KWARN = KWRNSV
                  KACCSW = KASAVE
                  MXEXP = MXSAVE
                  CALL FMWARN
                  NDIG = NDSAVE
                  CALL FMST2M('UNKNOWN',MC)
                  IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ELSE IF (M02(1) > NDIG.AND.MOD(INT(MBASE),KB) == 0) THEN
                  CALL FMI2M(0,M01)
                  GO TO 130
              ENDIF
              IF (M02(1) < NDIG) THEN
                  DO J = INT(M02(1))+1, NDIG+1
                     IF (M02(J) /= 0) GO TO 120
                  ENDDO
              ENDIF
              KE = MIN(INT(M02(1)),NDIG)
              MVB = KB
              MVC = MOD(M02(2),MVB)
              DO J = 3, KE+1
                 MVC = MOD(MVC*MBASE+M02(J),MVB)
              ENDDO
              IF (MVC == 0) THEN
                   CALL FMI2M(0,M01)
                   GO TO 130
              ENDIF
              KN = INT(M02(1)) - KE
              MVY = MOD(MBASE,MVB)
              MVZ = 1
              IF (MOD(KN,2) == 1) MVZ = MVY

              IF (MVY /= 1) THEN
  110             KN = KN/2
                  MVY = MOD(MVY*MVY,MVB)
                  IF (MOD(KN,2) == 1) MVZ = MOD(MVZ*MVY,MVB)
                  IF (KN > 1) GO TO 110
              ENDIF
              MVZ = MOD(MVZ*MVC,MVB)
              KE = INT(MVZ)
              CALL FMI2M(KE,M01)
              IF (MA(-1) < 0 .AND. M01(1) /= MUNKNO .AND.  &
                  M01(2) /= 0) M01(-1) = -M01(-1)
              GO TO 130
          ENDIF

!             General case.

  120     IF (MA(2) /= 0) THEN
              NDIG = NDIG + INT(MA(1)-MB(1))
          ENDIF
          IF (NDIG > NDG2MX .OR. MB(2) == 0) THEN
              KFLAG = -9
              IF (MA(1) == MEXPOV .OR. MB(1) == MEXPUN .OR. MB(2) == 0)  &
                  KFLAG = -4
              KWARN = KWRNSV
              KACCSW = KASAVE
              MXEXP = MXSAVE
              CALL FMWARN
              NDIG = NDSAVE
              CALL FMST2M('UNKNOWN',MC)
              IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
              NCALL = NCALL - 1
              RETURN
          ENDIF

          CALL FMEQ2(MA,M02,NDSAVE,NDIG)
          M02(0) = NINT(NDIG*ALOGM2)
          CALL FMEQ2(MB,M03,NDSAVE,NDIG)
          M03(0) = NINT(NDIG*ALOGM2)

          M02(-1) = 1
          M03(-1) = 1
          CALL FMDIV(M02,M03,M01)
          CALL FMINT(M01,M08)
          CALL FMEQ(M08,M01)
          CALL FMMPY_R1(M01,M03)
          CALL FMSUB_R2(M02,M01)

!             Due to rounding, M01 may not be between 0 and MB here.

          NTRSAV = NTRACE
          NTRACE = 0
          IF (FMCOMP(M01,'GE',M03)) THEN
              NTRACE = NTRSAV
              CALL FMSUB_R1(M01,M03)
          ENDIF
          NTRACE = NTRSAV
          IF (M01(-1) < 0) CALL FMADD_R1(M01,M03)
          IF (MA(-1) < 0 .AND. M01(1) /= MUNKNO .AND. M01(2) /= 0)  &
              M01(-1) = -M01(-1)
      ENDIF

  130 IF (KFLAG == 1) KFLAG = 0
      KWARN = KWRNSV
      MACMAX = NINT((NDSAVE-1)*ALOGM2+LOG(REAL(ABS(M01(2))+1))/0.69315)
      M01(0) = MIN(M01(0),MACCA,MACCB,MACMAX)
      CALL FMEXIT(M01,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMMOD

      SUBROUTINE FMMOVE(MW,MA)

!  Move a result from a work area (MW) to MA.

!  If the result has MW(2)=0, then it is shifted and the exponent
!  adjusted when it is moved to MA.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MW(LMWA)

      INTEGER J,N1,N2

      IF (MW(2) /= 0) THEN
          N1 = NDIG + 1

!             Major (Inner Loop)

          DO J = 1, N1
             MA(J) = MW(J)
          ENDDO
      ELSE
          N2 = NDIG + 2
          DO J = 3, N2
             MA(J-1) = MW(J)
          ENDDO
          IF (MA(2) /= 0) THEN
              MA(1) = MW(1) - 1
          ELSE
              MA(1) = 0
          ENDIF
      ENDIF

      MA(-1) = 1
      IF (ABS(MA(1)) > MXEXP) CALL FMTRAP(MA)

      RETURN
      END SUBROUTINE FMMOVE

      SUBROUTINE FMMPY(MA,MB,MC)

!  MC = MA * MB

!  When one of the numbers MA, MB is known to have more zero digits
!  (base MBASE) than the other, it is faster if MB is the one with
!  more zero digits.

!  This routine performs the trace printing for multiplication.
!  FMMPY2 is used to do the arithmetic.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMMPY '
          CALL FMNTR(2,MA,MB,2,1)

          CALL FMMPY2(MA,MB,MC)

          CALL FMNTR(1,MC,MC,1,1)
      ELSE
          CALL FMMPY2(MA,MB,MC)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMMPY

      SUBROUTINE FMMPY2(MA,MB,MC)

!  Internal multiplication routine.  MC = MA * MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MR,MS,MT1,MT2
      INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KSHIFT,L,N1,NGUARD

      IF (MBLOGS /= MBASE) CALL FMCONS
      JRSSAV = JRSIGN
      MACCA = MA(0)
      MACCB = MB(0)
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR.  &
          KDEBUG == 1) THEN
          CALL FMARGS('FMMPY ',2,MA,MB,KRESLT)
          IF (KRESLT /= 0) THEN
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'FMMPY '
              CALL FMRSLT(MA,MB,MC,KRESLT)
              JRSIGN = JRSSAV
              NCALL = NCALL - 1
              RETURN
          ENDIF
      ELSE IF (MA(2) == 0 .OR. MB(2) == 0) THEN
          CALL FMIM(0,MC)
          MC(0) = MIN(MACCA,MACCB)
          JRSIGN = JRSSAV
          RETURN
      ENDIF
      KFLAG = 0

!             Save the sign of MA and MB and then work only with
!             positive numbers.

      MAS = MA(-1)
      MBS = MB(-1)

!             NGUARD is the number of guard digits used.

      IF (NCALL > 1) THEN
          NGUARD = NGRD22
          IF (NGUARD > NDIG) NGUARD = NDIG
      ELSE
          NGUARD = NGRD52
          IF (NGUARD > NDIG) NGUARD = NDIG
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 2
          ENDIF
      ENDIF
      IF (MA(2)*MB(2) < MBASE .AND. NGUARD < 3) NGUARD = 3

      N1 = NDIG + 1

!             If MBASE is small, pack the input numbers and use a larger
!             base to speed up the calculation.

      IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
          IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN
              MBASEL = MBASE
              NDIGL = NDIG
              NGUARL = NGUARD
              DO J = 2, 1000
                 MR = MBASE*MBASEL
                 IF (4*MR > MXBASE) THEN
                     N21 = J - 1
                     NDIG = (NDIGL-1)/N21 + 1
                     IF (NDIG < 2) NDIG = 2
                     NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG
                     IF (NGRDN < 1) NGRDN = 1
                     EXIT
                 ENDIF
                 MBASE = MR
              ENDDO
              MBASEN = MBASE
              NDIGN = NDIG
          ELSE
              MBASE = MBASEN
              NDIG = NDIGN
          ENDIF
          MPMA(1) = 0
          MPMB(1) = 0
          L = 2 - N21
          DO J = 2, NDIGL+2-N21, N21
             MT1 = MA(J)
             MT2 = MB(J)
             DO K = J+1, J+N21-1
                MT1 = MT1*MBASEL + MA(K)
                MT2 = MT2*MBASEL + MB(K)
             ENDDO
             MPMA(2+J/N21) = MT1
             MPMB(2+J/N21) = MT2
             L = J
          ENDDO
          DO J = 3+L/N21, NDIG+NGRDN+1
             MPMA(J) = 0
             MPMB(J) = 0
          ENDDO
          IF (L+N21 <= NDIGL+1) THEN
              MT1 = 0
              MT2 = 0
              DO J = L+N21, L+2*N21-1
                 IF (J <= NDIGL+1) THEN
                     MT1 = MT1*MBASEL + MA(J)
                     MT2 = MT2*MBASEL + MB(J)
                 ELSE
                     MT1 = MT1*MBASEL
                     MT2 = MT2*MBASEL
                 ENDIF
              ENDDO
              MPMA(2+(L+N21)/N21) = MT1
              MPMB(2+(L+N21)/N21) = MT2
          ENDIF
          CALL FMMPY3(MPMA,MPMB,NGRDN,KSHIFT)
          IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN
              DO J = 1+NDIG+NGRDN, 2, -1
                 KT1 = MWA(J)
                 KT = 2 + (J-2)*N21
                 KT2 = N21 + KT - 1
                 DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2)
                    MWA(K) = IBITS(KT1,KT2-K,1)
                 ENDDO
              ENDDO
          ELSE
              MS = MBASEL**(N21-1)
              DO J = 1+NDIG+NGRDN, 2, -1
                 MR = MS
                 MT1 = MWA(J)
                 DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2)
                    MWA(K) = AINT (MT1/MR)
                    MT1 = MT1 - MWA(K)*MR
                    MR = AINT (MR/MBASEL)
                 ENDDO
              ENDDO
          ENDIF
          KSHIFT = 0
          IF (MWA(2) == 0) KSHIFT = 1
          MWA(1) = MA(1) + MB(1)
          NDIG = NDIGL
          MBASE = MBASEL
      ELSE
          CALL FMMPY3(MA,MB,NGUARD,KSHIFT)
      ENDIF

!             The multiplication is complete.  Round the result,
!             move it to MC, and append the correct sign.

      IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      MR = 2*MWA(NDIG+2+KSHIFT) + 1
      IF (KROUND == -1 .OR. KROUND == 2) THEN
          CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
      ELSE IF (MR >= MBASE) THEN
          IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
              IF (KROUND /= 0 .OR. NCALL > 1) THEN
                  MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
                  MWA(N1+1+KSHIFT) = 0
              ENDIF
          ELSE
              CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
          ENDIF
      ENDIF
      CALL FMMOVE(MWA,MC)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'FMMPY '
          CALL FMWARN
      ENDIF

      MC(-1) = 1
      IF (MAS*MBS < 0 .AND. MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1

      IF (KACCSW == 1) THEN
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)
          MC(0) = MIN(MACCA,MACCB,MD2B)
      ELSE
          MC(0) = MIN(MACCA,MACCB)
      ENDIF
      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMMPY2

      SUBROUTINE FMMPY_R1(MA,MB)

!  MA = MA * MB

!  When one of the numbers MA, MB is known to have more zero digits
!  (base MBASE) than the other, it is faster if MB is the one with
!  more zero digits.

!  This routine performs the trace printing for multiplication.
!  FMMPY2_R1 is used to do the arithmetic.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMMPY '
          CALL FMNTR(2,MA,MB,2,1)

          CALL FMMPY2_R1(MA,MB)

          CALL FMNTR(1,MA,MA,1,1)
      ELSE
          CALL FMMPY2_R1(MA,MB)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMMPY_R1

      SUBROUTINE FMMPY2_R1(MA,MB)

!  Internal multiplication routine.  MA = MA * MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MR,MS,MT1,MT2
      INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KSHIFT,L,N1,NGUARD

      IF (MBLOGS /= MBASE) CALL FMCONS
      JRSSAV = JRSIGN
      MACCA = MA(0)
      MACCB = MB(0)
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR.  &
          KDEBUG == 1) THEN
          CALL FMARGS('FMMPY ',2,MA,MB,KRESLT)
          IF (KRESLT /= 0) THEN
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'FMMPY '
              CALL FMRSLT(MA,MB,M07,KRESLT)
              CALL FMEQ(M07,MA)
              JRSIGN = JRSSAV
              NCALL = NCALL - 1
              RETURN
          ENDIF
      ELSE IF (MA(2) == 0 .OR. MB(2) == 0) THEN
          CALL FMIM(0,MA)
          MA(0) = MIN(MACCA,MACCB)
          JRSIGN = JRSSAV
          RETURN
      ENDIF
      KFLAG = 0

!             Save the sign of MA and MB and then work only with
!             positive numbers.

      MAS = MA(-1)
      MBS = MB(-1)

!             NGUARD is the number of guard digits used.

      IF (NCALL > 1) THEN
          NGUARD = NGRD22
          IF (NGUARD > NDIG) NGUARD = NDIG
      ELSE
          NGUARD = NGRD52
          IF (NGUARD > NDIG) NGUARD = NDIG
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 2
          ENDIF
      ENDIF
      IF (MA(2)*MB(2) < MBASE .AND. NGUARD < 3) NGUARD = 3

      N1 = NDIG + 1

!             If MBASE is small, pack the input numbers and use a larger
!             base to speed up the calculation.

      IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
          IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN
              MBASEL = MBASE
              NDIGL = NDIG
              NGUARL = NGUARD
              DO J = 2, 1000
                 MR = MBASE*MBASEL
                 IF (4*MR > MXBASE) THEN
                     N21 = J - 1
                     NDIG = (NDIGL-1)/N21 + 1
                     IF (NDIG < 2) NDIG = 2
                     NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG
                     IF (NGRDN < 1) NGRDN = 1
                     EXIT
                 ENDIF
                 MBASE = MR
              ENDDO
              MBASEN = MBASE
              NDIGN = NDIG
          ELSE
              MBASE = MBASEN
              NDIG = NDIGN
          ENDIF
          MPMA(1) = 0
          MPMB(1) = 0
          L = 2 - N21
          DO J = 2, NDIGL+2-N21, N21
             MT1 = MA(J)
             MT2 = MB(J)
             DO K = J+1, J+N21-1
                MT1 = MT1*MBASEL + MA(K)
                MT2 = MT2*MBASEL + MB(K)
             ENDDO
             MPMA(2+J/N21) = MT1
             MPMB(2+J/N21) = MT2
             L = J
          ENDDO
          DO J = 3+L/N21, NDIG+NGRDN+1
             MPMA(J) = 0
             MPMB(J) = 0
          ENDDO
          IF (L+N21 <= NDIGL+1) THEN
              MT1 = 0
              MT2 = 0
              DO J = L+N21, L+2*N21-1
                 IF (J <= NDIGL+1) THEN
                     MT1 = MT1*MBASEL + MA(J)
                     MT2 = MT2*MBASEL + MB(J)
                 ELSE
                     MT1 = MT1*MBASEL
                     MT2 = MT2*MBASEL
                 ENDIF
              ENDDO
              MPMA(2+(L+N21)/N21) = MT1
              MPMB(2+(L+N21)/N21) = MT2
          ENDIF
          CALL FMMPY3(MPMA,MPMB,NGRDN,KSHIFT)
          IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN
              DO J = 1+NDIG+NGRDN, 2, -1
                 KT1 = MWA(J)
                 KT = 2 + (J-2)*N21
                 KT2 = N21 + KT - 1
                 DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2)
                    MWA(K) = IBITS(KT1,KT2-K,1)
                 ENDDO
              ENDDO
          ELSE
              MS = MBASEL**(N21-1)
              DO J = 1+NDIG+NGRDN, 2, -1
                 MR = MS
                 MT1 = MWA(J)
                 DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2)
                    MWA(K) = AINT (MT1/MR)
                    MT1 = MT1 - MWA(K)*MR
                    MR = AINT (MR/MBASEL)
                 ENDDO
              ENDDO
          ENDIF
          KSHIFT = 0
          IF (MWA(2) == 0) KSHIFT = 1
          MWA(1) = MA(1) + MB(1)
          NDIG = NDIGL
          MBASE = MBASEL
      ELSE
          CALL FMMPY3(MA,MB,NGUARD,KSHIFT)
      ENDIF

!             The multiplication is complete.  Round the result,
!             move it to MA, and append the correct sign.

      IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      MR = 2*MWA(NDIG+2+KSHIFT) + 1
      IF (KROUND == -1 .OR. KROUND == 2) THEN
          CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
      ELSE IF (MR >= MBASE) THEN
          IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
              IF (KROUND /= 0 .OR. NCALL > 1) THEN
                  MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
                  MWA(N1+1+KSHIFT) = 0
              ENDIF
          ELSE
              CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
          ENDIF
      ENDIF
      CALL FMMOVE(MWA,MA)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'FMMPY '
          CALL FMWARN
      ENDIF

      MA(-1) = 1
      IF (MAS*MBS < 0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1

      IF (KACCSW == 1) THEN
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315)
          MA(0) = MIN(MACCA,MACCB,MD2B)
      ELSE
          MA(0) = MIN(MACCA,MACCB)
      ENDIF
      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMMPY2_R1

      SUBROUTINE FMMPY_R2(MA,MB)

!  MB = MA * MB

!  When one of the numbers MA, MB is known to have more zero digits
!  (base MBASE) than the other, it is faster if MB is the one with
!  more zero digits.

!  This routine performs the trace printing for multiplication.
!  FMMPY2_R2 is used to do the arithmetic.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMMPY '
          CALL FMNTR(2,MA,MB,2,1)

          CALL FMMPY2_R2(MA,MB)

          CALL FMNTR(1,MB,MB,1,1)
      ELSE
          CALL FMMPY2_R2(MA,MB)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMMPY_R2

      SUBROUTINE FMMPY2_R2(MA,MB)

!  Internal multiplication routine.  MB = MA * MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MR,MS,MT1,MT2
      INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KSHIFT,L,N1,NGUARD

      IF (MBLOGS /= MBASE) CALL FMCONS
      JRSSAV = JRSIGN
      MACCA = MA(0)
      MACCB = MB(0)
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR.  &
          KDEBUG == 1) THEN
          CALL FMARGS('FMMPY ',2,MA,MB,KRESLT)
          IF (KRESLT /= 0) THEN
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'FMMPY '
              CALL FMRSLT(MA,MB,M07,KRESLT)
              CALL FMEQ(M07,MB)
              JRSIGN = JRSSAV
              NCALL = NCALL - 1
              RETURN
          ENDIF
      ELSE IF (MA(2) == 0 .OR. MB(2) == 0) THEN
          CALL FMIM(0,MB)
          MB(0) = MIN(MACCA,MACCB)
          JRSIGN = JRSSAV
          RETURN
      ENDIF
      KFLAG = 0

!             Save the sign of MA and MB and then work only with
!             positive numbers.

      MAS = MA(-1)
      MBS = MB(-1)

!             NGUARD is the number of guard digits used.

      IF (NCALL > 1) THEN
          NGUARD = NGRD22
          IF (NGUARD > NDIG) NGUARD = NDIG
      ELSE
          NGUARD = NGRD52
          IF (NGUARD > NDIG) NGUARD = NDIG
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 2
          ENDIF
      ENDIF
      IF (MA(2)*MB(2) < MBASE .AND. NGUARD < 3) NGUARD = 3

      N1 = NDIG + 1

!             If MBASE is small, pack the input numbers and use a larger
!             base to speed up the calculation.

      IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
          IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN
              MBASEL = MBASE
              NDIGL = NDIG
              NGUARL = NGUARD
              DO J = 2, 1000
                 MR = MBASE*MBASEL
                 IF (4*MR > MXBASE) THEN
                     N21 = J - 1
                     NDIG = (NDIGL-1)/N21 + 1
                     IF (NDIG < 2) NDIG = 2
                     NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG
                     IF (NGRDN < 1) NGRDN = 1
                     EXIT
                 ENDIF
                 MBASE = MR
              ENDDO
              MBASEN = MBASE
              NDIGN = NDIG
          ELSE
              MBASE = MBASEN
              NDIG = NDIGN
          ENDIF
          MPMA(1) = 0
          MPMB(1) = 0
          L = 2 - N21
          DO J = 2, NDIGL+2-N21, N21
             MT1 = MA(J)
             MT2 = MB(J)
             DO K = J+1, J+N21-1
                MT1 = MT1*MBASEL + MA(K)
                MT2 = MT2*MBASEL + MB(K)
             ENDDO
             MPMA(2+J/N21) = MT1
             MPMB(2+J/N21) = MT2
             L = J
          ENDDO
          DO J = 3+L/N21, NDIG+NGRDN+1
             MPMA(J) = 0
             MPMB(J) = 0
          ENDDO
          IF (L+N21 <= NDIGL+1) THEN
              MT1 = 0
              MT2 = 0
              DO J = L+N21, L+2*N21-1
                 IF (J <= NDIGL+1) THEN
                     MT1 = MT1*MBASEL + MA(J)
                     MT2 = MT2*MBASEL + MB(J)
                 ELSE
                     MT1 = MT1*MBASEL
                     MT2 = MT2*MBASEL
                 ENDIF
              ENDDO
              MPMA(2+(L+N21)/N21) = MT1
              MPMB(2+(L+N21)/N21) = MT2
          ENDIF
          CALL FMMPY3(MPMA,MPMB,NGRDN,KSHIFT)
          IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN
              DO J = 1+NDIG+NGRDN, 2, -1
                 KT1 = MWA(J)
                 KT = 2 + (J-2)*N21
                 KT2 = N21 + KT - 1
                 DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2)
                    MWA(K) = IBITS(KT1,KT2-K,1)
                 ENDDO
              ENDDO
          ELSE
              MS = MBASEL**(N21-1)
              DO J = 1+NDIG+NGRDN, 2, -1
                 MR = MS
                 MT1 = MWA(J)
                 DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2)
                    MWA(K) = AINT (MT1/MR)
                    MT1 = MT1 - MWA(K)*MR
                    MR = AINT (MR/MBASEL)
                 ENDDO
              ENDDO
          ENDIF
          KSHIFT = 0
          IF (MWA(2) == 0) KSHIFT = 1
          MWA(1) = MA(1) + MB(1)
          NDIG = NDIGL
          MBASE = MBASEL
      ELSE
          CALL FMMPY3(MA,MB,NGUARD,KSHIFT)
      ENDIF

!             The multiplication is complete.  Round the result,
!             move it to MB, and append the correct sign.

      IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      MR = 2*MWA(NDIG+2+KSHIFT) + 1
      IF (KROUND == -1 .OR. KROUND == 2) THEN
          CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
      ELSE IF (MR >= MBASE) THEN
          IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
              IF (KROUND /= 0 .OR. NCALL > 1) THEN
                  MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
                  MWA(N1+1+KSHIFT) = 0
              ENDIF
          ELSE
              CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
          ENDIF
      ENDIF
      CALL FMMOVE(MWA,MB)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'FMMPY '
          CALL FMWARN
      ENDIF

      MB(-1) = 1
      IF (MAS*MBS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1

      IF (KACCSW == 1) THEN
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
          MB(0) = MIN(MACCA,MACCB,MD2B)
      ELSE
          MB(0) = MIN(MACCA,MACCB)
      ENDIF
      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMMPY2_R2

      SUBROUTINE FMMPY3(MA,MB,NGUARD,KSHIFT)

!  Internal multiplication of MA*MB.  The result is returned in MWA.
!  Both MA and MB are positive.

!  NGUARD is the number of guard digits that will be used.
!  KSHIFT = 1 is returned if a left shift is pending (i.e., MWA(2)=0).
!             The shift will be done in FMMOVE.  KSHIFT = 0 is returned
!             if no shift is pending.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER NGUARD,KSHIFT

      REAL (KIND(1.0D0)) :: MAXMWA,MBJ,MBKJ,MBM1,MBNORM,MK,MKT,MMAX,MT
      INTEGER J,JM1,K,KB,KI,KJ,KL,KNZ,KWA,L,N1

      N1 = NDIG + 1
      MWA(1) = MA(1) + MB(1)
      L = N1 + NGUARD
      MWA(L+1) = 0

!             The multiplication loop begins here.

!             MBNORM is the minimum number of digits that can be
!                    multiplied before normalization is required.
!             MAXMWA is an upper bound on the size of values in MWA
!                    divided by (MBASE-1).  It is used to determine
!                    whether to normalize before the next digit is
!                    multiplied.

      MBM1 = MBASE - 1
      MBNORM = AINT (MAXINT/(MBM1*MBM1))
      MMAX = INTMAX - MBASE
      MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX)
      IF (MBNORM > 1) THEN
          MBJ = MB(2)

!             Count the trailing zeros in MA.

          IF (MA(N1) /= 0) THEN
              KNZ = N1
          ELSE
              DO J = NDIG, 2, -1
                 IF (MA(J) /= 0) THEN
                     KNZ = J
                     GO TO 110
                 ENDIF
              ENDDO
          ENDIF

  110     MWA(2) = 0
          DO K = NDIG+2, L
             MWA(K) = 0
          ENDDO

!             (Inner Loop)

          DO K = 2, N1
             MWA(K+1) = MA(K)*MBJ
          ENDDO
          MAXMWA = MBJ
          DO J = 3, N1
             MBJ = MB(J)
             IF (MBJ /= 0) THEN
                 MAXMWA = MAXMWA + MBJ
                 JM1 = J - 1
                 KL = MIN(KNZ,L-JM1)

!                       Major (Inner Loop)

                 DO K = J+1, J+KL-1
                    MWA(K) = MWA(K) + MA(K-JM1)*MBJ
                 ENDDO
             ENDIF

             IF (MAXMWA > MMAX) THEN
                 MAXMWA = 0

!                       Here normalization is only required for the
!                       range of digits currently changing in MWA.

                 DO KB = JM1+KL, JM1+2, -1
                    MKT = INT (MWA(KB)/MBASE)
                    MWA(KB-1) = MWA(KB-1) + MKT
                    MWA(KB) = MWA(KB) - MKT*MBASE
                 ENDDO
             ENDIF
          ENDDO

!             Perform the final normalization.  (Inner Loop)

          DO KB = L, 3, -1
             MKT = INT (MWA(KB)/MBASE)
             MWA(KB-1) = MWA(KB-1) + MKT
             MWA(KB) = MWA(KB) - MKT*MBASE
          ENDDO

      ELSE

!             If normalization must be done for each digit, combine
!             the two loops and normalize as the digits are multiplied.

          DO J = 2, L
             MWA(J) = 0
          ENDDO
          KJ = NDIG + 2
          DO J = 2, N1
             KJ = KJ - 1
             MBKJ = MB(KJ)
             IF (MBKJ == 0) CYCLE
             KL = L - KJ + 1
             IF (KL > N1) KL = N1
             KI = KL + 2
             KWA = KL+ KJ + 1
             MK = 0
             DO K = 2, KL
                MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MK
                MK = INT (MT/MBASE)
                MWA(KWA-K) = MT - MBASE*MK
             ENDDO
             MWA(KWA-KL-1) = MK
          ENDDO

      ENDIF

!             Set KSHIFT = 1 if a shift left is necessary.

      IF (MWA(2) == 0) THEN
          KSHIFT = 1
          RETURN
      ELSE
          KSHIFT = 0
          RETURN
      ENDIF

      END SUBROUTINE FMMPY3

      SUBROUTINE FMMPYD(MA,MB,MC,MD,ME)

!  Double multiplication routine.  MD = MA * MB,   ME = MA * MC

!  It is usually slightly faster to do two multiplications that
!  have a common factor with one call.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK),  &
                            MD(-1:LUNPCK),ME(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MACCA,MACCB,MACCC,MAS,MAXMWA,MBS,MBJ,MBKJ,  &
                            MBM1,MBNORM,MCJ,MCKJ,MCS,MD2B,MKB,MKC,MKT,  &
                            MMAX,MR,MT,MTEMP
      INTEGER J,JM1,JRSSAV,K,KB,KI,KJ,KL,KNZ,KOVUN,KSHIFT,KWA,L,N1,NGUARD

      NCALL = NCALL + 1
      JRSSAV = JRSIGN
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMMPYD'
          CALL FMNTR(2,MA,MB,2,1)
          IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
              IF (NTRACE < 0) THEN
                  CALL FMNTRJ(MC,NDIG)
              ELSE
                  CALL FMPRNT(MC)
              ENDIF
          ENDIF
      ENDIF

      IF (MBLOGS /= MBASE) CALL FMCONS
      MACCA = MA(0)
      MACCB = MB(0)
      MACCC = MC(0)
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR.  &
          ABS(MC(1)) > MEXPAB .OR. MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN .OR.  &
              MB(1) == MEXPOV .OR. MB(1) == MEXPUN .OR.  &
              MC(1) == MEXPOV .OR. MC(1) == MEXPUN) KOVUN = 1
          IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR.  &
              MC(1) == MUNKNO) KOVUN = 2
          NCALL = NCALL + 1
          CALL FMMPY2(MA,MB,MWD)
          KB = KFLAG
          CALL FMMPY2(MA,MC,ME)
          NCALL = NCALL - 1
          IF (((KFLAG < 0 .OR. KB < 0) .AND. KOVUN == 0) .OR.  &
              ((KFLAG == -4 .OR. KB == -4) .AND. KOVUN == 1)) THEN
              IF (KFLAG == -4 .OR. KB == -4) THEN
                  KFLAG = -4
              ELSE IF (KFLAG == -5 .OR. KB == -5) THEN
                  KFLAG = -5
              ELSE
                  KFLAG = MIN(KFLAG,KB)
              ENDIF
              NAMEST(NCALL) = 'FMMPYD'
              CALL FMWARN
          ENDIF
          CALL FMEQ(MWD,MD)
          GO TO 120
      ENDIF
      IF (MA(2) == 0) THEN
          CALL FMIM(0,MD)
          MD(0) = MIN(MACCA,MACCB)
          CALL FMIM(0,ME)
          ME(0) = MIN(MACCA,MACCC)
          GO TO 120
      ENDIF
      IF (MB(2) == 0) THEN
          CALL FMMPY2(MA,MC,ME)
          CALL FMIM(0,MD)
          MD(0) = MIN(MACCA,MACCB)
          GO TO 120
      ENDIF
      IF (MC(2) == 0) THEN
          CALL FMMPY2(MA,MB,MD)
          CALL FMIM(0,ME)
          ME(0) = MIN(MACCA,MACCC)
          GO TO 120
      ENDIF
      KFLAG = 0

!             NGUARD is the number of guard digits used.

      IF (NCALL > 1) THEN
          NGUARD = NGRD22
          IF (NGUARD > NDIG) NGUARD = NDIG
      ELSE
          NGUARD = NGRD52
          IF (NGUARD > NDIG) NGUARD = NDIG
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 10
          ENDIF
      ENDIF
      IF ((MA(2)*MB(2) < MBASE .OR. MA(2)*MC(2) < MBASE)  &
          .AND. NGUARD < 3) NGUARD = 3

!             Save the sign of MA, MB, and MC and then
!             work only with positive numbers.

      MAS = MA(-1)
      MBS = MB(-1)
      MCS = MC(-1)

      N1 = NDIG + 1
      MWA(1) = MA(1) + MB(1)
      MWD(1) = MA(1) + MC(1)
      L = NDIG + 1 + NGUARD
      MWA(L+1) = 0
      MWD(L+1) = 0

!             The multiplication loop begins here.

!             MBNORM is the minimum number of digits that can be
!                    multiplied before normalization is required.
!             MAXMWA is an upper bound on the size of values in MWA
!                    divided by (MBASE-1).  It is used to determine
!                    whether to normalize before the next digit is
!                    multiplied.

      MBM1 = MBASE - 1
      MBNORM = AINT (MAXINT/(MBM1*MBM1))
      MMAX = INTMAX - MBASE
      MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX)
      IF (MBNORM > 1) THEN
          MBJ = MB(2)
          MCJ = MC(2)

!             Count the trailing zeros in MA.

          IF (MA(N1) /= 0) THEN
              KNZ = N1
          ELSE
              DO J = NDIG, 2, -1
                 IF (MA(J) /= 0) THEN
                     KNZ = J
                     GO TO 110
                 ENDIF
              ENDDO
          ENDIF

  110     MWA(2) = 0
          MWD(2) = 0
          DO K = NDIG+2, L
             MWA(K) = 0
             MWD(K) = 0
          ENDDO

!             (Inner Loop)

          DO K = 2, N1
             MTEMP = MA(K)
             MWA(K+1) = MTEMP*MBJ
             MWD(K+1) = MTEMP*MCJ
          ENDDO
          IF (MBJ > MCJ) THEN
              MAXMWA = MBJ
          ELSE
              MAXMWA = MCJ
          ENDIF
          DO J = 3, N1
             MBJ = MB(J)
             MCJ = MC(J)
             IF (MBJ > MCJ) THEN
                 MAXMWA = MAXMWA + MBJ
             ELSE
                 MAXMWA = MAXMWA + MCJ
             ENDIF
             JM1 = J - 1
             KL = MIN(KNZ,L-JM1)

!                       Major (Inner Loop)

             DO K = J+1, J+KL-1
                MTEMP = MA(K-JM1)
                MWA(K) = MWA(K) + MTEMP*MBJ
                MWD(K) = MWD(K) + MTEMP*MCJ
             ENDDO

             IF (MAXMWA > MMAX) THEN
                 MAXMWA = 0

!                       Here normalization is only required for the
!                       range of digits currently changing in MWA.

                 DO KB = JM1+KL, JM1+2, -1
                    MKT = INT (MWA(KB)/MBASE)
                    MWA(KB-1) = MWA(KB-1) + MKT
                    MWA(KB) = MWA(KB) - MKT*MBASE
                    MKT = INT (MWD(KB)/MBASE)
                    MWD(KB-1) = MWD(KB-1) + MKT
                    MWD(KB) = MWD(KB) - MKT*MBASE
                 ENDDO
             ENDIF
          ENDDO

!             Perform the final normalization.  (Inner Loop)

          DO KB = L, 3, -1
             MKT = INT (MWA(KB)/MBASE)
             MWA(KB-1) = MWA(KB-1) + MKT
             MWA(KB) = MWA(KB) - MKT*MBASE
             MKT = INT (MWD(KB)/MBASE)
             MWD(KB-1) = MWD(KB-1) + MKT
             MWD(KB) = MWD(KB) - MKT*MBASE
          ENDDO

      ELSE

!             If normalization must be done for each digit, combine
!             the two loops and normalize as the digits are multiplied.

          DO J = 2, L
             MWA(J) = 0
             MWD(J) = 0
          ENDDO
          KJ = NDIG + 2
          DO J = 2, N1
             KJ = KJ - 1
             MBKJ = MB(KJ)
             MCKJ = MC(KJ)
             KL = L - KJ + 1
             IF (KL > N1) KL = N1
             KI = KL + 2
             KWA = KL+ KJ + 1
             MKB = 0
             MKC = 0
             DO K = 2, KL
                MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MKB
                MKB = INT (MT/MBASE)
                MWA(KWA-K) = MT - MBASE*MKB
                MT = MA(KI-K)*MCKJ + MWD(KWA-K) + MKC
                MKC = INT (MT/MBASE)
                MWD(KWA-K) = MT - MBASE*MKC
             ENDDO
             MWA(KWA-KL-1) = MKB
             MWD(KWA-KL-1) = MKC
          ENDDO

      ENDIF

!             Set KSHIFT = 1 if a shift left is necessary.

      IF (MWA(2) == 0) THEN
          KSHIFT = 1
      ELSE
          KSHIFT = 0
      ENDIF

!             The multiplications are complete.

      IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      MR = 2*MWA(NDIG+2+KSHIFT) + 1
      IF (KROUND == -1 .OR. KROUND == 2) THEN
          CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
      ELSE IF (MR >= MBASE) THEN
          IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
              IF (KROUND /= 0 .OR. NCALL > 1) THEN
                  MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
                  MWA(N1+1+KSHIFT) = 0
              ENDIF
          ELSE
              CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
          ENDIF
      ENDIF
      CALL FMMOVE(MWA,MD)

      IF ((MAS > 0 .AND. MCS > 0) .OR. (MAS < 0 .AND. MCS < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      IF (MWD(2) == 0) THEN
          KSHIFT = 1
      ELSE
          KSHIFT = 0
      ENDIF
      MR = 2*MWD(NDIG+2+KSHIFT) + 1
      IF (KROUND == -1 .OR. KROUND == 2) THEN
          CALL FMRND(MWD,NDIG,NGUARD,KSHIFT)
      ELSE IF (MR >= MBASE) THEN
          IF (MR-1 > MBASE .AND. MWD(N1+KSHIFT) < MBASE-1) THEN
              IF (KROUND /= 0 .OR. NCALL > 1) THEN
                  MWD(N1+KSHIFT) = MWD(N1+KSHIFT) + 1
                  MWD(N1+1+KSHIFT) = 0
              ENDIF
          ELSE
              CALL FMRND(MWD,NDIG,NGUARD,KSHIFT)
          ENDIF
      ENDIF
      CALL FMMOVE(MWD,ME)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'FMMPYD'
          CALL FMWARN
      ENDIF

      MD(-1) = 1
      IF (MAS*MBS < 0 .AND. MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -1
      ME(-1) = 1
      IF (MAS*MCS < 0 .AND. ME(1) /= MUNKNO .AND. ME(2) /= 0) ME(-1) = -1

      IF (KACCSW == 1) THEN
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MD(2))+1))/0.69315)
          MD(0) = MIN(MACCA,MACCB,MD2B)
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(ME(2))+1))/0.69315)
          ME(0) = MIN(MACCA,MACCC,MD2B)
      ELSE
          MD(0) = MIN(MACCA,MACCB)
          ME(0) = MIN(MACCA,MACCC)
      ENDIF

  120 IF (NTRACE /= 0) THEN
          CALL FMNTR(1,MD,MD,1,1)
          IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN
              IF (NTRACE < 0) THEN
                  CALL FMNTRJ(ME,NDIG)
              ELSE
                  CALL FMPRNT(ME)
              ENDIF
          ENDIF
      ENDIF
      NCALL = NCALL - 1
      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMMPYD

      SUBROUTINE FMMPYE(MA,MB,MC,MD,ME,MF,MG)

!  Triple multiplication routine.

!      ME = MA * MB,   MF = MA * MC,   MG = MA * MD

!  It is usually slightly faster to do three multiplications that
!  have a common factor with one call.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK),  &
                            MD(-1:LUNPCK),ME(-1:LUNPCK),MF(-1:LUNPCK),  &
                            MG(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MACCA,MACCB,MACCC,MACCD,MAS,MAXJ,MAXMWA,MBS,MBJ,  &
                            MBKJ,MBM1,MBNORM,MCJ,MCKJ,MCS,MD2B,MDJ,MDKJ,MDS,  &
                            MKB,MKC,MKD,MKT,MMAX,MR,MT,MTEMP
      INTEGER J,JM1,JRSSAV,K,KB,KI,KJ,KL,KNZ,KOVUN,KSHIFT,KWA,L,N1,NGUARD

      NCALL = NCALL + 1
      JRSSAV = JRSIGN
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMMPYE'
          CALL FMNTR(2,MA,MB,2,1)
          IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
              IF (NTRACE < 0) THEN
                  CALL FMNTRJ(MC,NDIG)
                  CALL FMNTRJ(MD,NDIG)
              ELSE
                  CALL FMPRNT(MC)
                  CALL FMPRNT(MD)
              ENDIF
          ENDIF
      ENDIF

      IF (MBLOGS /= MBASE) CALL FMCONS
      MACCA = MA(0)
      MACCB = MB(0)
      MACCC = MC(0)
      MACCD = MD(0)
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR.  &
          ABS(MC(1)) > MEXPAB .OR. ABS(MD(1)) > MEXPAB .OR.  &
          MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN .OR.  &
              MB(1) == MEXPOV .OR. MB(1) == MEXPUN .OR.  &
              MC(1) == MEXPOV .OR. MC(1) == MEXPUN .OR.  &
              MD(1) == MEXPOV .OR. MD(1) == MEXPUN) KOVUN = 1
          IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR.  &
              MC(1) == MUNKNO .OR. MD(1) == MUNKNO) KOVUN = 2
          NCALL = NCALL + 1
          CALL FMMPY2(MA,MB,MWD)
          KB = KFLAG
          CALL FMMPY2(MA,MC,MWE)
          KJ = KFLAG
          CALL FMMPY2(MA,MD,MG)
          NCALL = NCALL - 1
          IF (((KFLAG < 0 .OR. KB < 0 .OR. KJ < 0) .AND. KOVUN == 0)  &
              .OR. ((KFLAG == -4 .OR. KB == -4 .OR. KJ == -4) .AND.  &
              KOVUN == 1)) THEN
              IF (KFLAG == -4 .OR. KB == -4 .OR. KJ == -4) THEN
                  KFLAG = -4
              ELSE IF (KFLAG == -5 .OR. KB == -5 .OR. KJ == -5) THEN
                  KFLAG = -5
              ELSE
                  KFLAG = MIN(KFLAG,KB,KJ)
              ENDIF
              NAMEST(NCALL) = 'FMMPYE'
              CALL FMWARN
          ENDIF
          CALL FMEQ(MWD,ME)
          CALL FMEQ(MWE,MF)
          GO TO 120
      ENDIF
      IF (MA(2) == 0) THEN
          CALL FMIM(0,ME)
          ME(0) = MIN(MACCA,MACCB)
          CALL FMIM(0,MF)
          MF(0) = MIN(MACCA,MACCC)
          CALL FMIM(0,MG)
          MG(0) = MIN(MACCA,MACCD)
          GO TO 120
      ENDIF
      IF (MB(2) == 0 .OR. MC(2) == 0 .OR. MD(2) == 0) THEN
          CALL FMMPY2(MA,MB,MWD)
          CALL FMMPY2(MA,MC,MWE)
          CALL FMMPY2(MA,MD,MG)
          CALL FMEQ(MWD,ME)
          CALL FMEQ(MWE,MF)
          GO TO 120
      ENDIF
      KFLAG = 0

!             NGUARD is the number of guard digits used.

      IF (NCALL > 1) THEN
          NGUARD = NGRD22
          IF (NGUARD > NDIG) NGUARD = NDIG
      ELSE
          NGUARD = NGRD52
          IF (NGUARD > NDIG) NGUARD = NDIG
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 10
          ENDIF
      ENDIF
      IF ((MA(2)*MB(2) < MBASE .OR. MA(2)*MC(2) < MBASE .OR.  &
           MA(2)*MD(2) < MBASE) .AND. NGUARD < 3) NGUARD = 3

!             Save the signs and then work only with positive numbers.

      MAS = MA(-1)
      MBS = MB(-1)
      MCS = MC(-1)
      MDS = MD(-1)

      N1 = NDIG + 1
      MWA(1) = MA(1) + MB(1)
      MWD(1) = MA(1) + MC(1)
      MWE(1) = MA(1) + MD(1)
      L = NDIG + 1 + NGUARD
      MWA(L+1) = 0
      MWD(L+1) = 0
      MWE(L+1) = 0

!             The multiplication loop begins here.

!             MBNORM is the minimum number of digits that can be
!                    multiplied before normalization is required.
!             MAXMWA is an upper bound on the size of values in MWA
!                    divided by (MBASE-1).  It is used to determine
!                    whether to normalize before the next digit is
!                    multiplied.

      MBM1 = MBASE - 1
      MBNORM = AINT (MAXINT/(MBM1*MBM1))
      MMAX = INTMAX - MBASE
      MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX)
      IF (MBNORM > 1) THEN
          MBJ = MB(2)
          MCJ = MC(2)
          MDJ = MD(2)

!             Count the trailing zeros in MA.

          IF (MA(N1) /= 0) THEN
              KNZ = N1
          ELSE
              DO J = NDIG, 2, -1
                 IF (MA(J) /= 0) THEN
                     KNZ = J
                     GO TO 110
                 ENDIF
              ENDDO
          ENDIF

  110     MWA(2) = 0
          MWD(2) = 0
          MWE(2) = 0
          DO K = NDIG+2, L
             MWA(K) = 0
             MWD(K) = 0
             MWE(K) = 0
          ENDDO

!             (Inner Loop)

          DO K = 2, N1
             MTEMP = MA(K)
             MWA(K+1) = MTEMP*MBJ
             MWD(K+1) = MTEMP*MCJ
             MWE(K+1) = MTEMP*MDJ
          ENDDO
          MAXMWA = MBJ
          IF (MCJ > MAXMWA) MAXMWA = MCJ
          IF (MDJ > MAXMWA) MAXMWA = MDJ
          DO J = 3, N1
             MBJ = MB(J)
             MCJ = MC(J)
             MDJ = MD(J)
             MAXJ = MBJ
             IF (MCJ > MAXJ) MAXJ = MCJ
             IF (MDJ > MAXJ) MAXJ = MDJ
             MAXMWA = MAXMWA + MAXJ
             JM1 = J - 1
             KL = MIN(KNZ,L-JM1)

!                       Major (Inner Loop)

             DO K = J+1, J+KL-1
                MTEMP = MA(K-JM1)
                MWA(K) = MWA(K) + MTEMP*MBJ
                MWD(K) = MWD(K) + MTEMP*MCJ
                MWE(K) = MWE(K) + MTEMP*MDJ
             ENDDO

             IF (MAXMWA > MMAX) THEN
                 MAXMWA = 0

!                       Here normalization is only required for the
!                       range of digits currently changing in MWA.

                 DO KB = JM1+KL, JM1+2, -1
                    MKT = INT (MWA(KB)/MBASE)
                    MWA(KB-1) = MWA(KB-1) + MKT
                    MWA(KB) = MWA(KB) - MKT*MBASE
                    MKT = INT (MWD(KB)/MBASE)
                    MWD(KB-1) = MWD(KB-1) + MKT
                    MWD(KB) = MWD(KB) - MKT*MBASE
                    MKT = INT (MWE(KB)/MBASE)
                    MWE(KB-1) = MWE(KB-1) + MKT
                    MWE(KB) = MWE(KB) - MKT*MBASE
                 ENDDO
             ENDIF
          ENDDO

!             Perform the final normalization.  (Inner Loop)

          DO KB = L, 3, -1
             MKT = INT (MWA(KB)/MBASE)
             MWA(KB-1) = MWA(KB-1) + MKT
             MWA(KB) = MWA(KB) - MKT*MBASE
             MKT = INT (MWD(KB)/MBASE)
             MWD(KB-1) = MWD(KB-1) + MKT
             MWD(KB) = MWD(KB) - MKT*MBASE
             MKT = INT (MWE(KB)/MBASE)
             MWE(KB-1) = MWE(KB-1) + MKT
             MWE(KB) = MWE(KB) - MKT*MBASE
          ENDDO

      ELSE

!             If normalization must be done for each digit, combine
!             the two loops and normalize as the digits are multiplied.

          DO J = 2, L
             MWA(J) = 0
             MWD(J) = 0
             MWE(J) = 0
          ENDDO
          KJ = NDIG + 2
          DO J = 2, N1
             KJ = KJ - 1
             MBKJ = MB(KJ)
             MCKJ = MC(KJ)
             MDKJ = MD(KJ)
             KL = L - KJ + 1
             IF (KL > N1) KL = N1
             KI = KL + 2
             KWA = KL+ KJ + 1
             MKB = 0
             MKC = 0
             MKD = 0
             DO K = 2, KL
                MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MKB
                MKB = INT (MT/MBASE)
                MWA(KWA-K) = MT - MBASE*MKB
                MT = MA(KI-K)*MCKJ + MWD(KWA-K) + MKC
                MKC = INT (MT/MBASE)
                MWD(KWA-K) = MT - MBASE*MKC
                MT = MA(KI-K)*MDKJ + MWE(KWA-K) + MKD
                MKD = INT (MT/MBASE)
                MWE(KWA-K) = MT - MBASE*MKD
             ENDDO
             MWA(KWA-KL-1) = MKB
             MWD(KWA-KL-1) = MKC
             MWE(KWA-KL-1) = MKD
          ENDDO

      ENDIF

!             Set KSHIFT = 1 if a shift left is necessary.

      IF (MWA(2) == 0) THEN
          KSHIFT = 1
      ELSE
          KSHIFT = 0
      ENDIF

!             The multiplications are complete.

      IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      MR = 2*MWA(NDIG+2+KSHIFT) + 1
      IF (KROUND == -1 .OR. KROUND == 2) THEN
          CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
      ELSE IF (MR >= MBASE) THEN
          IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
              IF (KROUND /= 0 .OR. NCALL > 1) THEN
                  MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
                  MWA(N1+1+KSHIFT) = 0
              ENDIF
          ELSE
              CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
          ENDIF
      ENDIF
      CALL FMMOVE(MWA,ME)

      IF ((MAS > 0 .AND. MCS > 0) .OR. (MAS < 0 .AND. MCS < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      IF (MWD(2) == 0) THEN
          KSHIFT = 1
      ELSE
          KSHIFT = 0
      ENDIF
      MR = 2*MWD(NDIG+2+KSHIFT) + 1
      IF (KROUND == -1 .OR. KROUND == 2) THEN
          CALL FMRND(MWD,NDIG,NGUARD,KSHIFT)
      ELSE IF (MR >= MBASE) THEN
          IF (MR-1 > MBASE .AND. MWD(N1+KSHIFT) < MBASE-1) THEN
              IF (KROUND /= 0 .OR. NCALL > 1) THEN
                  MWD(N1+KSHIFT) = MWD(N1+KSHIFT) + 1
                  MWD(N1+1+KSHIFT) = 0
              ENDIF
          ELSE
              CALL FMRND(MWD,NDIG,NGUARD,KSHIFT)
          ENDIF
      ENDIF
      CALL FMMOVE(MWD,MF)

      IF ((MAS > 0 .AND. MDS > 0) .OR. (MAS < 0 .AND. MDS < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      IF (MWE(2) == 0) THEN
          KSHIFT = 1
      ELSE
          KSHIFT = 0
      ENDIF
      MR = 2*MWE(NDIG+2+KSHIFT) + 1
      IF (KROUND == -1 .OR. KROUND == 2) THEN
          CALL FMRND(MWE,NDIG,NGUARD,KSHIFT)
      ELSE IF (MR >= MBASE) THEN
          IF (MR-1 > MBASE .AND. MWE(N1+KSHIFT) < MBASE-1) THEN
              IF (KROUND /= 0 .OR. NCALL > 1) THEN
                  MWE(N1+KSHIFT) = MWE(N1+KSHIFT) + 1
                  MWE(N1+1+KSHIFT) = 0
              ENDIF
          ELSE
              CALL FMRND(MWE,NDIG,NGUARD,KSHIFT)
          ENDIF
      ENDIF
      CALL FMMOVE(MWE,MG)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'FMMPYE'
          CALL FMWARN
      ENDIF

      ME(-1) = 1
      IF (MAS*MBS < 0 .AND. ME(1) /= MUNKNO .AND. ME(2) /= 0) ME(-1) = -1
      MF(-1) = 1
      IF (MAS*MCS < 0 .AND. MF(1) /= MUNKNO .AND. MF(2) /= 0) MF(-1) = -1
      MG(-1) = 1
      IF (MAS*MDS < 0 .AND. MG(1) /= MUNKNO .AND. MG(2) /= 0) MG(-1) = -1

      IF (KACCSW == 1) THEN
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(ME(2))+1))/0.69315)
          ME(0) = MIN(MACCA,MACCB,MD2B)
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MF(2))+1))/0.69315)
          MF(0) = MIN(MACCA,MACCC,MD2B)
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MG(2))+1))/0.69315)
          MG(0) = MIN(MACCA,MACCD,MD2B)
      ELSE
          ME(0) = MIN(MACCA,MACCB)
          MF(0) = MIN(MACCA,MACCC)
          MG(0) = MIN(MACCA,MACCD)
      ENDIF

  120 IF (NTRACE /= 0) THEN
          CALL FMNTR(1,ME,ME,1,1)
          IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN
              IF (NTRACE < 0) THEN
                  CALL FMNTRJ(MF,NDIG)
                  CALL FMNTRJ(MG,NDIG)
              ELSE
                  CALL FMPRNT(MF)
                  CALL FMPRNT(MG)
              ENDIF
          ENDIF
      ENDIF
      NCALL = NCALL - 1
      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMMPYE

      SUBROUTINE FMMPYI(MA,IVAL,MB)

!  MB = MA * IVAL

!  Multiply FM number MA by one word integer IVAL.

!  This routine is faster than FMMPY when IVAL*MBASE is a
!  one word integer.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER IVAL
      REAL (KIND(1.0D0)) :: MACCA,MAS,MCARRY,MD2B,MKT,MLR,MVAL
      INTEGER J,JRSSAV,KA,KB,KC,KSHIFT,N1,NGUARD,NMVAL,NV2

      IF (MBLOGS /= MBASE) CALL FMCONS
      JRSSAV = JRSIGN
      MACCA = MA(0)
      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMMPYI'
          CALL FMNTR(2,MA,MA,1,1)
          CALL FMNTRI(2,IVAL,0)
      ENDIF
      KFLAG = 0
      N1 = NDIG + 1

!             Check for special cases.

      IF (MA(2) == 0) THEN
          CALL FMEQ(MA,MB)
          IF (NTRACE /= 0) THEN
              CALL FMNTR(1,MB,MB,1,1)
          ENDIF
          NCALL = NCALL - 1
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (ABS(MA(1)) < MEXPOV .AND. ABS(IVAL) > 1) GO TO 110

      IF (MA(1) == MUNKNO) THEN
          CALL FMST2M('UNKNOWN',MB)
          KFLAG = -4
          IF (NTRACE /= 0) THEN
              CALL FMNTR(1,MB,MB,1,1)
          ENDIF
          NCALL = NCALL - 1
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (IVAL == 0) THEN
          CALL FMIM(0,MB)
          IF (NTRACE /= 0) THEN
              CALL FMNTR(1,MB,MB,1,1)
          ENDIF
          NCALL = NCALL - 1
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (ABS(IVAL) == 1) THEN
          DO J = -1, N1
             MB(J) = MA(J)
          ENDDO
          IF (MA(1) == MEXPOV) KFLAG = -5
          IF (MA(1) == MEXPUN) KFLAG = -6
          MB(-1) = MA(-1)*IVAL
          IF (NTRACE /= 0) THEN
              CALL FMNTR(1,MB,MB,1,1)
          ENDIF
          NCALL = NCALL - 1
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (MA(1) == MEXPOV) THEN
          MAS = MA(-1)
          KFLAG = -5
          CALL FMST2M('OVERFLOW',MB)
          IF ((MAS < 0 .AND. IVAL > 0) .OR.  &
              (MAS > 0 .AND. IVAL < 0))      MB(-1) = -1
          IF (NTRACE /= 0) THEN
              CALL FMNTR(1,MB,MB,1,1)
          ENDIF
          NCALL = NCALL - 1
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (MA(1) == MEXPUN) THEN
          NAMEST(NCALL) = 'FMMPYI'
          KFLAG = -4
          CALL FMWARN
          CALL FMST2M('UNKNOWN',MB)
          IF (NTRACE /= 0) THEN
              CALL FMNTR(1,MB,MB,1,1)
          ENDIF
          NCALL = NCALL - 1
          JRSIGN = JRSSAV
          RETURN
      ENDIF

!             Work with positive numbers.

  110 MAS = MA(-1)
      MVAL = ABS(IVAL)
      NMVAL = INT(MVAL)
      NV2 = NMVAL - 1

!             To leave room for the normalization, shift the product
!             to the right KSHIFT places in MWA.

      KSHIFT = INT((LOG(DBLE(MA(2)+1)*DBLE(MVAL)))/DLOGMB)

!             If IVAL is too big use FMMPY.

      IF (KSHIFT > NDIG .OR. MVAL > MAXINT/MBASE .OR.  &
          NMVAL /= ABS(IVAL) .OR. NV2 /= ABS(IVAL)-1) THEN
          CALL FMIM(IVAL,M01)
          CALL FMMPY2(MA,M01,MB)
          IF (NTRACE /= 0) THEN
              CALL FMNTR(1,MB,MB,1,1)
          ENDIF
          NCALL = NCALL - 1
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      MWA(1) = MA(1) + KSHIFT
      KA = 2 + KSHIFT
      KB = N1 + KSHIFT
      KC = NDIG + 5
      DO J = KB, KC
         MWA(J) = 0
      ENDDO

      MCARRY = 0

!             This is the main multiplication loop.

      DO J = KB, KA, -1
         MKT = MA(J-KSHIFT)*MVAL + MCARRY
         MCARRY = INT (MKT/MBASE)
         MWA(J) = MKT - MCARRY*MBASE
      ENDDO

!             Resolve the final carry.

      DO J = KA-1, 2, -1
         MKT = INT (MCARRY/MBASE)
         MWA(J) = MCARRY - MKT*MBASE
         MCARRY = MKT
      ENDDO

!             Now the first significant digit in the product is in
!             MWA(2) or MWA(3).  Round the result and move it to MB.

      IF ((MAS > 0 .AND. IVAL > 0) .OR. (MAS < 0 .AND. IVAL < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      IF (MWA(2) == 0) THEN
          MLR = 2*MWA(NDIG+3) + 1
          IF (KROUND == -1 .OR. KROUND == 2) THEN
              NGUARD = KSHIFT - 1
              CALL FMRND(MWA,NDIG,NGUARD,1)
          ELSE IF (MLR >= MBASE) THEN
              IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN
                  IF (KROUND /= 0 .OR. NCALL > 1) THEN
                      MWA(N1+1) = MWA(N1+1) + 1
                      MWA(N1+2) = 0
                  ENDIF
              ELSE
                  NGUARD = KSHIFT - 1
                  CALL FMRND(MWA,NDIG,NGUARD,1)
              ENDIF
          ENDIF
      ELSE
          MLR = 2*MWA(NDIG+2) + 1
          IF (KROUND == -1 .OR. KROUND == 2) THEN
              CALL FMRND(MWA,NDIG,KSHIFT,0)
          ELSE IF (MLR >= MBASE) THEN
              IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
                  IF (KROUND /= 0 .OR. NCALL > 1) THEN
                      MWA(N1) = MWA(N1) + 1
                      MWA(N1+1) = 0
                  ENDIF
              ELSE
                  CALL FMRND(MWA,NDIG,KSHIFT,0)
              ENDIF
          ENDIF
      ENDIF
      CALL FMMOVE(MWA,MB)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'FMMPYI'
          CALL FMWARN
      ENDIF

!             Put the sign on the result.

      MB(-1) = JRSIGN
      IF (KACCSW == 1) THEN
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
          MB(0) = MIN(MACCA,MD2B)
      ELSE
          MB(0) = MACCA
      ENDIF

      IF (NTRACE /= 0) THEN
          CALL FMNTR(1,MB,MB,1,1)
      ENDIF
      NCALL = NCALL - 1
      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMMPYI

      SUBROUTINE FMMPYI_R1(MA,IVAL)

!  MA = MA * IVAL

!  Multiply FM number MA by one word integer IVAL.

!  This routine is faster than FMMPY when IVAL*MBASE is a
!  one word integer.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER IVAL
      REAL (KIND(1.0D0)) :: MACCA,MAS,MCARRY,MD2B,MKT,MLR,MVAL
      INTEGER J,JRSSAV,KA,KB,KC,KSHIFT,N1,NGUARD,NMVAL,NV2

      IF (MBLOGS /= MBASE) CALL FMCONS
      JRSSAV = JRSIGN
      MACCA = MA(0)
      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMMPYI'
          CALL FMNTR(2,MA,MA,1,1)
          CALL FMNTRI(2,IVAL,0)
      ENDIF
      KFLAG = 0
      N1 = NDIG + 1

!             Check for special cases.

      IF (MA(2) == 0) THEN
          IF (NTRACE /= 0) THEN
              CALL FMNTR(1,MA,MA,1,1)
          ENDIF
          NCALL = NCALL - 1
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (ABS(MA(1)) < MEXPOV .AND. ABS(IVAL) > 1) GO TO 110

      IF (MA(1) == MUNKNO) THEN
          CALL FMST2M('UNKNOWN',MA)
          KFLAG = -4
          IF (NTRACE /= 0) THEN
              CALL FMNTR(1,MA,MA,1,1)
          ENDIF
          NCALL = NCALL - 1
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (IVAL == 0) THEN
          CALL FMIM(0,MA)
          IF (NTRACE /= 0) THEN
              CALL FMNTR(1,MA,MA,1,1)
          ENDIF
          NCALL = NCALL - 1
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (ABS(IVAL) == 1) THEN
          IF (MA(1) == MEXPOV) KFLAG = -5
          IF (MA(1) == MEXPUN) KFLAG = -6
          MA(-1) = MA(-1)*IVAL
          IF (NTRACE /= 0) THEN
              CALL FMNTR(1,MA,MA,1,1)
          ENDIF
          NCALL = NCALL - 1
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (MA(1) == MEXPOV) THEN
          MAS = MA(-1)
          KFLAG = -5
          CALL FMST2M('OVERFLOW',MA)
          IF ((MAS < 0 .AND. IVAL > 0) .OR.  &
              (MAS > 0 .AND. IVAL < 0))      MA(-1) = -1
          IF (NTRACE /= 0) THEN
              CALL FMNTR(1,MA,MA,1,1)
          ENDIF
          NCALL = NCALL - 1
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      IF (MA(1) == MEXPUN) THEN
          NAMEST(NCALL) = 'FMMPYI'
          KFLAG = -4
          CALL FMWARN
          CALL FMST2M('UNKNOWN',MA)
          IF (NTRACE /= 0) THEN
              CALL FMNTR(1,MA,MA,1,1)
          ENDIF
          NCALL = NCALL - 1
          JRSIGN = JRSSAV
          RETURN
      ENDIF

!             Work with positive numbers.

  110 MAS = MA(-1)
      MVAL = ABS(IVAL)
      NMVAL = INT(MVAL)
      NV2 = NMVAL - 1

!             To leave room for the normalization, shift the product
!             to the right KSHIFT places in MWA.

      KSHIFT = INT((LOG(DBLE(MA(2)+1)*DBLE(MVAL)))/DLOGMB)

!             If IVAL is too big use FMMPY.

      IF (KSHIFT > NDIG .OR. MVAL > MAXINT/MBASE .OR.  &
          NMVAL /= ABS(IVAL) .OR. NV2 /= ABS(IVAL)-1) THEN
          CALL FMIM(IVAL,M01)
          CALL FMMPY2_R1(MA,M01)
          IF (NTRACE /= 0) THEN
              CALL FMNTR(1,MA,MA,1,1)
          ENDIF
          NCALL = NCALL - 1
          JRSIGN = JRSSAV
          RETURN
      ENDIF

      MWA(1) = MA(1) + KSHIFT
      KA = 2 + KSHIFT
      KB = N1 + KSHIFT
      KC = NDIG + 5
      DO J = KB, KC
         MWA(J) = 0
      ENDDO

      MCARRY = 0

!             This is the main multiplication loop.

      DO J = KB, KA, -1
         MKT = MA(J-KSHIFT)*MVAL + MCARRY
         MCARRY = INT (MKT/MBASE)
         MWA(J) = MKT - MCARRY*MBASE
      ENDDO

!             Resolve the final carry.

      DO J = KA-1, 2, -1
         MKT = INT (MCARRY/MBASE)
         MWA(J) = MCARRY - MKT*MBASE
         MCARRY = MKT
      ENDDO

!             Now the first significant digit in the product is in
!             MWA(2) or MWA(3).  Round the result and move it to MA.

      IF ((MAS > 0 .AND. IVAL > 0) .OR. (MAS < 0 .AND. IVAL < 0)) THEN
          JRSIGN = 1
      ELSE
          JRSIGN = -1
      ENDIF
      IF (MWA(2) == 0) THEN
          MLR = 2*MWA(NDIG+3) + 1
          IF (KROUND == -1 .OR. KROUND == 2) THEN
              NGUARD = KSHIFT - 1
              CALL FMRND(MWA,NDIG,NGUARD,1)
          ELSE IF (MLR >= MBASE) THEN
              IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN
                  IF (KROUND /= 0 .OR. NCALL > 1) THEN
                      MWA(N1+1) = MWA(N1+1) + 1
                      MWA(N1+2) = 0
                  ENDIF
              ELSE
                  NGUARD = KSHIFT - 1
                  CALL FMRND(MWA,NDIG,NGUARD,1)
              ENDIF
          ENDIF
      ELSE
          MLR = 2*MWA(NDIG+2) + 1
          IF (KROUND == -1 .OR. KROUND == 2) THEN
              CALL FMRND(MWA,NDIG,KSHIFT,0)
          ELSE IF (MLR >= MBASE) THEN
              IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
                  IF (KROUND /= 0 .OR. NCALL > 1) THEN
                      MWA(N1) = MWA(N1) + 1
                      MWA(N1+1) = 0
                  ENDIF
              ELSE
                  CALL FMRND(MWA,NDIG,KSHIFT,0)
              ENDIF
          ENDIF
      ENDIF
      CALL FMMOVE(MWA,MA)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'FMMPYI'
          CALL FMWARN
      ENDIF

!             Put the sign on the result.

      MA(-1) = JRSIGN
      IF (KACCSW == 1) THEN
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315)
          MA(0) = MIN(MACCA,MD2B)
      ELSE
          MA(0) = MACCA
      ENDIF

      IF (NTRACE /= 0) THEN
          CALL FMNTR(1,MA,MA,1,1)
      ENDIF
      NCALL = NCALL - 1
      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMMPYI_R1

      SUBROUTINE FMNINT(MA,MB)

!  MB = NINT(MA)  --  MB is returned as the nearest integer to MA.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MA2,MXSAVE
      INTEGER J,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB) THEN
          CALL FMENTR('FMNINT',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMNINT'
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52-1,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,MB,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      KWRNSV = KWARN
      KWARN = 0
      CALL FMEQ2(MA,MB,NDSAVE,NDIG)
      IF (NDSAVE > INT(MA(1))) THEN
          MA2 = MA(-1)
          MB(-1) = 1
          CALL FMI2M(1,M01)
          CALL FMDIVI_R1(M01,2)
          CALL FMADD_R1(MB,M01)
          CALL FMINT(MB,M08)
          CALL FMEQ(M08,MB)
          IF (MA2 < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
      ENDIF
      KWARN = KWRNSV

!             Round the result and return.

      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMNINT

      SUBROUTINE FMNTR(NTR,MA,MB,NARG,KNAM)

!  Print FM numbers in base 10 format using FMOUT for conversion.
!  This is used for trace output from the FM routines.

!  NTR =  1 if a result of an FM call is to be printed.
!      =  2 to print input argument(s) to an FM call.

!  MA  -  the FM number to be printed.

!  MB  -  an optional second FM number to be printed.

!  NARG - the number of arguments.  NARG = 1 if only MA is to be
!         printed, and NARG = 2 if both MA and MB are to be printed.

!  KNAM - positive if the routine name is to be printed.


!  NTRACE and LVLTRC (in module FMVALS) control trace printout.

!  NTRACE = 0        No printout except warnings and errors.

!  NTRACE = 1        The result of each call to one of the routines
!                    is printed in base 10, using FMOUT.

!  NTRACE = -1       The result of each call to one of the routines
!                    is printed in internal base MBASE format.

!  NTRACE = 2        The input arguments and result of each call to one
!                    of the routines is printed in base 10, using FMOUT.

!  NTRACE = -2       The input arguments and result of each call to one
!                    of the routines is printed in base MBASE format.

!  LVLTRC defines the call level to which the trace is done.  LVLTRC = 1
!         means only FM routines called directly by the user are traced,
!         LVLTRC = K prints traces for FM routines with call levels up
!         to and including level K.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER KNAM,NTR,NARG

      CHARACTER(6) :: NAME

      IF (NTRACE == 0) RETURN
      IF (NCALL > LVLTRC) RETURN
      IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN

      IF (NTR == 2) THEN
          IF (KNAM > 0) THEN
              NAME = NAMEST(NCALL)
              WRITE (KW,"(' Input to ',A6)") NAME
          ENDIF
      ELSE
          NAME = NAMEST(NCALL)
          IF (KFLAG == 0) THEN
              WRITE (KW,  &
                     "(' ',A6,15X,'Call level =',I2,5X,'MBASE =',"  //  &
                     "I10,5X,'NDIG =',I6)"                              &
                    ) NAME,NCALL,INT(MBASE),NDIG
          ELSE
              WRITE (KW,  &
                     "(' ',A6,6X,'Call level =',I2,4X,'MBASE =',"  //  &
                     "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)"             &
                    ) NAME,NCALL,INT(MBASE),NDIG,KFLAG
          ENDIF
      ENDIF

!             Check for base MBASE internal format trace.

      IF (NTRACE < 0) THEN
          CALL FMNTRJ(MA,NDIG)
          IF (NARG == 2) CALL FMNTRJ(MB,NDIG)
      ENDIF

!             Check for base 10 trace using FMOUT.

      IF (NTRACE > 0) THEN
          CALL FMPRNT(MA)

          IF (NARG == 2) THEN
              CALL FMPRNT(MB)
          ENDIF
      ENDIF

      RETURN
      END SUBROUTINE FMNTR

      SUBROUTINE FMNTRI(NTR,N,KNAM)

!  Internal routine for trace output of integer variables.

!  NTR = 1 for output values
!        2 for input values

!  N     Integer to be printed.

!  KNAM  is positive if the routine name is to be printed.

      USE FMVALS
      IMPLICIT NONE

      INTEGER NTR,N,KNAM

      CHARACTER(6) :: NAME

      IF (NTRACE == 0) RETURN
      IF (NCALL > LVLTRC) RETURN
      IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN

      IF (NTR == 2 .AND. KNAM > 0) THEN
          NAME = NAMEST(NCALL)
          WRITE (KW,"(' Input to ',A6)") NAME
      ENDIF
      IF (NTR == 1 .AND. KNAM > 0) THEN
          NAME = NAMEST(NCALL)
          IF (KFLAG == 0) THEN
              WRITE (KW,  &
                     "(' ',A6,15X,'Call level =',I2,5X,'MBASE =',"  //  &
                     "I10,5X,'NDIG =',I6)"                              &
                    ) NAME,NCALL,INT(MBASE),NDIG
          ELSE
              WRITE (KW,  &
                     "(' ',A6,6X,'Call level =',I2,4X,'MBASE =',"  //  &
                     "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)"             &
                    ) NAME,NCALL,INT(MBASE),NDIG,KFLAG
          ENDIF
      ENDIF

      WRITE (KW,"(1X,I18)") N

      RETURN
      END SUBROUTINE FMNTRI

      SUBROUTINE FMNTRJ(MA,ND)

!  Print trace output in internal base MBASE format.  The number to
!  be printed is in MA.

!  ND is the number of base MBASE digits to be printed.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER ND

      CHARACTER(50) :: FORM
      INTEGER J,L,N,N1

      N1 = ND + 1

      L = INT(LOG10(DBLE(MBASE-1))) + 2
      N = (KSWIDE-23)/L
      IF (N > 10) N = 5*(N/5)
      IF (ND <= N) THEN
          WRITE (FORM,"(' (1X,I19,I',I2,',',I3,'I',I2,') ')") L+2, N-1, L
      ELSE
          WRITE (FORM,  &
                 "(' (1X,I19,I',I2,',',I3,'I',I2,'/"  //  &
                 "(22X,',I3,'I',I2,')) ')"                &
                ) L+2, N-1, L, N, L
      ENDIF
      WRITE (KW,FORM) INT(MA(1)),INT(MA(-1)*MA(2)),(INT(MA(J)),J=3,N1)

      RETURN
      END SUBROUTINE FMNTRJ

      SUBROUTINE FMNTRR(NTR,X,KNAM)

!  Internal routine for trace output of real variables.

!  NTR - 1 for output values
!        2 for input values

!  X   - Double precision value to be printed if NX == 1

!  KNAM - Positive if the routine name is to be printed.

      USE FMVALS
      IMPLICIT NONE

      INTEGER NTR,KNAM
      DOUBLE PRECISION X

      CHARACTER(6) :: NAME

      IF (NTRACE == 0) RETURN
      IF (NCALL > LVLTRC) RETURN
      IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN

      IF (NTR == 2 .AND. KNAM > 0) THEN
          NAME = NAMEST(NCALL)
          WRITE (KW,"(' Input to ',A6)") NAME
      ENDIF
      IF (NTR == 1 .AND. KNAM > 0) THEN
          NAME = NAMEST(NCALL)
          IF (KFLAG == 0) THEN
              WRITE (KW,  &
                     "(' ',A6,15X,'Call level =',I2,5X,'MBASE =',"  //  &
                     "I10,5X,'NDIG =',I6)"                              &
                    ) NAME,NCALL,INT(MBASE),NDIG
          ELSE
              WRITE (KW,  &
                     "(' ',A6,6X,'Call level =',I2,4X,'MBASE =',"  //  &
                     "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)"             &
                    ) NAME,NCALL,INT(MBASE),NDIG,KFLAG
          ENDIF
      ENDIF

      WRITE (KW,"(1X,D30.20)") X

      RETURN
      END SUBROUTINE FMNTRR

      SUBROUTINE FMOUT(MA,LINE,LB)

!  Convert a floating multiple precision number to a character array
!  for output.

!  MA   is an FM number to be converted to an A1 character
!       array in base 10 format
!  LINE is the CHARACTER*1 array in which the result is returned.
!  LB   is the length of LINE.

! JFORM1 and JFORM2 (in module FMVALS) determine the format of LINE.

! JFORM1 = 0  normal setting  ( .314159M+6 )
!        = 1  1PE format      ( 3.14159M+5 )
!        = 2  F   format      ( 314159.000 )

! JFORM2 = number of significant digits to display (if JFORM1 = 0, 1)
!        = number of digits after the decimal point (if JFORM1 = 2)

!          If JFORM2 == 0 and JFORM1 /= 2 then a default number of
!          digits is chosen.  The default is roughly the full precision
!          of MA.

!          If JFORM2 == 0 and JFORM1 == 2 then the number is returned in
!          integer format with no decimal point.  Rounding is done as
!          with other settings, so the value displayed is the nearest
!          integer to MA.

!  If JFORM1 == 2 and MA is too large or too small to display in the
!  requested format, it is converted using JFORM1=0, JFORM2=0.

!  LINE should be dimensioned at least LOG10(MBASE)*NDIG + 15 on a
!  32-bit machine to allow for up to 10 digit exponents.  Replace
!  15 by 20 if 48-bit integers are used, 25 for 64-bit integers, ....

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER LB
      CHARACTER LINE(LB)

      CHARACTER KCHAR
      REAL (KIND(1.0D0)) :: M2,MBSAVE,MEXP,MEXP10,MKT,MNDGMS,MS1,MS2,  &
                            MSD2,MT10,MXSAVE
      INTEGER J,JDPT,JF1SAV,JF2SAV,K,K1,K2,KA,KASAVE,KB,KC,KDIGIT,  &
              KEXP,KEXPSH,KMS2SD,KMT,KPT,KRSAVE,L,ND,NDE,NDE2,NDIGMS,  &
              NDS2,NDSAVE,NPOWER,NSD1,NSD2,NVAL,NWORD,NWORD1,NWORD2
      REAL X

      CHARACTER :: NUMB(10) = (/ '0','1','2','3','4','5','6','7','8','9' /)
      CHARACTER :: NUNKNO(12) = (/  &
                   ' ',' ',' ','U','N','K','N','O','W','N',' ',' ' /)
      CHARACTER :: NEXPOV(12) = (/  &
                   ' ',' ',' ','O','V','E','R','F','L','O','W',' ' /)
      CHARACTER :: NEXPUN(12) = (/  &
                   ' ',' ',' ','U','N','D','E','R','F','L','O','W' /)

!             To avoid recursion, FMOUT calls only internal arithmetic
!             routines (FMADD2, FMMPY2, ...), so no trace printout is
!             done during a call to FMOUT.

      KFLAG = 0
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMOUT '

!             Raise the call stack again, since the internal
!             routines don't.

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMOUT '
      DO J = 1, LB
         LINE(J) = ' '
      ENDDO

!             Check for special cases.

      IF (MA(1) == MUNKNO) THEN
          DO J = 1, 12
             LINE(J) = NUNKNO(J)
          ENDDO
          NCALL = NCALL - 2
          RETURN
      ENDIF
      IF (MA(1) == MEXPOV) THEN
          DO J = 1, 12
             LINE(J) = NEXPOV(J)
          ENDDO
          LINE(2) = '+'
          IF (MA(-1) < 0) LINE(2) = '-'
          NCALL = NCALL - 2
          RETURN
      ENDIF
      IF (MA(1) == MEXPUN) THEN
          DO J = 1, 12
             LINE(J) = NEXPUN(J)
          ENDDO
          LINE(2) = '+'
          IF (MA(-1) < 0) LINE(2) = '-'
          NCALL = NCALL - 2
          RETURN
      ENDIF
      IF (MA(2) == 0 .AND. JFORM1 == 2 .AND. JFORM2 == 0) THEN
          LINE(2) = '0'
          NCALL = NCALL - 2
          RETURN
      ENDIF

      KASAVE = KACCSW
      KACCSW = 0
      KRSAVE = KROUND
      KROUND = 1
      JF1SAV = JFORM1
      JF2SAV = JFORM2
      MBSAVE = MBASE
      NDSAVE = NDIG
      MXSAVE = MXEXP

!             ND is the number of base 10 digits required.

  110 ND = JFORM2
      IF (JFORM1 == 2 .AND. MA(1) > 0) ND = JFORM2 +  &
          INT(REAL(MA(1))*LOG10(REAL(MBASE))) + 1
      IF (ND <= 1) THEN
          K = INT(REAL(NDIG)*LOG10(REAL(MBASE)))
          ND = MAX(K,JFORM2)
      ENDIF
      IF (JFORM2 <= 0 .AND. JFORM1 <= 1) ND =  &
          INT(1.1 + REAL(NDIG-1)*LOG10(REAL(MBASE)))
      IF (ND < 2) ND = 2

      IF (LB < ND+6) THEN
          IF (JFORM1 == 2) THEN
              JFORM1 = 0
              JFORM2 = 0
              GO TO 110
          ENDIF
          GO TO 170
      ENDIF

!             Convert to the base that is the largest power of 10
!             less than MXBASE and build the output number.

      NPOWER = INT(LOG10(REAL(MXBASE)/4))
      MXEXP = MXEXP2
      MBASE = 10**NPOWER
      IF (MBLOGS /= MBASE) CALL FMCONS
      NDIG = ND/NPOWER + 3
      IF (NDIG < 2) NDIG = 2
      IF (NDIG > NDG2MX) THEN
          KFLAG = -9
          NCALL = NCALL - 1
          CALL FMWARN
          NCALL = NCALL + 1
          GO TO 170
      ENDIF

      IF (MA(2) == 0) THEN
          CALL FMIM(0,MLV4)
          GO TO 130
      ENDIF

!             Check to see if MA is already in a base that is a
!             power of ten.  If so, the conversion can be skipped.

      K = NPOWER
      DO J = 1, K
         MBASE = 10**J
         IF (MBASE == MBSAVE) THEN
             IF (MBLOGS /= MBASE) CALL FMCONS
             NPOWER = J
             NDIG = ND/NPOWER + 2
             IF (NDIG < 2) NDIG = 2
             IF (NDIG > NDG2MX) THEN
                 KFLAG = -9
                 NCALL = NCALL - 1
                 CALL FMWARN
                 NCALL = NCALL + 1
                 GO TO 170
             ENDIF
             CALL FMEQ2(MA,MLV4,NDSAVE,NDIG)
             MLV4(-1) = 1
             GO TO 130
         ENDIF
      ENDDO

      IF (MBLOGS /= MBASE) CALL FMCONS
      CALL FMIM(INT(MBSAVE),MLV2)
      NDS2 = NDSAVE + 1
      CALL FMIM(1,MLV3)
      KMT = 1

!             Convert the fraction part of MA to the new base.

      KPT = NDS2 + 1
      DO J = 3, NDS2
         KPT = KPT - 1
         IF (MA(KPT) /= 0) EXIT
      ENDDO

      KEXPSH = KPT - 1
      KDIGIT = INT(ABS(MA(2)))
      CALL FMIM(KDIGIT,MLV4)
      NDIGMS = NDIG

      DO J = 3, KPT
         KDIGIT = INT(MA(J))
         NDIG = MIN(NDIGMS,MAX(2,INT(MLV4(1)+MLV2(1))))
         CALL FMMPY2_R1(MLV4,MLV2)

         IF (KDIGIT > 0) THEN
             IF (KMT /= KDIGIT) THEN
                 NDIG = MIN(NDIGMS,MAX(2,INT(MLV2(1))))
                 CALL FMIM(KDIGIT,MLV3)
                 KMT = KDIGIT
             ENDIF
             NDIG = MIN(NDIGMS,MAX(2,INT(MAX(MLV4(1),MLV3(1)))+1))
             CALL FMADD2_R1(MLV4,MLV3)
         ENDIF
      ENDDO

!             Convert the exponent.

      NDIG = NDIGMS
      CALL FMIM(1,MLV3)
      K = ABS(INT(MA(1))-KEXPSH)
      IF (MOD(K,2) == 1) THEN
          CALL FMEQ(MLV2,MLV3)
      ELSE
          CALL FMIM(1,MLV3)
      ENDIF

  120 K = K/2
      M2 = 2
      MNDGMS = NDIGMS
      NDIG = INT(MIN(MNDGMS,MAX(M2,MLV2(1)*M2)))
      IF (K > 0) CALL FMSQR2_R1(MLV2)
      IF (MOD(K,2) == 1) THEN
          NDIG = INT(MIN(MNDGMS,MAX(M2,MLV3(1)+MLV2(1))))
          CALL FMMPY2_R1(MLV3,MLV2)
      ENDIF
      IF (K > 1) GO TO 120

      NDIG = NDIGMS
      IF (MA(1)-KEXPSH < 0) THEN
          CALL FMDIV2_R1(MLV4,MLV3)
      ELSE
          CALL FMMPY2_R1(MLV4,MLV3)
      ENDIF

!             Now MLV4 is the value of MA converted to a
!             power of ten base.

!             Convert it to a character string base 10 for output.

!             MEXP10 is the base 10 exponent.
!             KMS2SD is the number of base 10 significant digits
!                    in MLV4(2).

  130 MS1 = MLV4(1)
  140 MEXP10 = NPOWER*MLV4(1)
      KMS2SD = NPOWER
      K = INT(MBASE)
      DO J = 1, NPOWER
         K = K/10
         IF (MLV4(2) < K .AND. MLV4(2) /= 0) THEN
             MEXP10 = MEXP10 - 1
             KMS2SD = KMS2SD - 1
         ENDIF
      ENDDO

!             For printing using JFORM1 = 1, reduce the exponent to
!             account for the fact that the decimal point and first
!             significant digit will later be swapped.

      IF (JFORM1 == 1 .AND. MLV4(2) /= 0) MEXP10 = MEXP10 - 1

!             Find the position in the unpacked number for rounding.
!             NWORD is the word in which rounding is done, or zero if
!                   no rounding is necessary.
!                   NWORD is set to -1 if JFORM1 is 2 (F format) but no
!                   significant digits would be printed.  This case
!                   defaults to JFORM1 = 0.
!             NVAL gives the position within that word where rounding
!                  occurs.
!             NSD1 is the maximum number of base 10 S.D.'s in NWORD
!                  digits of base 10**NPOWER.
!             NSD2 is the number of base 10 S.D.'s needed to get ND
!                  base 10 digits after the decimal.

      NSD2 = ND
      IF (JFORM1 == 2) THEN
          MSD2 = JFORM2 + MEXP10
          IF (MSD2 > ND) THEN
              NSD2 = ND
          ELSE
              NSD2 = INT(MSD2)
          ENDIF
          NWORD = (NSD2-KMS2SD-1+NPOWER)/NPOWER + 2
          IF (NWORD < 2) NWORD = -1
          IF (NWORD > NDIG) NWORD = 0
          IF (NWORD >= 2 .AND. NSD2 <= 0) NWORD = -1
      ELSE
          NWORD = (ND-KMS2SD-1+NPOWER)/NPOWER + 2
      ENDIF
      NSD1 = KMS2SD + NPOWER*(NWORD-2)
      IF (NWORD < 2) THEN
          NVAL = 0
      ELSE
          NVAL = 10**(NSD1-NSD2)
      ENDIF

!             Now do the base 10 rounding.

      IF (NWORD >= 2) THEN
          X = 0.0
          IF (NVAL > 1) X = MOD(INT(MLV4(NWORD)),NVAL)
          IF (NWORD < NDIG+1) THEN
              X = REAL(DBLE(X) + DBLE(MLV4(NWORD+1))/DBLE(MBASE))
          ENDIF
          X = X/NVAL
          IF (X < 0.5) GO TO 150
          MS2 = MLV4(2)
          MLV4(NWORD) = INT(MLV4(NWORD)/NVAL)*NVAL
          MLV4(NWORD+1) = 0
          MLV4(NWORD+2) = 0
          MLV4(NWORD) = MLV4(NWORD) + NVAL
          IF (MLV4(NWORD) >= MBASE) THEN
              NWORD1 = NWORD - 1
              NWORD2 = NWORD - 2
              IF (NWORD > 2) THEN
                  CALL FMEQ2_R1(MLV4,NWORD1,NWORD2)
              ELSE
                  MLV4(1) = MLV4(1) + 1
                  MLV4(2) = INT(MLV4(2)/MBASE)
                  MLV4(3) = 0
              ENDIF
          ENDIF
          IF (MLV4(1) /= MS1 .OR. MLV4(2) /= MS2) GO TO 140
      ENDIF

!             Build the base 10 character string.

  150 IF (MA(-1) < 0) LINE(1) = '-'
      LINE(2) = '.'
      K = 10**KMS2SD
      L = 2
      IF (NWORD == -1) NSD2 = ND
      DO J = 1, NSD2
         K = K/10
         IF (K == 0) THEN
             K = INT(MBASE)/10
             L = L + 1
         ENDIF
         KDIGIT = INT(MLV4(L))/K
         MLV4(L) = MOD(INT(MLV4(L)),K)
         LINE(J+2) = NUMB(KDIGIT+1)
      ENDDO

      KA = NSD2 + 3
      KB = ND + 2
      IF (KB >= KA) THEN
          DO J = KA, KB
             LINE(J) = NUMB(1)
          ENDDO
      ENDIF

      LINE(ND+3) = CMCHAR
      LINE(ND+4) = '+'
      IF (MEXP10 < 0) LINE(ND+4) = '-'
      IF (MA(2) == 0) LINE(ND+4) = ' '

!             Build the digits of the base 10 exponent backwards,
!             then reverse them.

      NDE = 1
      MEXP = ABS(MEXP10)
      MT10 = 10
      DO J = 1, LB
         MKT = AINT (MEXP/MT10)
         KDIGIT = INT(MEXP-MKT*MT10)
         LINE(ND+4+J) = NUMB(KDIGIT+1)
         MEXP = MKT
         IF (MEXP == 0) EXIT

         IF (ND+5+J > LB) THEN
             DO K = 1, LB
                LINE(K) = '*'
             ENDDO
             GO TO 160
         ENDIF

         NDE = NDE + 1
      ENDDO

      NDE2 = NDE/2
      IF (NDE2 < 1) GO TO 160
      K1 = ND + 4
      K2 = ND + 5 + NDE
      DO J = 1, NDE2
         K1 = K1 + 1
         K2 = K2 - 1
         KCHAR = LINE(K1)
         LINE(K1) = LINE(K2)
         LINE(K2) = KCHAR
      ENDDO

!             If JFORM1 is 1 put the first digit left of the decimal.

  160 IF (JFORM1 == 1) THEN
          KCHAR = LINE(2)
          LINE(2) = LINE(3)
          LINE(3) = KCHAR
      ENDIF

!             If JFORM1 is 2 put the number into fixed format.

      IF (JFORM1 == 2 .AND. JFORM2 >= 0) THEN
          IF (MEXP10 <= -JFORM2 .OR. MEXP10+2 > LB) THEN
              JFORM1 = 0
              JFORM2 = 0
              MBASE = MBSAVE
              IF (MBLOGS /= MBASE) CALL FMCONS
              NDIG = NDSAVE
              MXEXP = MXSAVE
              DO J = 1, LB
                 LINE(J) = ' '
              ENDDO
              GO TO 110
          ENDIF
          KA = ND + 3
          DO J = KA, LB
             LINE(J) = NUMB(1)
          ENDDO

          KEXP = INT(MEXP10)
          IF (MEXP10 > 0) THEN
              DO J = 1, KEXP
                 LINE(J+1) = LINE(J+2)
              ENDDO
              LINE(KEXP+2) = '.'
          ENDIF

          IF (MEXP10 < 0) THEN
              KEXP = -INT(MEXP10)
              KA = 3 + KEXP
              KB = LB + 1
              KC = KB - KEXP
              DO J = KA, LB
                 KB = KB - 1
                 KC = KC - 1
                 LINE(KB) = LINE(KC)
                 LINE(KC) = NUMB(1)
              ENDDO
          ENDIF

          JDPT = 0
          DO J = 1, LB
             IF (LINE(J) == '.') JDPT = J
             IF (JDPT > 0 .AND. J > JDPT+JFORM2) LINE(J) = ' '
          ENDDO
          IF (JFORM2 == 0 .AND. JDPT > 0) LINE(KEXP+2) = ' '

      ENDIF

!             Restore values and return

      GO TO 180

!             LINE is not big enough to hold the number
!             of digits specified.

  170 KFLAG = -8
      DO J = 1, LB
         LINE(J) = '*'
      ENDDO
      NCALL = NCALL - 1
      CALL FMWARN
      NCALL = NCALL + 1

  180 MBASE = MBSAVE
      IF (MBLOGS /= MBASE) CALL FMCONS
      NDIG = NDSAVE
      MXEXP = MXSAVE
      NCALL = NCALL - 2
      KACCSW = KASAVE
      KROUND = KRSAVE
      JFORM1 = JF1SAV
      JFORM2 = JF2SAV
      RETURN
      END SUBROUTINE FMOUT

      SUBROUTINE FMPACK(MA,MP)

!  MA is packed two base NDIG digits per word and returned in MP.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MP(-1:LPACK)

      INTEGER J,KP

      KP = 2
      MP(-1) = MA(-1)
      MP(0) = MA(0)
      MP(1) = MA(1)
      MP(2) = ABS(MA(2))*MBASE + MA(3)
      IF (NDIG >= 4) THEN
          DO J = 4, NDIG, 2
             KP = KP + 1
             MP(KP) = MA(J)*MBASE + MA(J+1)
          ENDDO
      ENDIF
      IF (MOD(NDIG,2) == 1) MP(KP+1) = MA(NDIG+1)*MBASE
      RETURN
      END SUBROUTINE FMPACK

      SUBROUTINE FMPI(MA)

!  MA = pi

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      CHARACTER(155) :: STRING
      INTEGER K,KASAVE,NDMB,NDSAVE,NDSV

      IF (MBLOGS /= MBASE) CALL FMCONS
      KFLAG = 0
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMPI  '
      IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
          WRITE (KW,"(' Input to FMPI')")
      ENDIF
      KASAVE = KACCSW
      KACCSW = 0

!             Increase the working precision.

      NDSAVE = NDIG
      IF (NCALL == 1) THEN
          K = NGRD52
          NDIG = MAX(NDIG+K,2)
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWARN
              NDIG = NDSAVE
              CALL FMST2M('UNKNOWN',MA)
              GO TO 110
          ENDIF
      ENDIF

!             Check to see if pi has previously been computed
!             in base MBASE with sufficient precision.

      IF (MBSPI == MBASE .AND. NDIGPI >= NDIG) THEN
          IF (NAMEST(NCALL-1) /= 'NOEQ  ') THEN
              KACCSW = KASAVE
              CALL FMEQ2(MPISAV,MA,NDIGPI,NDSAVE)
          ENDIF
      ELSE
          NDMB = INT(150.0*2.302585/ALOGMB)
          IF (NDMB >= NDIG) THEN
              NDSV = NDIG
              NDIG = MIN(NDMB,NDG2MX)
              STRING = '3.141592653589793238462643383279502884197169'//  &
              '39937510582097494459230781640628620899862803482534211'//  &
              '7067982148086513282306647093844609550582231725359408128'
              CALL FMST2M(STRING,MPISAV)
              MPISAV(0) = NINT(NDIG*ALOGM2)
              MBSPI = MBASE
              NDIGPI = NDIG
              IF (ABS(MPISAV(1)) > 10) NDIGPI = 0
          ELSE
              NDSV = NDIG
              NDIG = MIN(NDIG+2,NDG2MX)
              CALL FMPI2(MPISAV)
              MPISAV(0) = NINT(NDIG*ALOGM2)
              MBSPI = MBASE
              NDIGPI = NDIG
              IF (ABS(MPISAV(1)) > 10) NDIGPI = 0
          ENDIF
          IF (NAMEST(NCALL-1) /= 'NOEQ  ') THEN
              KACCSW = KASAVE
              CALL FMEQ2(MPISAV,MA,NDIG,NDSAVE)
          ENDIF
          NDIG = NDSV
      ENDIF

  110 NDIG = NDSAVE
      KACCSW = KASAVE
      IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMPI

      SUBROUTINE FMPI2(MPI)

!  Internal routine to compute pi.
!  The formula used is due to S. Ramanujan:
!                                                (4n)!(1103+26390n)
!  1/pi = (sqrt(8)/9801) * sum(n=0 to infinity) --------------------
!                                               ((n!)**4)(396**(4n))
!  The result is returned in MPI.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MPI(-1:LUNPCK)
      DOUBLE PRECISION X
      REAL (KIND(1.0D0)) :: MX
      INTEGER NSTACK(19),J,K,KST,LARGE,N,NDIGRD,NDSAVE

      IF (MBLOGS /= MBASE) CALL FMCONS
      NDSAVE = NDIG
      N = -1
      CALL FMI2M(1103,MPI)
      CALL FMI2M(1,M02)
      CALL FMI2M(26390,M03)
      CALL FMI2M(1103,M04)
      MX = MXBASE**2/MBASE
      IF (MX > MXEXP2) MX = MXEXP2

  110 N = N + 1
      LARGE = INT(MX)/(4*N + 3)
      J = 4*N + 1
      IF (J > LARGE) THEN
          CALL FMMPYI_R1(M02,J)
          J = J + 1
          CALL FMMPYI_R1(M02,J)
          J = J + 1
          CALL FMMPYI_R1(M02,J)
      ELSE IF (J*(J+1) > LARGE) THEN
          K = J*(J+1)
          CALL FMMPYI_R1(M02,K)
          J = J + 2
          CALL FMMPYI_R1(M02,J)
      ELSE
          K = J*(J+1)*(J+2)
          CALL FMMPYI_R1(M02,K)
      ENDIF

      J = N + 1
      LARGE = INT(MXBASE)/J
      IF (J > LARGE) THEN
          CALL FMDIVI_R1(M02,J)
          CALL FMDIVI_R1(M02,J)
          CALL FMDIVI_R1(M02,J)
      ELSE IF (J*J > LARGE) THEN
          K = J*J
          CALL FMDIVI_R1(M02,K)
          CALL FMDIVI_R1(M02,J)
      ELSE
          K = J*J*J
          CALL FMDIVI_R1(M02,K)
      ENDIF

!             Break 4/396**4 into 1/(2178*2178*1296).

      J = 2178
      LARGE = INT(MXBASE)/J
      IF (J > LARGE) THEN
          CALL FMDIVI_R1(M02,J)
          CALL FMDIVI_R1(M02,J)
          CALL FMDIVI_R1(M02,1296)
      ELSE
          K = J*J
          CALL FMDIVI_R1(M02,K)
          CALL FMDIVI_R1(M02,1296)
      ENDIF

      NDIGRD = NDIG
      NDIG = NDSAVE
      CALL FMADD_R2(M03,M04)
      NDIG = NDIGRD
      CALL FMMPY(M02,M04,M01)

      NDIG = NDSAVE
      CALL FMADD_R1(MPI,M01)
      NDIG = MAX(2,NDSAVE - INT(MPI(1) - M01(1)))
      IF (KFLAG /= 1) GO TO 110
      NDIG = NDSAVE

      CALL FMI2M(8,M02)
      X = 8
      X = SQRT(X)
      CALL FMDPM(X,M04)
      CALL FMDIG(NSTACK,KST)
      DO J = 1, KST
         NDIG = NSTACK(J)
         CALL FMDIV(M02,M04,M01)
         CALL FMADD_R1(M04,M01)
         CALL FMDIVI_R1(M04,2)
      ENDDO
      M04(0) = NINT(NDIG*ALOGM2)
      CALL FMI2M(9801,M03)
      CALL FMMPY_R1(MPI,M04)
      CALL FMDIV_R2(M03,MPI)

      RETURN
      END SUBROUTINE FMPI2

      SUBROUTINE FMPRNT(MA)

!  Print MA in base 10 format.

!  FMPRNT can be called directly by the user for easy output
!  in M format.  MA is converted using FMOUT and printed.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      CHARACTER(20) :: FORM
      INTEGER J,K,KSAVE,L,LAST,LB,ND,NEXP

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMPRNT'
      KSAVE = KFLAG
      ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
      IF (ND < 2) ND = 2
      NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
      LB = MAX(JFORM2+NEXP,ND+NEXP)
      LB = MIN(LB,LMBUFF)
      CALL FMOUT(MA,CMBUFF,LB)
      KFLAG = KSAVE
      LAST = LB + 1
      WRITE (FORM,"(' (6X,',I3,'A1) ')") KSWIDE-7
      DO J = 1, LB
         IF (CMBUFF(LAST-J) /= ' ' .OR. J == LB) THEN
             L = LAST - J
             WRITE (KW,FORM) (CMBUFF(K),K=1,L)
             NCALL = NCALL - 1
             RETURN
         ENDIF
      ENDDO
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMPRNT

      SUBROUTINE FMPWR(MA,MB,MC)

!  MC = MA ** MB

!  If MB can be expressed exactly as a one word integer, then FMIPWR is
!  used.  This is much faster when MB is small, and using FMIPWR allows
!  MA to be negative.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MXSAVE
      INTEGER IEXTRA,INTMB,J,K,KASAVE,KFL,KOVUN,KRESLT,KWRNSV,NDSAVE

!             Convert MB to an integer before changing NDIG.

      KWRNSV = KWARN
      KWARN = 0
      CALL FMMI(MB,INTMB)
      KWARN = KWRNSV
      KFL = KFLAG

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR.  &
          MA(2) == 0 .OR. MA(-1) < 0) THEN
          CALL FMENTR('FMPWR ',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMPWR '
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52-1,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MB,MC,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

!             If the exponent is large or the base is very large,
!             raise the precision.

      IF (MA(1) /= 0) THEN
          IEXTRA = MAX(0,INT(MB(1)))+INT(LOG(ABS(REAL(MA(1))))/ALOGMB)
      ELSE
          IEXTRA = MAX(0,INT(MB(1)))
      ENDIF
      IF (MB(1)-NDIG > LOG(ALOGMB*REAL(MXEXP2))) THEN
          IEXTRA = 0
      ENDIF

      NDIG = NDIG + IEXTRA
      IF (NDIG > NDG2MX) THEN
          IF (NCALL == 1) THEN
              KFLAG = -9
              CALL FMWARN
              NDIG = NDSAVE
              CALL FMST2M('UNKNOWN',MC)
              DO J = -1, NDIG+1
                 M01(J) = MC(J)
              ENDDO
              CALL FMEXIT(M01,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
              RETURN
          ELSE
              NDIG = NDG2MX
          ENDIF
      ENDIF
      IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
          IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
      ENDIF

!             If the exponent is a small integer, call FMIPWR.

      KWRNSV = KWARN
      KWARN = 0

      MACCA = MA(0)
      MACCB = NINT(NDIG*ALOGM2)
      CALL FMEQ2(MA,M06,NDSAVE,NDIG)
      M06(0) = NINT(NDIG*ALOGM2)

      IF (KFL == 0) THEN
          CALL FMIPWR(M06,INTMB,MC)
      ELSE IF (M06(2) == 0 .OR. M06(-1) < 0) THEN
          CALL FMST2M('UNKNOWN',MC)
          KFLAG = -4
      ELSE
          CALL FMLN(M06,M13)
          CALL FMEQ(M13,M06)
          MACCB = MB(0)
          CALL FMEQ2(MB,M02,NDSAVE,NDIG)
          M02(0) = NINT(NDIG*ALOGM2)
          CALL FMMPY_R1(M06,M02)
          CALL FMEXP(M06,MC)
      ENDIF
      KWARN = KWRNSV

!             Round the result and return.

      MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)
      MC(0) = MIN(MC(0),MACCA,MACCB,MACMAX)
      DO J = -1, NDIG+1
         M01(J) = MC(J)
      ENDDO
      CALL FMEXIT(M01,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMPWR

      SUBROUTINE FM_RANDOM_NUMBER(VALUE)

!  FM_RANDOM_NUMBER generates pseudo-random numbers uniform on (0,1).
!  VALUE is returned as the next random (double precision) number.
!  Neither zero nor one will be returned in VALUE.

!  This version uses the FM package to implement a multiplicative congruential
!  generator.  Both the modulus and the multiplier are 49-digit primes, and
!  the period is over 1.0E+49.  This generator passes the spectral test, with
!  mu(2), ..., mu(6) =  3.40,   4.35,   3.98,   3.19,   3.20.

!  Then the numbers are shuffled before returning them to the calling program.
!  See the discussion of Bays and Durham shuffling in Knuth, V. 2.

!  Both the basic multiplicative congruential generator and the shuffled
!  version have passed Marsaglia's DieHard test suite for generators.

!  The typical usage is to call FM_RANDOM_SEED once with PUT defined as an
!  integer array of length 7 containing seven seed values used to initialize
!  the generator.  This initializes the table used by the mixed congruential
!  generator.  Then each call to FM_RANDOM_NUMBER gets the next random value.

!  The calling program must USE FMZM to call FM_RANDOM_SEED.  FM_RANDOM_NUMBER
!  can be used with a default seed without any calls to FM_RANDOM_SEED.

!  This example seeds the generator and then fills the array R with random
!  values between 0 and 1.

!        SEED = (/ 314159,265358,979323,846264,338327,950288,419716 /)
!        CALL FM_RANDOM_SEED(PUT=SEED)
!        DO J = 1, N
!           CALL FM_RANDOM_NUMBER(R(J))
!        ENDDO

!  In a GET= call, the seed array is returned that would later restart the
!  multiplicative congruential generator in FM_RANDOM_NUMBER at the same place
!  in the sequence, but since the table used to shuffle the output values is
!  not saved in a GET= call, the sequence may not repeat exactly.

!      SEED = (/ 314159,265358,979323,846264,338327,950288,419716 /)
!      CALL FM_RANDOM_SEED(PUT=SEED)
!      DO J = 1, 100
!         CALL FM_RANDOM_NUMBER(R(J))
!      ENDDO

!      CALL FM_RANDOM_SEED(GET=SEED)
!      DO J = 101, 200
!         CALL FM_RANDOM_NUMBER(R(J))
!      ENDDO

!      CALL FM_RANDOM_SEED(PUT=SEED)
!      DO J = 201, 300
!         CALL FM_RANDOM_NUMBER(R(J))
!      ENDDO

!      CALL FM_RANDOM_SEED(PUT=SEED)
!      DO J = 301, 400
!         CALL FM_RANDOM_NUMBER(R(J))
!      ENDDO

!  Here the seed is saved after 100 calls.  The seed is used to re-set the
!  generator after 200 calls to the same state it had after 100 calls, but
!  R(201), ..., R(300) is not the same sequence as R(101), ..., R(200)
!  because the shuffling is different.

!  However, re-setting again after 300 calls will reinitialize the shuffling
!  the same way as after 200 calls, so R(301), ..., R(400) is exactly the
!  same sequence as R(201), ..., R(300).

      USE FMVALS
      USE FMZM

      IMPLICIT NONE

      DOUBLE PRECISION VALUE,DPM,DPX,Y
      SAVE DPM,Y
      INTEGER POS_OF_LAST_DIGIT,J,JBASE,LAST_DIGIT_OF_X,LAST_DIGIT_OF_M_M1
      INTEGER :: SEED(7) = (/314159,265358,979323,846264,338327,950288,419716/)
      SAVE JBASE,LAST_DIGIT_OF_M_M1,SEED
      DOUBLE PRECISION :: MSAVE
      LOGICAL IMCOMP

!             Keep a table of recently generated numbers and shuffle the
!             order before returning them.

      INTEGER, PARAMETER :: TABLE_SIZE = 100
      DOUBLE PRECISION, SAVE :: TABLE(0:TABLE_SIZE-1)

      MSAVE = MBASE
      MBASE = MBRAND

!             START_RANDOM_SEQUENCE =  0  for normal operation.
!                                         Get the next  random value.
!                                   =  1  for an initializing call after
!                                         the user has called FM_RANDOM_SEED.
!                                         Use that value in MRNX to initialize.
!                                   = -1  for the first user call if there
!                                         was no initializing call to
!                                         FM_RANDOM_SEED.  Use a default
!                                         seed to initialize MRNX.

      IF (START_RANDOM_SEQUENCE /= 0) THEN
          IF (START_RANDOM_SEQUENCE == -1) THEN
              CALL FM_RANDOM_SEED(PUT=SEED)
          ENDIF
          START_RANDOM_SEQUENCE = 0
          CALL IMST2M('1424133622579837639401183671018194926834820238197',MRNA)
          CALL IMST2M('2070613773952029032014000773560846464373793273739',MRNM)
          LAST_DIGIT_OF_M_M1 = INT(MRNM(INT(MRNM(1))+1)) - 1
          JBASE = INT(MBASE) - 1
          CALL IMI2M(1,MRNC)
          CALL IMM2DP(MRNM,DPM)
          DPM = 1.0D0/DPM
          DO J = 0, TABLE_SIZE-1
  110        CALL IMMPYM(MRNA,MRNX,MRNM,M13)
             CALL IMADD(M13,MRNC,M10)
             CALL IMMOD(M10,MRNM,MRNX)
             CALL IMM2DP(MRNX,DPX)
             VALUE = DPX*DPM
             IF (VALUE >= 1.0D0 .OR. VALUE <= 0.0D0) GO TO 110
             TABLE(J) = VALUE
          ENDDO
          CALL IMMPYM(MRNA,MRNX,MRNM,M13)
          CALL IMADD(M13,MRNC,M10)
          CALL IMMOD(M10,MRNM,MRNX)
          CALL IMM2DP(MRNX,DPX)
          Y = DPX*DPM
      ENDIF

!             Get the next number in the sequence.

  120 CALL IMMPYM(MRNA,MRNX,MRNM,M13)
      POS_OF_LAST_DIGIT = INT(MRNX(1)) + 1
      DO J = -1, POS_OF_LAST_DIGIT
         MRNX(J) = M13(J)
      ENDDO
      LAST_DIGIT_OF_X = INT(MRNX(POS_OF_LAST_DIGIT))
      IF (LAST_DIGIT_OF_X == LAST_DIGIT_OF_M_M1) THEN
          CALL IMADD(MRNX,MRNC,M10)
          CALL IMEQ(M10,MRNX)
          IF (IMCOMP(MRNX,'GE',MRNM)) THEN
              CALL IMSUB(MRNX,MRNM,M10)
              CALL IMEQ(M10,MRNX)
          ENDIF
      ELSE IF (LAST_DIGIT_OF_X < JBASE) THEN
          MRNX(POS_OF_LAST_DIGIT) = MRNX(POS_OF_LAST_DIGIT) + 1
      ELSE
          CALL IMADD(MRNX,MRNC,M10)
          CALL IMEQ(M10,MRNX)
      ENDIF

!            Convert to double precision.

      DPX = MRNX(2)
      DO J = 3, POS_OF_LAST_DIGIT
         DPX = MBASE*DPX + MRNX(J)
      ENDDO

      DPX = DPX*DPM
      IF (DPX >= 1.0D0 .OR. DPX <= 0.0D0) GO TO 120

!             Shuffling.

      J = Y*TABLE_SIZE
      Y = TABLE(J)
      VALUE = Y
      TABLE(J) = DPX

      MBASE = MSAVE
      RETURN
      END SUBROUTINE FM_RANDOM_NUMBER

      SUBROUTINE FMRDC(MA,JSIN,JCOS,JSWAP)

!  Reduce MA using various trigonometric identities to an equivalent
!  angle between 0 and 45 degrees.  The reduction is done in radians
!  if KRAD (in module FMVALS) is 1, in degrees if KRAD is 0.
!  JSIN and JCOS are returned +1 or -1 and JSWAP is returned to indicate
!  that the sin and cos functions have been interchanged as follows:

!  JSWAP = 0 means   SIN(MA) = JSIN*SIN(returned value of MA)
!                    COS(MA) = JCOS*COS(returned value of MA)

!  JSWAP = 1 means   SIN(MA) = JSIN*COS(returned value of MA)
!                    COS(MA) = JCOS*SIN(returned value of MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER JSIN,JCOS,JSWAP
      REAL (KIND(1.0D0)) :: MA0
      DOUBLE PRECISION X
      INTEGER J,KASAVE,NDSAVE,NDSV
      LOGICAL FMCOMP

      IF (MBLOGS /= MBASE) CALL FMCONS
      JSIN = 1
      JCOS = 1
      JSWAP = 0
      NDSAVE = NDIG
      NDIG = NDIG + MAX(0,INT(MA(1)))

!             If the argument is too big, return UNKNOWN.

      IF (NDIG > NDG2MX) THEN
          KFLAG = -9
          CALL FMWARN
          NDIG = NDSAVE
          CALL FMST2M('UNKNOWN',MA)
          RETURN
      ENDIF
      MA0 = MA(0) + NINT(ALOGM2*REAL(MAX(0,INT(MA(1)))))

!             If MA is less than 1/MBASE, no reduction is needed.

      IF (MA(1) < 0) THEN
          NDIG = NDSAVE
          IF (MA(-1) < 0) THEN
              MA(-1) = 1
              JSIN = -1
          ENDIF
          RETURN
      ENDIF

      J = 1
      IF (KRAD == 1) THEN
  110     IF (MBSPI /= MBASE .OR. NDIGPI < NDIG)  THEN
              NDSV = NDIG
              NDIG = MIN(NDIG+2,NDG2MX)
              KASAVE = KACCSW
              KACCSW = 0
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'NOEQ  '
              CALL FMPI(MPISAV)
              NCALL = NCALL - 1
              KACCSW = KASAVE
              NDIG = NDSV
          ENDIF
          CALL FMEQ2(MA,M04,NDSAVE,NDIG)
          M04(0) = MA0
          IF (MA(-1) < 0) JSIN = -1
          M04(-1) = 1
          IF (M04(1) == 0) THEN
              CALL FMM2DP(M04,X)
              IF (X <= 0.75) THEN
                  NDIG = NDSAVE
                  CALL FMEQ(M04,MA)
                  RETURN
              ENDIF
          ENDIF
          CALL FMADD(MPISAV,MPISAV,M02)
          IF (FMCOMP(M04,'GE',M02)) THEN
              CALL FMDIV(M04,M02,M01)
              CALL FMINT(M01,M08)
              CALL FMEQ(M08,M01)
              CALL FMMPY_R1(M01,M02)
              CALL FMSUB_R1(M04,M01)
          ENDIF
          CALL FMEQ(MPISAV,M03)
          IF (FMCOMP(M04,'GE',M03)) THEN
              JSIN = -JSIN
              CALL FMSUB_R2(M02,M04)
          ENDIF
          CALL FMDIVI_R1(M02,4)
          IF (FMCOMP(M04,'GE',M02)) THEN
              JCOS = -JCOS
              CALL FMSUB_R2(M03,M04)
          ENDIF
          CALL FMDIVI_R1(M03,4)
          IF (FMCOMP(M04,'GE',M03)) THEN
              JSWAP = 1
              CALL FMSUB_R2(M02,M04)
          ENDIF

!             If the reduced argument is close to zero, then
!             cancellation has produced an inaccurate value.
!             Raise NDIG and do the reduction again.

          IF (J == 1 .AND. (M04(1) < 0 .OR. M04(2) == 0)) THEN
              J = 2
              IF (M04(2) == 0) THEN
                  NDIG = MIN(2*NDIG,NDG2MX)
              ELSE
                  NDIG = NDIG - INT(M04(1))
              ENDIF
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  CALL FMST2M('UNKNOWN',MA)
                  RETURN
              ENDIF
              JSIN = 1
              JCOS = 1
              JSWAP = 0
              MA0 = MA(0) + NINT(ALOGM2*REAL(-M04(1)))
              GO TO 110
          ENDIF

      ELSE

          CALL FMEQ2(MA,M04,NDSAVE,NDIG)
          M04(0) = MA0
          IF (MA(-1) < 0) JSIN = -1
          M04(-1) = 1
          IF (M04(1) == 0) THEN
              CALL FMM2DP(M04,X)
              IF (X <= 44.0) THEN
                  NDIG = NDSAVE
                  CALL FMEQ(M04,MA)
                  RETURN
              ENDIF
          ENDIF
          CALL FMI2M(360,M02)
          IF (FMCOMP(M04,'GE',M02)) THEN
              CALL FMDIV(M04,M02,M01)
              CALL FMINT(M01,M08)
              CALL FMEQ(M08,M01)
              CALL FMMPY_R1(M01,M02)
              CALL FMSUB_R1(M04,M01)
          ENDIF
          CALL FMI2M(180,M03)
          IF (FMCOMP(M04,'GE',M03)) THEN
              JSIN = -JSIN
              CALL FMSUB_R2(M02,M04)
          ENDIF
          CALL FMI2M(90,M02)
          IF (FMCOMP(M04,'GE',M02)) THEN
              JCOS = -JCOS
              CALL FMSUB_R2(M03,M04)
          ENDIF
          CALL FMI2M(45,M03)
          IF (FMCOMP(M04,'GE',M03)) THEN
              JSWAP = 1
              CALL FMSUB_R2(M02,M04)
          ENDIF

      ENDIF

!             Round the result and return.

      CALL FMEQ2(M04,MA,NDIG,NDSAVE)
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE FMRDC

      SUBROUTINE FMREAD(KREAD,MA)

!  Read MA on unit KREAD.  Multi-line numbers will have '&' as the
!  last nonblank character on all but the last line.  Only one
!  number is allowed on the line(s).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER KREAD

      CHARACTER LINE(80)
      INTEGER J,LB,NDSAVE

      IF (MBLOGS /= MBASE) CALL FMCONS
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMREAD'
      NDSAVE = NDIG
      NDIG = MIN(NDG2MX,MAX(NDIG+NGRD52,2))
      LB = 0

  110 READ (KREAD,"(80A1)",ERR=120,END=120) LINE

!             Scan the line and look for '&'

      DO J = 1, 80
         IF (LINE(J) == '&') GO TO 110
         IF (LINE(J) /= ' ') THEN
             LB = LB + 1
             IF (LB > LMBUFF) THEN
                 KFLAG = -8
                 GO TO 130
             ENDIF
             CMBUFF(LB) = LINE(J)
         ENDIF
      ENDDO

      CALL FMINP(CMBUFF,M01,1,LB)

      CALL FMEQ2(M01,MA,NDIG,NDSAVE)
      NDIG = NDSAVE
      NCALL = NCALL - 1
      RETURN

!             If there is an error, return UNKNOWN.

  120 KFLAG = -4
  130 CALL FMWARN
      NDIG = NDSAVE
      CALL FMST2M('UNKNOWN',MA)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMREAD

      SUBROUTINE FMRND(MW,ND,NGUARD,KSHIFT)

!  Round MW to ND digits (base MBASE).

!  MW is non-negative and has ND+NGUARD+KSHIFT digits.

!  NGUARD is the number of guard digits carried.
!  KSHIFT is 1 if a left shift is pending when MW(2)=0.

!  Round to position MW(ND+1+KSHIFT) using the guard digits
!  MW(ND+2+KSHIFT), ..., MW(ND+1+NGUARD+KSHIFT).

!  This routine is designed to be called only from within the FM
!  package.  The user should call FMEQU to round numbers.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MW(LMWA)
      INTEGER ND,NGUARD,KSHIFT

      REAL (KIND(1.0D0)) :: M2,MFACTR,MKT
      INTEGER J,K,KB,L

      IF (KROUND == -1 .AND. NCALL <= 1) THEN
          IF (JRSIGN == 1) RETURN
          DO J = ND+2+KSHIFT, ND+1+NGUARD+KSHIFT
             IF (MW(J) > 0) THEN
                 MW(ND+1+KSHIFT) = MW(ND+1+KSHIFT) + 1
                 MW(ND+2+KSHIFT) = 0
                 IF (MW(ND+1+KSHIFT) < MBASE) RETURN
                 L = ND + 2 + KSHIFT
                 GO TO 120
             ENDIF
          ENDDO
          RETURN
      ENDIF

      IF (KROUND == 2 .AND. NCALL <= 1) THEN
          IF (JRSIGN == -1) RETURN
          DO J = ND+2+KSHIFT, ND+1+NGUARD+KSHIFT
             IF (MW(J) > 0) THEN
                 MW(ND+1+KSHIFT) = MW(ND+1+KSHIFT) + 1
                 MW(ND+2+KSHIFT) = 0
                 IF (MW(ND+1+KSHIFT) < MBASE) RETURN
                 L = ND + 2 + KSHIFT
                 GO TO 120
             ENDIF
          ENDDO
          RETURN
      ENDIF

      IF (KROUND == 0 .AND. NCALL <= 1) RETURN
      L = ND + 2 + KSHIFT
      IF (2*(MW(L)+1) < MBASE) RETURN
      IF (2*MW(L) > MBASE) THEN
          MW(L-1) = MW(L-1) + 1
          MW(L) = 0
          IF (MW(L-1) < MBASE) RETURN
          GO TO 120
      ENDIF

!             If the first guard digit gives a value close to 1/2 then
!             further guard digits must be examined.

      M2 = 2
      IF (INT(MBASE-AINT (MBASE/M2)*M2) == 0) THEN
          IF (2*MW(L) < MBASE) RETURN
          IF (2*MW(L) == MBASE) THEN
              IF (NGUARD >= 2) THEN
                  IF (MBASE >= 1000) THEN
                      IF (MBASE < 1000000) THEN
                          MFACTR = INT(0.5D0+0.6883D0*MBASE)
                      ELSE
                          MFACTR = INT(0.5D0+0.687783D0*MBASE)
                      ENDIF
                      IF (MW(L+1) == MFACTR) RETURN
                  ENDIF
                  DO J = 2, NGUARD
                     IF (MW(L+J-1) > 0) GO TO 110
                  ENDDO
              ENDIF

!                       Round to even.

              IF (INT(MW(L-1)-AINT (MW(L-1)/M2)*M2) == 0) RETURN
          ENDIF
      ELSE
          IF (2*MW(L)+1 == MBASE) THEN
              IF (NGUARD >= 2) THEN
                  DO J = 2, NGUARD
                     IF (2*(MW(L+J-1)+1) < MBASE) RETURN
                     IF (2*MW(L+J-1) > MBASE) GO TO 110
                  ENDDO
                  IF (NGUARD <= NDIG) RETURN
                  M2 = 2
                  IF (INT(MW(L-1)-AINT (MW(L-1)/M2)*M2) == 0) THEN
                      RETURN
                  ELSE
                      GO TO 110
                  ENDIF
              ENDIF
          ENDIF
      ENDIF

  110 MW(L-1) = MW(L-1) + 1
      MW(L) = 0

!             Check whether there was a carry in the rounded digit.

  120 KB = L - 1
      IF (KB >= 3) THEN
          K = KB + 1
          DO J = 3, KB
             K = K - 1
             IF (MW(K) < MBASE) RETURN
             MKT = AINT (MW(K)/MBASE)
             MW(K-1) = MW(K-1) + MKT
             MW(K) = MW(K) - MKT*MBASE
          ENDDO
      ENDIF

!             If there is a carry in the first digit then the exponent
!             must be adjusted and the number shifted right.

      IF (MW(2) >= MBASE) THEN
          IF (KB >= 4) THEN
              K = KB + 1
              DO J = 4, KB
                 K = K - 1
                 MW(K) = MW(K-1)
              ENDDO
          ENDIF

          MKT = AINT (MW(2)/MBASE)
          IF (KB >= 3) MW(3) = MW(2) - MKT*MBASE
          MW(2) = MKT
          MW(1) = MW(1) + 1
      ENDIF

      RETURN
      END SUBROUTINE FMRND

      SUBROUTINE FMRPWR(MA,IVAL,JVAL,MB)

!  MB = MA ** (IVAL/JVAL)   rational exponentiation.

!  This routine is faster than FMPWR when IVAL and JVAL are
!  small integers.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER IVAL,JVAL
      DOUBLE PRECISION X,F
      REAL (KIND(1.0D0)) :: MA1,MA2,MAS,MACCA,MACMAX,MXSAVE
      INTEGER NSTACK(19),IJSIGN,INVERT,IVAL2,J,JVAL2,K,KASAVE,KOVUN,  &
              KRESLT,KST,KWRNSV,L,LVAL,NDSAVE
      REAL XVAL

      IF (MBLOGS /= MBASE) CALL FMCONS
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMRPWR'
      IF (NTRACE /= 0) THEN
          CALL FMNTR(2,MA,MA,1,1)
          CALL FMNTRI(2,IVAL,0)
          CALL FMNTRI(2,JVAL,0)
      ENDIF
      KOVUN = 0
      IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
      NDSAVE = NDIG
      IF (NCALL == 1) THEN
          XVAL = MAX(ABS(IVAL),ABS(JVAL))
          IF (XVAL == 0.0) XVAL = 1.0
          K = INT((5.0*REAL(DLOGTN) + 2.0*LOG(XVAL))/ALOGMB + 2.0)
          NDIG = MAX(NDIG+K,2)
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
          ENDIF
      ELSE
          XVAL = MAX(ABS(IVAL),ABS(JVAL))
          IF (XVAL == 0.0) XVAL = 1.0
          K = INT(LOG(XVAL)/ALOGMB + 1.0)
          NDIG = NDIG + K
      ENDIF
      IF (NDIG > NDG2MX) THEN
          KFLAG = -9
          CALL FMWARN
          NDIG = NDSAVE
          KRESLT = 12
          CALL FMRSLT(MA,MA,MB,KRESLT)
          IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF
      KASAVE = KACCSW
      KACCSW = 0
      MXSAVE = MXEXP
      MXEXP = MXEXP2

      MAS = MA(-1)
      MA1 = MA(1)
      MA2 = MA(2)
      MACCA = MA(0)
      CALL FMEQ2(MA,M02,NDSAVE,NDIG)
      M02(0) = NINT(NDIG*ALOGM2)

!             Use GCD-reduced positive exponents.

      IJSIGN = 1
      IVAL2 = ABS(IVAL)
      JVAL2 = ABS(JVAL)
      IF (IVAL > 0 .AND. JVAL < 0) IJSIGN = -1
      IF (IVAL < 0 .AND. JVAL > 0) IJSIGN = -1
      IF (IVAL2 > 0 .AND. JVAL2 > 0) CALL FMGCDI(IVAL2,JVAL2)

!             Check for special cases.

  110 IF (MA1 == MUNKNO .OR. JVAL2 == 0 .OR.  &
          (IJSIGN <= 0 .AND. MA2 == 0)) THEN
          CALL FMST2M('UNKNOWN',MB)
          KFLAG = -4
          GO TO 120
      ENDIF

      IF (IVAL2 == 0) THEN
          CALL FMIM(1,MB)
          GO TO 120
      ENDIF

      IF (JVAL2 == 1) THEN
          CALL FMIPWR(M02,IJSIGN*IVAL2,MB)
          GO TO 120
      ENDIF

      IF (MA2 == 0) THEN
          CALL FMEQ(MA,MB)
          GO TO 120
      ENDIF

      IF (MAS < 0) THEN
          IF (MOD(JVAL2,2) == 0) THEN
              JVAL2 = 0
              GO TO 110
          ENDIF
      ENDIF

      IF (MA1 == MEXPOV) THEN
          IF (IVAL2 < JVAL2) THEN
              JVAL2 = 0
              GO TO 110
          ENDIF
          CALL FMIM(0,MB)
          IF (IJSIGN == 1 .AND. MAS > 0) THEN
              CALL FMST2M('OVERFLOW',MB)
              KFLAG = -5
          ELSE IF (IJSIGN == -1 .AND. MAS > 0) THEN
              CALL FMST2M('UNDERFLOW',MB)
              KFLAG = -6
          ELSE IF (IJSIGN == 1 .AND. MAS < 0) THEN
              IF (MOD(IVAL2,2) == 0) THEN
                  CALL FMST2M('OVERFLOW',MB)
                  KFLAG = -5
              ELSE
                  CALL FMST2M('-OVERFLOW',MB)
                  KFLAG = -5
              ENDIF
          ELSE IF (IJSIGN == -1 .AND. MAS < 0) THEN
              IF (MOD(IVAL2,2) == 0) THEN
                  CALL FMST2M('UNDERFLOW',MB)
                  KFLAG = -6
              ELSE
                  CALL FMST2M('-UNDERFLOW',MB)
                  KFLAG = -6
              ENDIF
          ENDIF
          GO TO 120
      ENDIF

      IF (MA1 == MEXPUN) THEN
          IF (IVAL2 < JVAL2) THEN
              JVAL2 = 0
              GO TO 110
          ENDIF
          CALL FMIM(0,MB)
          IF (IJSIGN == 1 .AND. MAS > 0) THEN
              CALL FMST2M('UNDERFLOW',MB)
              KFLAG = -6
          ELSE IF (IJSIGN == -1 .AND. MAS > 0) THEN
              CALL FMST2M('OVERFLOW',MB)
              KFLAG = -5
          ELSE IF (IJSIGN == 1 .AND. MAS < 0) THEN
              IF (MOD(IVAL2,2) == 0) THEN
                  CALL FMST2M('UNDERFLOW',MB)
                  KFLAG = -6
              ELSE
                  CALL FMST2M('-UNDERFLOW',MB)
                  KFLAG = -6
              ENDIF
          ELSE IF (IJSIGN == -1 .AND. MAS < 0) THEN
              IF (MOD(IVAL2,2) == 0) THEN
                  CALL FMST2M('OVERFLOW',MB)
                  KFLAG = -5
              ELSE
                  CALL FMST2M('-OVERFLOW',MB)
                  KFLAG = -5
              ENDIF
          ENDIF
          GO TO 120
      ENDIF

!             Invert MA if MA > 1 and IVAL or JVAL is large.

      INVERT = 0
      IF (MA(1) > 0) THEN
          IF (IVAL > 5 .OR. JVAL > 5) THEN
              INVERT = 1
              CALL FMI2M(1,M01)
              CALL FMDIV_R2(M01,M02)
          ENDIF
      ENDIF

!             Generate the first approximation to ABS(MA)**(1/JVAL2).

      MA1 = M02(1)
      M02(1) = 0
      M02(-1) = 1
      CALL FMM2DP(M02,X)
      L = INT(MA1/JVAL2)
      F = MA1/DBLE(JVAL2) - L
      X = X**(1.0D0/JVAL2) * DBLE(MBASE)**F
      CALL FMDPM(X,MB)
      MB(1) = MB(1) + L
      M02(1) = MA1

!             Initialize.

      CALL FMDIG(NSTACK,KST)

!             Newton iteration.

      DO J = 1, KST
         NDIG = NSTACK(J)
         IF (J < KST) NDIG = NDIG + 1
         LVAL = JVAL2 - 1
         CALL FMIPWR(MB,LVAL,M03)
         CALL FMDIV_R2(M02,M03)
         CALL FMMPYI_R1(MB,LVAL)
         CALL FMADD_R1(MB,M03)
         CALL FMDIVI_R1(MB,JVAL2)
      ENDDO

      IF (MB(1) /= MUNKNO .AND. MB(2) /= 0 .AND. MAS < 0) MB(-1) = -MB(-1)
      CALL FMIPWR(MB,IJSIGN*IVAL2,M03)
      CALL FMEQ(M03,MB)
      IF (INVERT == 1) THEN
          CALL FMI2M(1,M01)
          CALL FMDIV_R2(M01,MB)
      ENDIF

!             Round the result and return.

  120 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
      MB(0) = MIN(MACCA,MACMAX)
      KWRNSV = KWARN
      IF (MA1 == MUNKNO) KWARN = 0
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      KWARN = KWRNSV
      RETURN
      END SUBROUTINE FMRPWR

      SUBROUTINE FMRSLT(MA,MB,MC,KRESLT)

!  Handle results that are special cases, such as overflow,
!  underflow, and unknown.

!  MA and MB are the input arguments to an FM subroutine.

!  MC is the result that is returned.

!  KRESLT is the result code from FMARGS.  Result codes handled here:

!   0 - Perform the normal operation
!   1 - The result is the first input argument
!   2 - The result is the second input argument
!   3 - The result is -OVERFLOW
!   4 - The result is +OVERFLOW
!   5 - The result is -UNDERFLOW
!   6 - The result is +UNDERFLOW
!   7 - The result is -1.0
!   8 - The result is +1.0
!  11 - The result is 0.0
!  12 - The result is UNKNOWN

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
      INTEGER KRESLT

      REAL (KIND(1.0D0)) :: MACCAB,MACCSV
      INTEGER KFSAVE

      KFSAVE = KFLAG
      MACCAB = MIN(MA(0),MB(0))
      IF (KRESLT == 1) THEN
          MACCSV = MA(0)
          CALL FMEQ(MA,MC)
          MC(0) = MACCAB
          IF (NAMEST(NCALL) == 'FMADD ' .OR.  &
              NAMEST(NCALL) == 'FMSUB ') THEN
              KFLAG = 1
              MC(0) = MACCSV
          ELSE
              KFLAG = KFSAVE
          ENDIF
          RETURN
      ENDIF

      IF (KRESLT == 2) THEN
          MACCSV = MB(0)
          CALL FMEQ(MB,MC)
          MC(0) = MACCAB
          IF (NAMEST(NCALL) == 'FMADD ') THEN
              KFLAG = 1
              MC(0) = MACCSV
          ELSE
              KFLAG = KFSAVE
          ENDIF
          IF (NAMEST(NCALL) == 'FMSUB ') THEN
              IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
              KFLAG = KFSAVE
              MC(0) = MACCSV
          ENDIF
          RETURN
      ENDIF

      IF (KRESLT == 3 .OR. KRESLT == 4) THEN
          CALL FMIM(0,MC)
          MC(1) = MEXPOV
          MC(2) = 1
          MC(0) = NINT(NDIG*ALOGM2)
          IF (KRESLT == 3) MC(-1) = -1
          MC(0) = MACCAB
          KFLAG = KFSAVE
          RETURN
      ENDIF

      IF (KRESLT == 5 .OR. KRESLT == 6) THEN
          CALL FMIM(0,MC)
          MC(1) = MEXPUN
          MC(2) = 1
          MC(0) = NINT(NDIG*ALOGM2)
          IF (KRESLT == 5) MC(-1) = -1
          MC(0) = MACCAB
          KFLAG = KFSAVE
          RETURN
      ENDIF

      IF (KRESLT == 7) THEN
          CALL FMIM(-1,MC)
          MC(0) = MACCAB
          KFLAG = KFSAVE
          RETURN
      ENDIF

      IF (KRESLT == 8) THEN
          CALL FMIM(1,MC)
          MC(0) = MACCAB
          KFLAG = KFSAVE
          RETURN
      ENDIF

      IF (KRESLT == 11) THEN
          CALL FMIM(0,MC)
          MC(0) = MACCAB
          KFLAG = KFSAVE
          RETURN
      ENDIF

      IF (KRESLT == 12 .OR. KRESLT < 0 .OR. KRESLT > 15) THEN
          CALL FMIM(0,MC)
          MC(1) = MUNKNO
          MC(2) = 1
          MC(0) = NINT(NDIG*ALOGM2)
          MC(0) = MACCAB
          KFLAG = KFSAVE
          RETURN
      ENDIF

      RETURN
      END SUBROUTINE FMRSLT

      SUBROUTINE FMSETVAR(STRING)

!  Change the value of one of the internal FM variables.
!  STRING must have the format  ' variablename = value ', with no
!         embedded blanks in variablename.

      USE FMVALS
      IMPLICIT NONE
      CHARACTER(*) :: STRING
      CHARACTER(6) :: VARNAME
      INTEGER IVAL,J,KPTEQ,KPT1,KPT2
      DOUBLE PRECISION DVAL
      REAL (KIND(1.0D0)) :: MVAL

      CHARACTER(52) :: LETTERS =  &
                    'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'

!             Find the equal sign.

      KPTEQ = INDEX(STRING,'=')
      IF (KPTEQ <= 0) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' Cannot find the equal sign in FMSETVAR.'
          WRITE (KW,*) ' Input string:  ',STRING
          RETURN
      ENDIF

!             Find the variable name.

      KPT1 = 0
      KPT2 = 0
      DO J = 1, KPTEQ-1
         IF (KPT1 == 0 .AND. STRING(J:J) /= ' ') KPT1 = J
      ENDDO
      DO J = KPTEQ-1, 1, -1
         IF (KPT2 == 0 .AND. STRING(J:J) /= ' ') KPT2 = J
      ENDDO
      IF (KPT1 == 0) THEN
          WRITE (KW,*) ' '
          WRITE (KW,*) ' Cannot find the variable name in FMSETVAR.'
          WRITE (KW,*) ' Input string:  ',STRING
          RETURN
      ENDIF
      VARNAME = '      '
      DO J = KPT1, KPT2
         IVAL = INDEX(LETTERS,STRING(J:J))
         IF (IVAL > 26 .AND. IVAL <= 52) THEN
             VARNAME(J-KPT1+1:J-KPT1+1) = LETTERS(IVAL-26:IVAL-26)
         ELSE
             VARNAME(J-KPT1+1:J-KPT1+1) = STRING(J:J)
         ENDIF
      ENDDO

!             CMCHAR is a special case, since the value is a character.

      IF (VARNAME == 'CMCHAR') THEN
          KPT1 = 0
          KPT2 = 0
          DO J = KPTEQ+1, LEN(STRING)
             IF (KPT1 == 0 .AND. STRING(J:J) /= ' ') KPT1 = J
          ENDDO
          DO J = LEN(STRING), KPTEQ+1, -1
             IF (KPT2 == 0 .AND. STRING(J:J) /= ' ') KPT2 = J
          ENDDO
          IF (KPT1 == KPT2 .AND. INDEX(LETTERS,STRING(KPT1:KPT2)) > 0) THEN
              CMCHAR = STRING(KPT1:KPT2)
          ELSE
              WRITE (KW,*) ' '
              WRITE (KW,*) ' Only a single letter is allowed after the',  &
                           ' equal sign in FMSETVAR.'
              WRITE (KW,*) ' Input string:  ',STRING
              RETURN
          ENDIF
      ENDIF

!             Convert the value after the equal sign.

      IF (KPTEQ+1 <= LEN(STRING)) THEN
          IF (INDEX(STRING(KPTEQ+1:LEN(STRING)),'=') /= 0) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' Only a single equal sign is allowed in FMSETVAR.'
              WRITE (KW,*) ' Input string:  ',STRING
              RETURN
          ENDIF
          CALL FMST2D(STRING(KPTEQ+1:LEN(STRING)),DVAL)
          IF (KFLAG /= 0) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' Invalid value after the equal sign in',  &
                           ' FMSETVAR.'
              WRITE (KW,*) ' Input string:  ',STRING
              RETURN
          ENDIF
      ELSE
          WRITE (KW,*) ' '
          WRITE (KW,*) ' Cannot find a value after the equal sign in',  &
                       ' FMSETVAR.'
          WRITE (KW,*) ' Input string:  ',STRING
          RETURN
      ENDIF

!             Check the list of variable names.

      IF (VARNAME == 'JFORM1') THEN
          JFORM1 = NINT(DVAL)
          IF (JFORM1 < 0 .OR. JFORM1 > 2) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',JFORM1,  &
                           ' is an invalid value for JFORM1'
              JFORM1 = 1
              WRITE (KW,*) '            Valid values are 0,1,2.',  &
                           '  JFORM1 was set to ',JFORM1
          ENDIF
      ELSE IF (VARNAME == 'JFORM2') THEN
          JFORM2 = NINT(DVAL)
          IF (JFORM2 < 0) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',JFORM2,  &
                           ' is an invalid value for JFORM2'
              JFORM2 = 1
              WRITE (KW,*) '            It should be nonegative.',  &
                           '  JFORM2 was set to ',JFORM2
          ENDIF
      ELSE IF (VARNAME == 'JFORMZ') THEN
          JFORMZ = NINT(DVAL)
          IF (JFORMZ < 1 .OR. JFORMZ > 3) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',JFORMZ,  &
                           ' is an invalid value for JFORMZ'
              JFORMZ = 1
              WRITE (KW,*) '            Valid values are 1,2,3.',  &
                           '  JFORMZ was set to ',JFORMZ
          ENDIF
      ELSE IF (VARNAME == 'JPRNTZ') THEN
          JPRNTZ = NINT(DVAL)
          IF (JPRNTZ < 1 .OR. JPRNTZ > 2) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',JPRNTZ,  &
                           ' is an invalid value for JPRNTZ'
              JPRNTZ = 1
              WRITE (KW,*) '            Valid values are 1,2.',  &
                           '  JPRNTZ was set to ',JPRNTZ
          ENDIF
      ELSE IF (VARNAME == 'KACCSW') THEN
          KACCSW = NINT(DVAL)
          IF (KACCSW < 0 .OR. KACCSW > 1) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',KACCSW,  &
                           ' is an invalid value for KACCSW'
              KACCSW = 0
              WRITE (KW,*) '            Valid values are 0,1.',  &
                           '  KACCSW was set to ',KACCSW
          ENDIF
      ELSE IF (VARNAME == 'KDEBUG') THEN
          KDEBUG = NINT(DVAL)
          IF (KDEBUG < 0 .OR. KDEBUG > 1) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',KDEBUG,  &
                           ' is an invalid value for KDEBUG'
              KDEBUG = 1
              WRITE (KW,*) '            Valid values are 0,1.',  &
                           '  KDEBUG was set to ',KDEBUG
          ENDIF
      ELSE IF (VARNAME == 'KESWCH') THEN
          KESWCH = NINT(DVAL)
          IF (KESWCH < 0 .OR. KESWCH > 1) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',KESWCH,  &
                           ' is an invalid value for KESWCH'
              KESWCH = 1
              WRITE (KW,*) '            Valid values are 0,1.',  &
                           '  KESWCH was set to ',KESWCH
          ENDIF
      ELSE IF (VARNAME == 'KRAD  ') THEN
          KRAD = NINT(DVAL)
          IF (KRAD < 0 .OR. KRAD > 1) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',KRAD,  &
                           ' is an invalid value for KRAD'
              KRAD = 1
              WRITE (KW,*) '            Valid values are 0,1.',  &
                           '  KRAD was set to ',KRAD
          ENDIF
      ELSE IF (VARNAME == 'KROUND') THEN
          KROUND = NINT(DVAL)
          IF (KROUND < -1 .OR. KROUND > 2) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',KROUND,  &
                           ' is an invalid value for KROUND'
              KROUND = 1
              WRITE (KW,*) '            Valid values are -1,0,1,2.',  &
                           '  KROUND was set to ',KROUND
          ENDIF
      ELSE IF (VARNAME == 'KRPERF') THEN
          KRPERF = NINT(DVAL)
          IF (KRPERF < 0 .OR. KRPERF > 1) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',KRPERF,  &
                           ' is an invalid value for KRPERF'
              KRPERF = 0
              WRITE (KW,*) '            Valid values are 0,1.',  &
                           '  KRPERF was set to ',KRPERF
          ENDIF
      ELSE IF (VARNAME == 'KSWIDE') THEN
          KSWIDE = NINT(DVAL)
          IF (KSWIDE < 10) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',KSWIDE,  &
                           ' is an invalid value for KSWIDE'
              KSWIDE = 80
              WRITE (KW,*) '            It should be 10 or more.',  &
                           '  KSWIDE was set to ',KSWIDE
          ENDIF
      ELSE IF (VARNAME == 'KW    ') THEN
          KW = NINT(DVAL)
      ELSE IF (VARNAME == 'KWARN ') THEN
          KWARN = NINT(DVAL)
          IF (KWARN < 0 .OR. KWARN > 2) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',KWARN,  &
                           ' is an invalid value for KWARN'
              KWARN = 1
              WRITE (KW,*) '            Valid values are 0,1,2.',  &
                           '  KWARN was set to ',KWARN
          ENDIF
      ELSE IF (VARNAME == 'LVLTRC') THEN
          LVLTRC = NINT(DVAL)
          IF (LVLTRC < 0) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',LVLTRC,  &
                           ' is an invalid value for LVLTRC'
              LVLTRC = 1
              WRITE (KW,*) '            It should be nonegative.',  &
                           '  LVLTRC was set to ',LVLTRC
          ENDIF
      ELSE IF (VARNAME == 'NDIG  ') THEN
          IVAL = NDIG
          NDIG = NINT(DVAL)
          IF (NDIG < 2) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',NDIG,  &
                           ' is an invalid value for NDIG'
              NDIG = IVAL
              WRITE (KW,*) '            It should be > 1.',  &
                           '  NDIG was not changed from ',NDIG
          ENDIF
          IF (NDIG > NDIGMX) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',NDIG,  &
                           ' is an invalid value for NDIG'
              NDIG = NDIGMX
              WRITE (KW,*) '            It should be <=',NDIGMX,  &
                           '.  NDIG was set to ',NDIG
          ENDIF
      ELSE IF (VARNAME == 'NTRACE') THEN
          NTRACE = NINT(DVAL)
          IF (NTRACE < -2 .OR. NTRACE > 2) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',NTRACE,  &
                           ' is an invalid value for NTRACE'
              NTRACE = 0
              WRITE (KW,*) '            Valid values are -2,-1,0,1,2.',  &
                           '  NTRACE was set to ',NTRACE
          ENDIF
      ELSE IF (VARNAME == 'MBASE ') THEN
          MVAL = MBASE
          MBASE = ANINT (DVAL)
          IF (MBASE < 2) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',MBASE,  &
                           ' is an invalid value for MBASE'
              MBASE = MVAL
              WRITE (KW,*) '            It should be > 1.',  &
                           '  MBASE was not changed from ',MBASE
          ENDIF
      ELSE IF (VARNAME == 'MXEXP ') THEN
          MXEXP = AINT (DVAL)
          IF (MXEXP < 10 .OR. MXEXP > MXEXP2/2.01D0) THEN
              WRITE (KW,*) ' '
              WRITE (KW,*) ' FMSETVAR:  Input string:  ',STRING
              WRITE (KW,*) '            ',MXEXP,  &
                           ' is an invalid value for MXEXP'
              MXEXP = INT(MXEXP2/2.01D0)
              WRITE (KW,*) '            Valid values are 10 to ',  &
                           INT(MXEXP2/2.01D0),'  MXEXP was set to ',MXEXP
          ENDIF
      ELSE
          WRITE (KW,*) ' Variable name not recognized in FMSETVAR.'
          WRITE (KW,*) ' Input string:  ',STRING
          RETURN
      ENDIF

      CALL FMCONS
      RETURN
      END SUBROUTINE FMSETVAR

      SUBROUTINE FMSIGN(MA,MB,MC)

!  MC = SIGN(MA,MB)

!  MC is set to ABS(MA) if MB is positive or zero,
!     or -ABS(MA) if MB is negative.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      INTEGER KWRNSV

      KFLAG = 0
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMSIGN'
      IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)

      KWRNSV = KWARN
      KWARN = 0
      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
          CALL FMST2M('UNKNOWN',MC)
          KFLAG = -4
      ELSE IF (MB(-1) >= 0) THEN
          CALL FMEQ(MA,MC)
          MC(-1) = 1
      ELSE
          CALL FMEQ(MA,MC)
          IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1
      ENDIF

      KWARN = KWRNSV
      IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMSIGN

      SUBROUTINE FMSIN(MA,MB)

!  MB = SIN(MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
      INTEGER J,JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NDSV

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN
          CALL FMENTR('FMSIN ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMSIN '
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,MB,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      MACCA = MA(0)
      MAS = MA(-1)
      CALL FMEQ2(MA,MB,NDSAVE,NDIG)
      MB(0) = NINT(NDIG*ALOGM2)
      MB(-1) = 1
      CALL FMEQ(MB,MWE)
      KWRNSV = KWARN
      KWARN = 0

!             Reduce the argument, convert to radians if the input is
!             in degrees, and evaluate the function.

      CALL FMRDC(MB,JSIN,JCOS,JSWAP)
      KWARN = KWRNSV
      IF (MB(1) == MUNKNO) THEN
          IF (KRAD /= 1 .OR. JSWAP == 0) THEN
              CALL FMEQ(MWE,MB)
              CALL FMRDC(MB,JSIN,JCOS,JSWAP)
              GO TO 110
          ENDIF
          IF (MBSPI /= MBASE .OR. NDIGPI < NDIG)  THEN
              NDSV = NDIG
              NDIG = MIN(NDIG+2,NDG2MX)
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'NOEQ  '
              CALL FMPI(MPISAV)
              NCALL = NCALL - 1
              NDIG = NDSV
          ENDIF
          CALL FMDIV(MWE,MPISAV,M04)
          CALL FMMPYI_R1(M04,2)
          CALL FMNINT(M04,M03)
          CALL FMMPY(M03,MPISAV,M02)
          CALL FMDIVI_R1(M02,2)
          CALL FMSUB_R2(MWE,M02)
          IF (M02(2) == 0) CALL FMULP(MWE,M02)
          CALL FMI2M(1,M04)
          CALL FMSQR_R1(M02)
          CALL FMDIVI_R1(M02,2)
          CALL FMSUB_R2(M04,M02)
          CALL FMSUB_R1(M02,M04)
          IF (M02(2) == 0) THEN
              CALL FMI2M(JSIN,MB)
          ELSE
              CALL FMEQ(MWE,MB)
              CALL FMRDC(MB,JSIN,JCOS,JSWAP)
          ENDIF
          GO TO 110
      ENDIF
      IF (KRAD == 0) THEN
          IF (MBSPI /= MBASE .OR. NDIGPI < NDIG)  THEN
              NDSV = NDIG
              NDIG = MIN(NDIG+2,NDG2MX)
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'NOEQ  '
              CALL FMPI(MPISAV)
              NCALL = NCALL - 1
              NDIG = NDSV
          ENDIF
          CALL FMMPY_R1(MB,MPISAV)
          CALL FMDIVI_R1(MB,180)
      ENDIF
      IF (MB(1) /= MUNKNO) THEN
          IF (JSWAP == 0) THEN
              IF (MB(1) < 0 .OR. NDIG <= 50) THEN
                  CALL FMSIN2(MB,M09)
                  CALL FMEQ(M09,MB)
              ELSE
                  CALL FMCOS2(MB,M09)
                  CALL FMEQ(M09,MB)
                  CALL FMI2M(1,M03)
                  CALL FMSQR_R1(MB)
                  CALL FMSUB_R2(M03,MB)
                  CALL FMSQRT_R1(MB)
              ENDIF
          ELSE
              CALL FMCOS2(MB,M09)
              CALL FMEQ(M09,MB)
          ENDIF
      ENDIF

!             Append the sign, round, and return.

      IF (JSIN == -1 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
  110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
      MB(0) = MIN(MB(0),MACCA,MACMAX)
      IF (MAS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMSIN

      SUBROUTINE FMSIN2(MA,MB)

!  Internal subroutine for MB = SIN(MA) where 0 <= MA <= 1.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
!             LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent
!             sums.  Increasing this value will begin to improve the
!             speed of SIN when the base is large and precision exceeds
!             about 1,500 decimal digits.

      REAL (KIND(1.0D0)) :: MAXVAL
      INTEGER J,J2,K,K2,KPT,KTHREE,KWRNSV,L,L2,LARGE,N2,NBOT,NDSAV1,  &
              NDSAVE,NTERM
      REAL ALOG3,ALOGT,B,T,TJ

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (MA(2) == 0) THEN
          CALL FMEQ(MA,MB)
          RETURN
      ENDIF
      NDSAVE = NDIG
      KWRNSV = KWARN
      KWARN = 0

!             Use the direct series
!                  SIN(X) = X - X**3/3! + X**5/5! - ...

!             The argument will be divided by 3**K2 before the series
!             is summed.  The series will be added as J2 concurrent
!             series.  The approximately optimal values of K2 and J2
!             are now computed to try to minimize the time required.
!             N2/2 is the approximate number of terms of the series
!             that will be needed, and L2 guard digits will be carried.

      B = REAL(MBASE)
      K = NGRD52
      T = MAX(NDIG-K,2)
      ALOG3 = LOG(3.0)
      ALOGT = LOG(T)
      TJ = 0.05*ALOGMB*T**0.3333 + 1.85
      J2 = INT(TJ)
      J2 = MAX(1,MIN(J2,LJSUMS/NDG2MX))
      K2 = INT(0.1*SQRT(T*ALOGMB/TJ) - 0.05*ALOGT + 2.5)

      L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B +  &
            REAL(MA(3))/(B*B)))/ALOG3 - 0.3)
      K2 = K2 - L
      IF (L < 0) L = 0
      IF (K2 < 0) THEN
          K2 = 0
          J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG3)) + .33)
      ENDIF
      IF (J2 <= 1) J2 = 1

      N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG3))
      L2 = INT(LOG(REAL(N2)+3.0**K2)/ALOGMB)
      NDIG = NDIG + L2
      IF (NDIG > NDG2MX) THEN
          IF (NCALL == 1) THEN
              KFLAG = -9
              CALL FMWARN
              NDIG = NDSAVE
              CALL FMST2M('UNKNOWN',MB)
              KWARN = KWRNSV
              RETURN
          ELSE
              NDIG = NDG2MX
          ENDIF
      ENDIF
      NDSAV1 = NDIG

!             Divide the argument by 3**K2.

      CALL FMEQ2(MA,M02,NDSAVE,NDIG)
      KTHREE = 1
      MAXVAL = MXBASE/3
      IF (K2 > 0) THEN
          DO J = 1, K2
             KTHREE = 3*KTHREE
             IF (KTHREE > MAXVAL) THEN
                 CALL FMDIVI_R1(M02,KTHREE)
                 KTHREE = 1
             ENDIF
          ENDDO
          IF (KTHREE > 1) CALL FMDIVI_R1(M02,KTHREE)
      ENDIF

!             Split into J2 concurrent sums and reduce NDIG while
!             computing each term in the sum as the terms get smaller.

      CALL FMEQ(M02,M03)
      NTERM = 1
      DO J = 1, J2
         NBOT = NTERM*(NTERM-1)
         IF (NBOT > 1) CALL FMDIVI_R1(M03,NBOT)
         NTERM = NTERM + 2
         KPT = (J-1)*(NDIG+3)
         CALL FMEQ(M03,MJSUMS(KPT-1))
         IF (M03(1) /= MUNKNO .AND. M03(2) /= 0) M03(-1) = -M03(-1)
      ENDDO
      CALL FMSQR_R1(M02)
      IF (M02(1) < -NDIG) GO TO 120
      CALL FMIPWR(M02,J2,MB)

  110 CALL FMMPY_R1(M03,MB)
      LARGE = INT(INTMAX/NTERM)
      DO J = 1, J2
         NBOT = NTERM*(NTERM-1)
         IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN
             CALL FMDIVI_R1(M03,NTERM)
             NBOT = NTERM - 1
             CALL FMDIVI_R1(M03,NBOT)
         ELSE
             CALL FMDIVI_R1(M03,NBOT)
         ENDIF
         KPT = (J-1)*(NDSAV1+3)
         NDIG = NDSAV1
         CALL FMADD_R1(MJSUMS(KPT-1),M03)
         IF (KFLAG /= 0) GO TO 120
         NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1))
         IF (NDIG < 2) NDIG = 2
         IF (M03(1) /= MUNKNO .AND. M03(2) /= 0) M03(-1) = -M03(-1)
         NTERM = NTERM + 2
      ENDDO
      GO TO 110

!             Next put the J2 separate sums back together.

  120 KFLAG = 0
      KPT = (J2-1)*(NDIG+3)
      CALL FMEQ(MJSUMS(KPT-1),MB)
      IF (J2 >= 2) THEN
          DO J = 2, J2
             CALL FMMPY_R2(M02,MB)
             KPT = (J2-J)*(NDIG+3)
             CALL FMADD_R1(MB,MJSUMS(KPT-1))
          ENDDO
      ENDIF

!             Reverse the effect of reducing the argument to
!             compute SIN(MA).

      NDIG = NDSAV1
      IF (K2 > 0) THEN
          CALL FMI2M(3,M02)
          DO J = 1, K2
             CALL FMSQR(MB,M03)
             CALL FMMPYI_R1(M03,-4)
             CALL FMADD_R2(M02,M03)
             CALL FMMPY_R2(M03,MB)
          ENDDO
      ENDIF

      CALL FMEQ2_R1(MB,NDSAV1,NDSAVE)
      NDIG = NDSAVE
      KWARN = KWRNSV

      RETURN
      END SUBROUTINE FMSIN2

      SUBROUTINE FMSINH(MA,MB)

!  MB = SINH(MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
      INTEGER J,K,KASAVE,KOVUN,KRESLT,NDSAVE,NMETHD

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB) THEN
          CALL FMENTR('FMSINH',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMSINH'
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,MB,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      MACCA = MA(0)
      MAS = MA(-1)
      CALL FMEQ2(MA,MB,NDSAVE,NDIG)
      IF (MA(2) == 0) THEN
          GO TO 120
      ENDIF
      MB(0) = NINT(NDIG*ALOGM2)
      MB(-1) = 1

!             Use a series for small arguments, FMEXP for large ones.

      IF (MB(1) == MUNKNO) GO TO 120
      IF (MBASE > 99) THEN
          IF (MB(1) <= 0) THEN
              NMETHD = 1
          ELSE IF (MB(1) >= 2) THEN
              NMETHD = 2
          ELSE IF (ABS(MB(2)) < 10) THEN
              NMETHD = 1
          ELSE
              NMETHD = 2
          ENDIF
      ELSE
          IF (MB(1) <= 0) THEN
              NMETHD = 1
          ELSE
              NMETHD = 2
          ENDIF
      ENDIF

      IF (NMETHD == 2) GO TO 110
      IF (MB(1) < 0 .OR. NDIG <= 50) THEN
          CALL FMSNH2(MB,M09)
          CALL FMEQ(M09,MB)
      ELSE
          CALL FMCSH2(MB,M09)
          CALL FMEQ(M09,MB)
          CALL FMI2M(1,M03)
          CALL FMSQR_R1(MB)
          CALL FMSUB_R1(MB,M03)
          CALL FMSQRT_R1(MB)
      ENDIF
      GO TO 120

  110 CALL FMEXP(MB,M12)
      CALL FMEQ(M12,MB)
      IF (MB(1) == MEXPOV) THEN
          GO TO 120
      ELSE IF (MB(1) == MEXPUN) THEN
          MB(1) = MEXPOV
          GO TO 120
      ENDIF
      IF (INT(MB(1)) <= (NDIG+1)/2) THEN
          CALL FMI2M(1,M01)
          CALL FMDIV_R1(M01,MB)
          CALL FMSUB_R1(MB,M01)
      ENDIF
      CALL FMDIVI_R1(MB,2)

!             Round and return.

  120 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
      MB(0) = MIN(MB(0),MACCA,MACMAX)
      IF (MAS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMSINH

      SUBROUTINE FMSNH2(MA,MB)

!  Internal subroutine for MB = SINH(MA).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
!             LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent
!             sums.  Increasing this value will begin to improve the
!             speed of SINH when the base is large and precision exceeds
!             about 1,500 decimal digits.

      REAL (KIND(1.0D0)) :: MAXVAL
      INTEGER J,J2,K,K2,KPT,KTHREE,KWRNSV,L,L2,LARGE,N2,NBOT,NDSAV1,  &
              NDSAVE,NTERM
      REAL ALOG3,ALOGT,B,T,TJ

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (MA(2) == 0) THEN
          CALL FMEQ(MA,MB)
          RETURN
      ENDIF
      NDSAVE = NDIG
      KWRNSV = KWARN
      KWARN = 0

!             Use the direct series
!                  SINH(X) = X + X**3/3! + X**5/5! - ...

!             The argument will be divided by 3**K2 before the series
!             is summed.  The series will be added as J2 concurrent
!             series.  The approximately optimal values of K2 and J2
!             are now computed to try to minimize the time required.
!             N2/2 is the approximate number of terms of the series
!             that will be needed, and L2 guard digits will be carried.

      B = REAL(MBASE)
      K = NGRD52
      T = MAX(NDIG-K,2)
      ALOG3 = LOG(3.0)
      ALOGT = LOG(T)
      TJ = 0.05*ALOGMB*T**0.3333 + 1.85
      J2 = INT(TJ)
      J2 = MAX(1,MIN(J2,LJSUMS/NDG2MX))
      K2 = INT(0.1*SQRT(T*ALOGMB/TJ) - 0.05*ALOGT + 2.5)

      L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B +  &
            REAL(MA(3))/(B*B)))/ALOG3 - 0.3)
      K2 = K2 - L
      IF (L < 0) L = 0
      IF (K2 < 0) THEN
          K2 = 0
          J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG3)) + .33)
      ENDIF
      IF (J2 <= 1) J2 = 1

      N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG3))
      L2 = INT(LOG(REAL(N2)+3.0**K2)/ALOGMB)
      NDIG = NDIG + L2
      IF (NDIG > NDG2MX) THEN
          IF (NCALL == 1) THEN
              KFLAG = -9
              CALL FMWARN
              NDIG = NDSAVE
              CALL FMST2M('UNKNOWN',MB)
              KWARN = KWRNSV
              RETURN
          ELSE
              NDIG = NDG2MX
          ENDIF
      ENDIF
      NDSAV1 = NDIG

!             Divide the argument by 3**K2.

      CALL FMEQ2(MA,M02,NDSAVE,NDIG)
      KTHREE = 1
      MAXVAL = MXBASE/3
      IF (K2 > 0) THEN
          DO J = 1, K2
             KTHREE = 3*KTHREE
             IF (KTHREE > MAXVAL) THEN
                 CALL FMDIVI_R1(M02,KTHREE)
                 KTHREE = 1
             ENDIF
          ENDDO
          IF (KTHREE > 1) CALL FMDIVI_R1(M02,KTHREE)
      ENDIF

!             Split into J2 concurrent sums and reduce NDIG while
!             computing each term in the sum as the terms get smaller.

      CALL FMEQ(M02,M03)
      NTERM = 1
      DO J = 1, J2
         NBOT = NTERM*(NTERM-1)
         IF (NBOT > 1) CALL FMDIVI_R1(M03,NBOT)
         NTERM = NTERM + 2
         KPT = (J-1)*(NDIG+3)
         CALL FMEQ(M03,MJSUMS(KPT-1))
      ENDDO
      CALL FMSQR_R1(M02)
      IF (M02(1) < -NDIG) GO TO 120
      CALL FMIPWR(M02,J2,MB)

  110 CALL FMMPY_R1(M03,MB)
      LARGE = INT(INTMAX/NTERM)
      DO J = 1, J2
         NBOT = NTERM*(NTERM-1)
         IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN
             CALL FMDIVI_R1(M03,NTERM)
             NBOT = NTERM - 1
             CALL FMDIVI_R1(M03,NBOT)
         ELSE
             CALL FMDIVI_R1(M03,NBOT)
         ENDIF
         KPT = (J-1)*(NDSAV1+3)
         NDIG = NDSAV1
         CALL FMADD_R1(MJSUMS(KPT-1),M03)
         IF (KFLAG /= 0) GO TO 120
         NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1))
         IF (NDIG < 2) NDIG = 2
         NTERM = NTERM + 2
      ENDDO
      GO TO 110

!             Next put the J2 separate sums back together.

  120 KFLAG = 0
      KPT = (J2-1)*(NDIG+3)
      CALL FMEQ(MJSUMS(KPT-1),MB)
      IF (J2 >= 2) THEN
          DO J = 2, J2
             CALL FMMPY_R2(M02,MB)
             KPT = (J2-J)*(NDIG+3)
             CALL FMADD_R1(MB,MJSUMS(KPT-1))
          ENDDO
      ENDIF

!             Reverse the effect of reducing the argument to
!             compute SINH(MA).

      NDIG = NDSAV1
      IF (K2 > 0) THEN
          CALL FMI2M(3,M02)
          DO J = 1, K2
             CALL FMSQR(MB,M03)
             CALL FMMPYI_R1(M03,4)
             CALL FMADD_R2(M02,M03)
             CALL FMMPY_R2(M03,MB)
          ENDDO
      ENDIF

      CALL FMEQ2_R1(MB,NDSAV1,NDSAVE)
      NDIG = NDSAVE
      KWARN = KWRNSV

      RETURN
      END SUBROUTINE FMSNH2

      SUBROUTINE FMSP2M(X,MA)

!  MA = X

!  Convert a single precision number to FM format.

!  This version tries to convert the single precision machine
!  number to FM with accuracy of nearly full FM precision.
!  If conversion to FM with approximately double precision accuracy
!  is good enough, it is faster to CALL FMDPM(DBLE(X),MA)

      USE FMVALS
      IMPLICIT NONE

      REAL X
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      DOUBLE PRECISION XDP,Y,YT
      INTEGER K

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMSP2M'
      XDP = DBLE(X)
      IF (NTRACE /= 0) CALL FMNTRR(2,XDP,1)

!             Check to see if X is exactly a small integer.  If so,
!             converting as an integer is better.
!             Also see if X is exactly a small integer divided by
!             a small power of two.

      Y = MXEXP2
      IF (ABS(XDP) < Y) THEN
          K = INT(XDP)
          Y = K
          IF (Y == XDP) THEN
              CALL FMIM(K,MA)
              GO TO 110
          ENDIF
      ENDIF
      IF (ABS(XDP) < 1.0D0) THEN
          Y = 4096.0D0 * XDP
          K = INT(Y)
          YT = K
          IF (Y == YT) THEN
              CALL FMIM(K,MA)
              CALL FMDIVI_R1(MA,4096)
              GO TO 110
          ENDIF
      ENDIF

      CALL FMDM2(XDP,MA)

  110 IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMSP2M

      SUBROUTINE FMSQR(MA,MB)

!  MB = MA*MA    Faster than using FMMPY.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMSQR '
          CALL FMNTR(2,MA,MA,1,1)

          CALL FMSQR2(MA,MB)

          CALL FMNTR(1,MB,MB,1,1)
      ELSE
          CALL FMSQR2(MA,MB)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMSQR

      SUBROUTINE FMSQR2(MA,MB)

!  MB = MA*MA.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MACCA,MAXMAX,MAXMWA,MBJ,MBKJ,MBM1,  &
                            MBNORM,MD2B,MK,MKA,MKT,MMAX,MR,MT
      INTEGER J,JM1,JRSSAV,K,KB,KI,KJ,KL,KNZ,KOVUN,KSHIFT,KWA,  &
              L,N1,NGUARD

      IF (MBLOGS /= MBASE) CALL FMCONS
      JRSSAV = JRSIGN
      IF (ABS(MA(1)) > MEXPAB .OR. KDEBUG == 1 .OR.  &
          MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          IF (MA(1) == MUNKNO) KOVUN = 2
          NCALL = NCALL + 1
          CALL FMMPY2(MA,MA,MB)
          NCALL = NCALL - 1
          IF ((KFLAG < 0 .AND. KOVUN == 0) .OR.  &
              (KFLAG == -4 .AND. KOVUN == 1)) THEN
              NAMEST(NCALL) = 'FMSQR '
              CALL FMWARN
          ENDIF
          GO TO 120
      ELSE IF (MA(2) == 0) THEN
          CALL FMEQ(MA,MB)
          GO TO 120
      ENDIF
      KFLAG = 0
      MAXMAX = 0

      MACCA = MA(0)
      N1 = NDIG + 1
      MWA(1) = MA(1) + MA(1)

!             NGUARD is the number of guard digits used.

      IF (NCALL > 1) THEN
          NGUARD = NGRD22
          IF (NGUARD > NDIG) NGUARD = NDIG
      ELSE
          NGUARD = NGRD52
          IF (NGUARD > NDIG) NGUARD = NDIG
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 10
          ENDIF
      ENDIF
      IF (MA(2)*MA(2) < MBASE .AND. NGUARD < 3) NGUARD = 3

      L = N1 + NGUARD
      MWA(L+1) = 0

!             The multiplication loop begins here.

!             MBNORM is the minimum number of digits that can be
!                    multiplied before normalization is required.
!             MAXMWA is an upper bound on the size of values in MWA
!                    divided by (MBASE-1).  It is used to determine
!                    whether to normalize before the next digit is
!                    multiplied.

      MBM1 = MBASE - 1
      MBNORM = AINT (MAXINT/(MBM1*MBM1))
      MMAX = INTMAX - MBASE
      MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX)
      IF (MBNORM > 1) THEN
          MBJ = MA(2)

!             Count the trailing zeros in MA.

          IF (MA(N1) /= 0) THEN
              KNZ = N1
          ELSE
              DO J = NDIG, 2, -1
                 IF (MA(J) /= 0) THEN
                     KNZ = J
                     GO TO 110
                 ENDIF
              ENDDO
          ENDIF

  110     MWA(2) = 0
          MWA(3) = 0
          DO K = NDIG+2, L
             MWA(K) = 0
          ENDDO

!             (Inner Loop)

          DO K = 3, N1
             MWA(K+1) = MA(K)*MBJ
          ENDDO
          MAXMWA = MBJ
          DO J = 3, MIN(L/2,N1)
             MBJ = MA(J)
             IF (MBJ /= 0) THEN
                 MAXMWA = MAXMWA + MBJ
                 JM1 = J - 1
                 KL = MIN(KNZ,L-JM1)

!                       Major (Inner Loop)

                 DO K = 2*J, JM1+KL
                    MWA(K) = MWA(K) + MA(K-JM1)*MBJ
                 ENDDO
             ENDIF

             IF (MAXMWA > MMAX) THEN
                 MAXMAX = MAX(MAXMAX,MAXMWA)
                 MAXMWA = 0

!                       Normalization is only required for the
!                       range of digits currently changing in MWA.

                 DO KB = JM1+KL, 2*J, -1
                    MKT = INT (MWA(KB)/MBASE)
                    MWA(KB-1) = MWA(KB-1) + MKT
                    MWA(KB) = MWA(KB) - MKT*MBASE
                 ENDDO
             ENDIF
          ENDDO

!             Double MWA, add the square terms, and perform
!             the final normalization.  (Inner Loop)

          IF (2*MAX(MAXMAX,MAXMWA)+MBASE > MMAX) THEN
              DO KB = L, 4, -1
                 MKT = INT (MWA(KB)/MBASE)
                 MWA(KB-1) = MWA(KB-1) + MKT
                 MWA(KB) = MWA(KB) - MKT*MBASE
              ENDDO
          ENDIF

          DO J = 3, L-1, 2
             IF ((J+1)/2 <= N1) THEN
                 MKA = MA((J+1)/2)
                 MWA(J) = 2*MWA(J) + MKA*MKA
                 MWA(J+1) = 2*MWA(J+1)
             ELSE
                 MWA(J) = 2*MWA(J)
                 MWA(J+1) = 2*MWA(J+1)
             ENDIF
          ENDDO
          IF (MOD(L,2) == 1) THEN
              IF ((L+1)/2 <= N1) THEN
                  MKA = MA((L+1)/2)
                  MWA(L) = 2*MWA(L) + MKA*MKA
              ELSE
                  MWA(L) = 2*MWA(L)
              ENDIF
          ENDIF

          DO KB = L, 3, -1
             MKT = INT (MWA(KB)/MBASE)
             MWA(KB-1) = MWA(KB-1) + MKT
             MWA(KB) = MWA(KB) - MKT*MBASE
          ENDDO

      ELSE

!             If normalization must be done for each digit, combine
!             the two loops and normalize as the digits are multiplied.

          DO J = 2, L
             MWA(J) = 0
          ENDDO
          KJ = NDIG + 2
          DO J = 2, N1
             KJ = KJ - 1
             MBKJ = MA(KJ)
             IF (MBKJ == 0) CYCLE
             KL = L - KJ + 1
             IF (KL > N1) KL = N1
             KI = KL + 2
             KWA = KL+ KJ + 1
             MK = 0
             DO K = 2, KL
                MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MK
                MK = INT (MT/MBASE)
                MWA(KWA-K) = MT - MBASE*MK
             ENDDO
             MWA(KWA-KL-1) = MK
          ENDDO

      ENDIF

!             Set KSHIFT = 1 if a shift left is necessary.

      IF (MWA(2) == 0) THEN
          KSHIFT = 1
      ELSE
          KSHIFT = 0
      ENDIF

!             The multiplication is complete.
!             Round the result and move it to MB.

      JRSIGN = 1
      MR = 2*MWA(NDIG+2+KSHIFT) + 1
      IF (KROUND == -1 .OR. KROUND == 2) THEN
          CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
      ELSE IF (MR >= MBASE) THEN
          IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
              IF (KROUND /= 0 .OR. NCALL > 1) THEN
                  MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
                  MWA(N1+1+KSHIFT) = 0
              ENDIF
          ELSE
              CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
          ENDIF
      ENDIF
      CALL FMMOVE(MWA,MB)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'FMSQR '
          CALL FMWARN
      ENDIF

      IF (KACCSW == 1) THEN
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
          MB(0) = MIN(MACCA,MD2B)
      ELSE
          MB(0) = MACCA
      ENDIF
  120 MB(-1) = 1
      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMSQR2

      SUBROUTINE FMSQR_R1(MA)

!  MA = MA*MA    Faster than using FMMPY.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMSQR '
          CALL FMNTR(2,MA,MA,1,1)

          CALL FMSQR2_R1(MA)

          CALL FMNTR(1,MA,MA,1,1)
      ELSE
          CALL FMSQR2_R1(MA)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMSQR_R1

      SUBROUTINE FMSQR2_R1(MA)

!  MA = MA*MA.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MACCA,MAXMAX,MAXMWA,MBJ,MBKJ,MBM1,  &
                            MBNORM,MD2B,MK,MKA,MKT,MMAX,MR,MT
      INTEGER J,JM1,JRSSAV,K,KB,KI,KJ,KL,KNZ,KOVUN,KSHIFT,KWA,  &
              L,N1,NGUARD

      IF (MBLOGS /= MBASE) CALL FMCONS
      JRSSAV = JRSIGN
      IF (ABS(MA(1)) > MEXPAB .OR. KDEBUG == 1 .OR.  &
          MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          IF (MA(1) == MUNKNO) KOVUN = 2
          NCALL = NCALL + 1
          CALL FMMPY2(MA,MA,M07)
          CALL FMEQ(M07,MA)
          NCALL = NCALL - 1
          IF ((KFLAG < 0 .AND. KOVUN == 0) .OR.  &
              (KFLAG == -4 .AND. KOVUN == 1)) THEN
              NAMEST(NCALL) = 'FMSQR '
              CALL FMWARN
          ENDIF
          GO TO 120
      ELSE IF (MA(2) == 0) THEN
          GO TO 120
      ENDIF
      KFLAG = 0
      MAXMAX = 0

      MACCA = MA(0)
      N1 = NDIG + 1
      MWA(1) = MA(1) + MA(1)

!             NGUARD is the number of guard digits used.

      IF (NCALL > 1) THEN
          NGUARD = NGRD22
          IF (NGUARD > NDIG) NGUARD = NDIG
      ELSE
          NGUARD = NGRD52
          IF (NGUARD > NDIG) NGUARD = NDIG
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NGUARD = NDIG + 10
          ENDIF
      ENDIF
      IF (MA(2)*MA(2) < MBASE .AND. NGUARD < 3) NGUARD = 3

      L = N1 + NGUARD
      MWA(L+1) = 0

!             The multiplication loop begins here.

!             MBNORM is the minimum number of digits that can be
!                    multiplied before normalization is required.
!             MAXMWA is an upper bound on the size of values in MWA
!                    divided by (MBASE-1).  It is used to determine
!                    whether to normalize before the next digit is
!                    multiplied.

      MBM1 = MBASE - 1
      MBNORM = AINT (MAXINT/(MBM1*MBM1))
      MMAX = INTMAX - MBASE
      MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX)
      IF (MBNORM > 1) THEN
          MBJ = MA(2)

!             Count the trailing zeros in MA.

          IF (MA(N1) /= 0) THEN
              KNZ = N1
          ELSE
              DO J = NDIG, 2, -1
                 IF (MA(J) /= 0) THEN
                     KNZ = J
                     GO TO 110
                 ENDIF
              ENDDO
          ENDIF

  110     MWA(2) = 0
          MWA(3) = 0
          DO K = NDIG+2, L
             MWA(K) = 0
          ENDDO

!             (Inner Loop)

          DO K = 3, N1
             MWA(K+1) = MA(K)*MBJ
          ENDDO
          MAXMWA = MBJ
          DO J = 3, MIN(L/2,N1)
             MBJ = MA(J)
             IF (MBJ /= 0) THEN
                 MAXMWA = MAXMWA + MBJ
                 JM1 = J - 1
                 KL = MIN(KNZ,L-JM1)

!                       Major (Inner Loop)

                 DO K = 2*J, JM1+KL
                    MWA(K) = MWA(K) + MA(K-JM1)*MBJ
                 ENDDO
             ENDIF

             IF (MAXMWA > MMAX) THEN
                 MAXMAX = MAX(MAXMAX,MAXMWA)
                 MAXMWA = 0

!                       Normalization is only required for the
!                       range of digits currently changing in MWA.

                 DO KB = JM1+KL, 2*J, -1
                    MKT = INT (MWA(KB)/MBASE)
                    MWA(KB-1) = MWA(KB-1) + MKT
                    MWA(KB) = MWA(KB) - MKT*MBASE
                 ENDDO
             ENDIF
          ENDDO

!             Double MWA, add the square terms, and perform
!             the final normalization.  (Inner Loop)

          IF (2*MAX(MAXMAX,MAXMWA)+MBASE > MMAX) THEN
              DO KB = L, 4, -1
                 MKT = INT (MWA(KB)/MBASE)
                 MWA(KB-1) = MWA(KB-1) + MKT
                 MWA(KB) = MWA(KB) - MKT*MBASE
              ENDDO
          ENDIF

          DO J = 3, L-1, 2
             IF ((J+1)/2 <= N1) THEN
                 MKA = MA((J+1)/2)
                 MWA(J) = 2*MWA(J) + MKA*MKA
                 MWA(J+1) = 2*MWA(J+1)
             ELSE
                 MWA(J) = 2*MWA(J)
                 MWA(J+1) = 2*MWA(J+1)
             ENDIF
          ENDDO
          IF (MOD(L,2) == 1) THEN
              IF ((L+1)/2 <= N1) THEN
                  MKA = MA((L+1)/2)
                  MWA(L) = 2*MWA(L) + MKA*MKA
              ELSE
                  MWA(L) = 2*MWA(L)
              ENDIF
          ENDIF

          DO KB = L, 3, -1
             MKT = INT (MWA(KB)/MBASE)
             MWA(KB-1) = MWA(KB-1) + MKT
             MWA(KB) = MWA(KB) - MKT*MBASE
          ENDDO

      ELSE

!             If normalization must be done for each digit, combine
!             the two loops and normalize as the digits are multiplied.

          DO J = 2, L
             MWA(J) = 0
          ENDDO
          KJ = NDIG + 2
          DO J = 2, N1
             KJ = KJ - 1
             MBKJ = MA(KJ)
             IF (MBKJ == 0) CYCLE
             KL = L - KJ + 1
             IF (KL > N1) KL = N1
             KI = KL + 2
             KWA = KL+ KJ + 1
             MK = 0
             DO K = 2, KL
                MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MK
                MK = INT (MT/MBASE)
                MWA(KWA-K) = MT - MBASE*MK
             ENDDO
             MWA(KWA-KL-1) = MK
          ENDDO

      ENDIF

!             Set KSHIFT = 1 if a shift left is necessary.

      IF (MWA(2) == 0) THEN
          KSHIFT = 1
      ELSE
          KSHIFT = 0
      ENDIF

!             The multiplication is complete.
!             Round the result and move it to MA.

      JRSIGN = 1
      MR = 2*MWA(NDIG+2+KSHIFT) + 1
      IF (KROUND == -1 .OR. KROUND == 2) THEN
          CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
      ELSE IF (MR >= MBASE) THEN
          IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
              IF (KROUND /= 0 .OR. NCALL > 1) THEN
                  MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
                  MWA(N1+1+KSHIFT) = 0
              ENDIF
          ELSE
              CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
          ENDIF
      ENDIF
      CALL FMMOVE(MWA,MA)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'FMSQR '
          CALL FMWARN
      ENDIF

      IF (KACCSW == 1) THEN
          MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315)
          MA(0) = MIN(MACCA,MD2B)
      ELSE
          MA(0) = MACCA
      ENDIF
  120 MA(-1) = 1
      JRSIGN = JRSSAV
      RETURN
      END SUBROUTINE FMSQR2_R1

      SUBROUTINE FMSQRT(MA,MB)

!  MB = SQRT(MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      DOUBLE PRECISION X,XB
      REAL (KIND(1.0D0)) :: MA1,MACCA,MD2B,MKE,MXSAVE
      INTEGER NSTACK(19),J,K,KASAVE,KMA1,KOVUN,KRESLT,KST,NDSAVE

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0 .OR. MA(-1) < 0) THEN
          CALL FMENTR('FMSQRT',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          IF (NTRACE /= 0) THEN
              NAMEST(NCALL) = 'FMSQRT'
              CALL FMNTR(2,MA,MA,1,1)
          ENDIF
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52-1,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  NAMEST(NCALL) = 'FMSQRT'
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,MB,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF
      IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
          IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
      ENDIF

      MA1 = MA(1)

      MACCA = MA(0)
      CALL FMEQ2(MA,M02,NDSAVE,NDIG)
      M02(0) = NINT(NDIG*ALOGM2)

!             Generate the first approximation.

      M02(1) = 0
      CALL FMM2DP(M02,X)
      X = SQRT(X)
      MKE = MA1/2
      KMA1 = INT(ABS(MA1))
      IF (MOD(KMA1,2) == 1) THEN
          XB = MBASE
          X = X*SQRT(XB)
          MKE = (MA1-1)/2
      ENDIF
      CALL FMDPM(X,MB)
      MB(1) = MB(1) + MKE

!             Initialize.

      M02(1) = MA1
      CALL FMDIG(NSTACK,KST)

!             Newton iteration.

      DO J = 1, KST
         NDIG = NSTACK(J)
         CALL FMDIV(M02,MB,M01)
         CALL FMADD_R1(MB,M01)
         CALL FMDIVI_R1(MB,2)
      ENDDO

!             Round the result and return.

      IF (KASAVE == 1) THEN
          MD2B = NINT((NDSAVE-1)*ALOGM2+LOG(REAL(ABS(MB(2))+1))/0.69315)
          MB(0) = MIN(MACCA,MD2B)
      ELSE
          MB(0) = MACCA
      ENDIF
      MB(-1) = 1
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,0)
      RETURN
      END SUBROUTINE FMSQRT

      SUBROUTINE FMSQRT_R1(MA)

!  MA = SQRT(MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      DOUBLE PRECISION X,XB
      REAL (KIND(1.0D0)) :: MA1,MACCA,MD2B,MKE,MXSAVE
      INTEGER NSTACK(19),J,K,KASAVE,KMA1,KOVUN,KRESLT,KST,NDSAVE

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0 .OR. MA(-1) < 0) THEN
          CALL FMENTR('FMSQRT',MA,MA,1,1,M07,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) THEN
              CALL FMEQ(M07,MA)
              RETURN
          ENDIF
      ELSE
          NCALL = NCALL + 1
          IF (NTRACE /= 0) THEN
              NAMEST(NCALL) = 'FMSQRT'
              CALL FMNTR(2,MA,MA,1,1)
          ENDIF
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52-1,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  NAMEST(NCALL) = 'FMSQRT'
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,M07,KRESLT)
                  CALL FMEQ(M07,MA)
                  IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF
      IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
          IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
      ENDIF

      MA1 = MA(1)

      MACCA = MA(0)
      CALL FMEQ2(MA,M02,NDSAVE,NDIG)
      M02(0) = NINT(NDIG*ALOGM2)

!             Generate the first approximation.

      M02(1) = 0
      CALL FMM2DP(M02,X)
      X = SQRT(X)
      MKE = MA1/2
      KMA1 = INT(ABS(MA1))
      IF (MOD(KMA1,2) == 1) THEN
          XB = MBASE
          X = X*SQRT(XB)
          MKE = (MA1-1)/2
      ENDIF
      CALL FMDPM(X,MA)
      MA(1) = MA(1) + MKE

!             Initialize.

      M02(1) = MA1
      CALL FMDIG(NSTACK,KST)

!             Newton iteration.

      DO J = 1, KST
         NDIG = NSTACK(J)
         CALL FMDIV(M02,MA,M01)
         CALL FMADD_R1(MA,M01)
         CALL FMDIVI_R1(MA,2)
      ENDDO

!             Round the result and return.

      IF (KASAVE == 1) THEN
          MD2B = NINT((NDSAVE-1)*ALOGM2+LOG(REAL(ABS(MA(2))+1))/0.69315)
          MA(0) = MIN(MACCA,MD2B)
      ELSE
          MA(0) = MACCA
      ENDIF
      MA(-1) = 1
      DO J = -1, NDIG+1
         M01(J) = MA(J)
      ENDDO
      CALL FMEXIT(M01,MA,NDSAVE,MXSAVE,KASAVE,0)
      RETURN
      END SUBROUTINE FMSQRT_R1

      SUBROUTINE FMST2D(STRING,X)

!  STRING contains a free-format number that is converted to double
!  precision and returned in X.

!  The input number may be in integer or any real format.
!  The convention is made that if no digits appear before 'E' then 1.0
!  is assumed.  For example 'E6' is converted as '1.0E+6'.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(*) :: STRING
      INTEGER J,JSTATE,KDIGFL,KEXP,KPT,KSIGN,KSIGNX,KSTART,KSTOP,  &
              KTYPE,KVAL,N2
      DOUBLE PRECISION X,F1,F2

      INTEGER :: JTRANS(8,4) = RESHAPE(  (/    &
                   2, 9, 9, 9, 9, 7, 9, 9,  &
                   3, 3, 3, 5, 5, 8, 8, 8,  &
                   4, 4, 4, 9, 9, 9, 9, 9,  &
                   6, 6, 6, 6, 6, 9, 9, 9   /)  &
        , (/ 8,4 /) )

      CHARACTER :: KBLANK = ' '

      JSTATE = 1
      KSIGN = 1
      F1 = 0.0D0
      F2 = 0.0D0
      N2 = 0
      KSIGNX = 1
      KEXP = 0
      KSTART = 1
      KSTOP = LEN(STRING)
      KFLAG = 0

!             KDIGFL will be 1 if any digits are found before 'E'.

      KDIGFL = 0

!             Initialize two hash tables that are used for character
!             look-up during input conversion.

      IF (LHASH == 0) CALL FMHTBL

!             Scan the number.

      DO J = KSTART, KSTOP
         IF (STRING(J:J) == KBLANK) CYCLE
         KPT = ICHAR(STRING(J:J))
         IF (KPT < LHASH1 .OR. KPT > LHASH2) THEN
             WRITE (KW,  &
                "(/' Error in input conversion.'/"                        //  &
                "' ICHAR function was out of range for the current',"     //  &
                "' dimensions.'/' ICHAR(''',A,''') gave the value ',"     //  &
                "I12,', which is outside the currently'/' dimensioned',"  //  &
                "' bounds of (',I5,':',I5,') for variables KHASHT ',"     //  &
                "'and KHASHV.'/' Re-define the two parameters ',"         //  &
                "'LHASH1 and LHASH2 so the dimensions will'/' contain',"  //  &
                "' all possible output values from ICHAR.'//)"                &
                   ) STRING(J:J),KPT,LHASH1,LHASH2
             KTYPE = 5
             KVAL  = 0
         ELSE
             KTYPE = KHASHT(KPT)
             KVAL  = KHASHV(KPT)
         ENDIF
         IF (KTYPE >= 5) GO TO 110

         JSTATE = JTRANS(JSTATE,KTYPE)

         SELECT CASE (JSTATE)

!             State 2.  Sign of the number.

         CASE (2)
             KSIGN = KVAL

!             State 3.  Digits before a decimal point.

         CASE (3)
             KDIGFL = 1
             F1 = 10.0D0*F1 + KVAL

!             State 4.  Decimal point

         CASE (4)
             CYCLE

!             State 5.  Digits after a decimal point.

         CASE (5)
             KDIGFL = 1
             F2 = 10.0D0*F2 + KVAL
             N2 = N2 + 1

!             State 6.  Precision indicator.

         CASE (6)
             IF (KDIGFL == 0) F1 = 1.0D0

!             State 7.  Sign of the exponent.

         CASE (7)
             KSIGNX = KVAL

!             State 8.  Digits of the exponent.

         CASE (8)
             KEXP = 10*KEXP + KVAL

         CASE DEFAULT
             GO TO 110

         END SELECT

      ENDDO

!             Form the number and return.

      KEXP = KSIGNX*KEXP
      X = KSIGN*(F1 + F2/10.0D0**N2)*10.0D0**KEXP

      RETURN

!             Error in converting the number.

  110 X = -1.0D+31
      KFLAG = -4
      RETURN
      END SUBROUTINE FMST2D

      SUBROUTINE FMST2M(STRING,MA)

!  MA = STRING

!  Convert a character string to FM format.
!  This is often more convenient than using FMINP, which converts an
!  array of CHARACTER*1 values.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(*) :: STRING
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      INTEGER J,LB,KFSAVE

      IF (MBLOGS /= MBASE) CALL FMCONS
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMST2M'
      LB = MIN(LEN(STRING),LMBUFF)
      KFSAVE = KFLAG

      DO J = 1, LB
         CMBUFF(J) = STRING(J:J)
      ENDDO
      CALL FMINP(CMBUFF,MA,1,LB)

      IF (KFSAVE /= 0) KFLAG = KFSAVE
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMST2M

      SUBROUTINE FMSUB(MA,MB,MC)

!  MC = MA - MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      INTEGER KFLG1

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMSUB '
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)

          KFLG1 = 0
          IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1
          IF (MB(2) == 0) KFLG1 = 0

!             FMADD2 will negate MB and add.

          KSUB = 1
          CALL FMADD2(MA,MB,MC)
          KSUB = 0

!             If MA was smaller than MB, then KFLAG = 1 returned from
!             FMADD means the result from FMSUB is the opposite of the
!             input argument of larger magnitude, so reset KFLAG.

          IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0

          IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
      ELSE
          KFLG1 = 0
          IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1
          IF (MB(2) == 0) KFLG1 = 0
          KSUB = 1
          CALL FMADD2(MA,MB,MC)
          KSUB = 0
          IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMSUB

      SUBROUTINE FMSUB_R1(MA,MB)

!  MA = MA - MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      INTEGER KFLG1

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMSUB '
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)

          KFLG1 = 0
          IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1
          IF (MB(2) == 0) KFLG1 = 0

!             FMADD2 will negate MB and add.

          KSUB = 1
          CALL FMADD2_R1(MA,MB)
          KSUB = 0

!             If MA was smaller than MB, then KFLAG = 1 returned from
!             FMADD means the result from FMSUB is the opposite of the
!             input argument of larger magnitude, so reset KFLAG.

          IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0

          IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
      ELSE
          KFLG1 = 0
          IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1
          IF (MB(2) == 0) KFLG1 = 0
          KSUB = 1
          CALL FMADD2_R1(MA,MB)
          KSUB = 0
          IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMSUB_R1

      SUBROUTINE FMSUB_R2(MA,MB)

!  MB = MA - MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      INTEGER KFLG1

      NCALL = NCALL + 1
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'FMSUB '
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)

          KFLG1 = 0
          IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1
          IF (MB(2) == 0) KFLG1 = 0

!             FMADD2 will negate MB and add.

          KSUB = 1
          CALL FMADD2_R2(MA,MB)
          KSUB = 0

!             If MA was smaller than MB, then KFLAG = 1 returned from
!             FMADD means the result from FMSUB is the opposite of the
!             input argument of larger magnitude, so reset KFLAG.

          IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0

          IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
      ELSE
          KFLG1 = 0
          IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1
          IF (MB(2) == 0) KFLG1 = 0
          KSUB = 1
          CALL FMADD2_R2(MA,MB)
          KSUB = 0
          IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMSUB_R2

      SUBROUTINE FMTAN(MA,MB)

!  MB = TAN(MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
      INTEGER J,JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,NDSAVE,NDSV

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN
          CALL FMENTR('FMTAN ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMTAN '
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52-1,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,MB,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      MACCA = MA(0)
      MAS = MA(-1)
      CALL FMEQ2(MA,MB,NDSAVE,NDIG)
      MB(0) = NINT(NDIG*ALOGM2)
      MB(-1) = 1

!             Reduce the argument, convert to radians if the input is
!             in degrees, and evaluate the function.

      CALL FMRDC(MB,JSIN,JCOS,JSWAP)
      IF (MB(1) == MUNKNO) GO TO 110
      IF (MB(2) == 0) THEN
          IF (JSWAP == 1) THEN
              KFLAG = -4
              CALL FMWARN
              CALL FMST2M('UNKNOWN',MB)
          ENDIF
          GO TO 110
      ENDIF
      IF (KRAD == 0) THEN
          IF (MBSPI /= MBASE .OR. NDIGPI < NDIG)  THEN
              NDSV = NDIG
              NDIG = MIN(NDIG+2,NDG2MX)
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'NOEQ  '
              CALL FMPI(MPISAV)
              NCALL = NCALL - 1
              NDIG = NDSV
          ENDIF
          CALL FMMPY_R1(MB,MPISAV)
          CALL FMDIVI_R1(MB,180)
      ENDIF
      IF (MB(1) /= MUNKNO) THEN
          IF (JSWAP == 0) THEN
              IF (MB(1) < 0) THEN
                  CALL FMSIN2(MB,M09)
                  CALL FMEQ(M09,MB)
                  MB(-1) = JSIN*MB(-1)
                  CALL FMSQR(MB,M03)
                  CALL FMI2M(1,M02)
                  CALL FMSUB_R2(M02,M03)
                  CALL FMSQRT(M03,M04)
                  M04(-1) = JCOS*M04(-1)
                  CALL FMDIV_R1(MB,M04)
              ELSE
                  CALL FMCOS2(MB,M09)
                  CALL FMEQ(M09,MB)
                  MB(-1) = JCOS*MB(-1)
                  CALL FMSQR(MB,M03)
                  CALL FMI2M(1,M02)
                  CALL FMSUB_R2(M02,M03)
                  CALL FMSQRT(M03,M04)
                  M04(-1) = JSIN*M04(-1)
                  CALL FMDIV_R2(M04,MB)
              ENDIF
          ELSE
              IF (MB(1) < 0) THEN
                  CALL FMSIN2(MB,M09)
                  CALL FMEQ(M09,MB)
                  MB(-1) = JCOS*MB(-1)
                  CALL FMSQR(MB,M03)
                  CALL FMI2M(1,M02)
                  CALL FMSUB_R2(M02,M03)
                  CALL FMSQRT(M03,M04)
                  M04(-1) = JSIN*M04(-1)
                  CALL FMDIV_R2(M04,MB)
              ELSE
                  CALL FMCOS2(MB,M09)
                  CALL FMEQ(M09,MB)
                  MB(-1) = JSIN*MB(-1)
                  CALL FMSQR(MB,M03)
                  CALL FMI2M(1,M02)
                  CALL FMSUB_R2(M02,M03)
                  CALL FMSQRT(M03,M04)
                  M04(-1) = JCOS*M04(-1)
                  CALL FMDIV_R1(MB,M04)
              ENDIF
          ENDIF
      ENDIF

!             Round and return.

  110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
      MB(0) = MIN(MB(0),MACCA,MACMAX)
      IF (MAS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMTAN

      SUBROUTINE FMTANH(MA,MB)

!  MB = TANH(MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
      INTEGER J,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE
      REAL X,XT

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB) THEN
          CALL FMENTR('FMTANH',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMTANH'
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = MAX(NGRD52-1,2)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,MB,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      KWRNSV = KWARN
      KWARN = 0
      MAS = MA(-1)

      MACCA = MA(0)
      CALL FMEQ2(MA,MB,NDSAVE,NDIG)
      IF (MA(2) == 0) THEN
          GO TO 110
      ENDIF
      MB(0) = NINT(NDIG*ALOGM2)
      MB(-1) = 1

      IF (MA(1) >= 1) THEN
          XT = REAL((NDIG+1)/2)*ALOGMB
          K = INT(LOG(XT)/ALOGMB)
          IF (MA(1) > K+1) THEN
              CALL FMI2M(1,MB)
              GO TO 110
          ELSE
              X = REAL(MB(2)*MBASE+MB(3)+1)*REAL(MBASE)**INT(MB(1)-2)
              IF (X > XT+5.0) THEN
                  CALL FMI2M(1,MB)
                  GO TO 110
              ENDIF
          ENDIF
      ENDIF
      IF (MB(1) == 0 .AND. NDIG < 50) THEN
          CALL FMEXP2(MB,M09)
          CALL FMEQ(M09,MB)
          CALL FMSQR_R1(MB)
          CALL FMI2M(1,M02)
          CALL FMSUB(MB,M02,M03)
          CALL FMADD_R2(MB,M02)
          CALL FMDIV(M03,M02,MB)
          GO TO 110
      ENDIF
      IF (MB(1) >= 0 .AND. MB(2) /= 0) THEN
          CALL FMCOSH(MB,M13)
          CALL FMEQ(M13,MB)
          IF (MB(1) > NDIG) THEN
              IF (MAS > 0) THEN
                  CALL FMI2M(1,MB)
                  GO TO 110
              ELSE
                  CALL FMI2M(-1,MB)
                  GO TO 110
              ENDIF
          ENDIF
          CALL FMSQR(MB,M03)
          CALL FMI2M(-1,M02)
          CALL FMADD_R1(M03,M02)
          CALL FMSQRT_R1(M03)
          CALL FMDIV_R2(M03,MB)
      ELSE
          CALL FMSINH(MB,M13)
          CALL FMEQ(M13,MB)
          CALL FMSQR(MB,M03)
          CALL FMI2M(1,M02)
          CALL FMADD_R1(M03,M02)
          CALL FMSQRT_R1(M03)
          CALL FMDIV_R1(MB,M03)
      ENDIF

!             Round and return.

  110 KWARN = KWRNSV
      MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
      MB(0) = MIN(MB(0),MACCA,MACMAX)
      IF (MAS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMTANH

      SUBROUTINE FMTRAP(MA)

!  If MA has overflowed or underflowed, replace it by the appropriate
!  symbol.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      IF (NCALL <= 0) RETURN
      IF (MA(1) > MXEXP+1) THEN
          IF (MA(-1) > 0) THEN
              CALL FMIM(0,MA)
              MA(1) = MEXPOV
              MA(2) = 1
              MA(0) = NINT(NDIG*ALOGM2)
          ELSE
              CALL FMIM(0,MA)
              MA(1) = MEXPOV
              MA(2) = 1
              MA(-1) = -1
              MA(0) = NINT(NDIG*ALOGM2)
          ENDIF
          KFLAG = -5
      ENDIF
      IF (MA(1) < -MXEXP) THEN
          IF (MA(-1) > 0) THEN
              CALL FMIM(0,MA)
              MA(1) = MEXPUN
              MA(2) = 1
              MA(0) = NINT(NDIG*ALOGM2)
          ELSE
              CALL FMIM(0,MA)
              MA(1) = MEXPUN
              MA(2) = 1
              MA(-1) = -1
              MA(0) = NINT(NDIG*ALOGM2)
          ENDIF
          KFLAG = -6
      ENDIF

      RETURN
      END SUBROUTINE FMTRAP

      SUBROUTINE FMULP(MA,MB)

!  MB = The value of one Unit in the Last Place of MA at the current
!       base and precision.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MA1
      INTEGER J,KWRNSV,N1

      IF (MBLOGS /= MBASE) CALL FMCONS
      KFLAG = 0
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMULP '
      IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)

      MA1 = MA(1)
      N1 = NDIG + 1
      DO J = 3, N1
         MWA(J) = 0
      ENDDO
      MWA(2) = 1
      MWA(1) = MA(1) - NDIG + 1
      IF (MA(2) == 0 .OR. MA(1) >= MEXPOV) THEN
          KFLAG = -4
          IF (MA1 /= MUNKNO) CALL FMWARN
          CALL FMST2M('UNKNOWN',MB)
      ELSE
          KWRNSV = KWARN
          IF (MA1 == MEXPUN) KWARN = 0
          IF (MA(-1) < 0) THEN
              CALL FMMOVE(MWA,MB)
              MB(-1) = 1
              IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1
          ELSE
              CALL FMMOVE(MWA,MB)
              MB(-1) = 1
          ENDIF
          IF (KFLAG < 0) THEN
              NAMEST(NCALL) = 'FMULP '
              CALL FMWARN
          ENDIF
          KWARN = KWRNSV
      ENDIF
      MB(0) = NINT(NDIG*ALOGM2)

      IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMULP

      SUBROUTINE FMUNPK(MP,MA)

!  MP is unpacked and the value returned in MA.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MP(-1:LPACK)

      INTEGER J,KP

      KP = 2
      MA(-1) = MP(-1)
      MA(0) = MP(0)
      MA(1) = MP(1)
      MA(2) = AINT (ABS(MP(2))/MBASE)
      MA(3) = ABS(MP(2)) - MA(2)*MBASE
      IF (NDIG >= 4) THEN
          DO J = 4, NDIG, 2
             KP = KP + 1
             MA(J) = AINT (MP(KP)/MBASE)
             MA(J+1) = MP(KP) - MA(J)*MBASE
          ENDDO
      ENDIF
      IF (MOD(NDIG,2) == 1) THEN
          MA(NDIG+1) = AINT (MP(KP+1)/MBASE)
      ENDIF
      RETURN
      END SUBROUTINE FMUNPK

      SUBROUTINE FMVARS

!  Write the values of the FM global variables in module FMVALS.

      USE FMVALS
      IMPLICIT NONE

      WRITE (KW,*) ' '
      WRITE (KW,*) ' Current values of the FM global variables.'
      WRITE (KW,*) ' '
      WRITE (KW,*) ' ALOGM2 = ',ALOGM2
      WRITE (KW,*) ' ALOGMB = ',ALOGMB
      WRITE (KW,*) ' ALOGMT = ',ALOGMT
      WRITE (KW,*) ' ALOGMX = ',ALOGMX
      WRITE (KW,*) ' CMCHAR = ',CMCHAR
      WRITE (KW,*) ' DLOGEB = ',DLOGEB
      WRITE (KW,*) ' DLOGMB = ',DLOGMB
      WRITE (KW,*) ' DLOGPI = ',DLOGPI
      WRITE (KW,*) ' DLOGTN = ',DLOGTN
      WRITE (KW,*) ' DLOGTP = ',DLOGTP
      WRITE (KW,*) ' DLOGTW = ',DLOGTW
      WRITE (KW,*) ' DPEPS  = ',DPEPS
      WRITE (KW,*) ' DPMAX  = ',DPMAX
      WRITE (KW,*) ' DPPI   = ',DPPI
      WRITE (KW,*) ' INTMAX = ',INTMAX
      WRITE (KW,*) ' IUNKNO = ',IUNKNO
      WRITE (KW,*) ' JFORM1 = ',JFORM1
      WRITE (KW,*) ' JFORM2 = ',JFORM2
      WRITE (KW,*) ' JFORMZ = ',JFORMZ
      WRITE (KW,*) ' JPRNTZ = ',JPRNTZ
      WRITE (KW,*) ' KACCSW = ',KACCSW
      WRITE (KW,*) ' KDEBUG = ',KDEBUG
      WRITE (KW,*) ' KESWCH = ',KESWCH
      WRITE (KW,*) ' KFLAG  = ',KFLAG
      WRITE (KW,*) ' KPTIMP = ',KPTIMP
      WRITE (KW,*) ' KPTIMU = ',KPTIMU
      WRITE (KW,*) ' KRAD   = ',KRAD
      WRITE (KW,*) ' KROUND = ',KROUND
      WRITE (KW,*) ' KRPERF = ',KRPERF
      WRITE (KW,*) ' KSUB   = ',KSUB
      WRITE (KW,*) ' KSWIDE = ',KSWIDE
      WRITE (KW,*) ' KW     = ',KW
      WRITE (KW,*) ' KWARN  = ',KWARN
      WRITE (KW,*) ' LHASH  = ',LHASH
      WRITE (KW,*) ' LHASH1 = ',LHASH1
      WRITE (KW,*) ' LHASH2 = ',LHASH2
      WRITE (KW,*) ' LJSUMS = ',LJSUMS
      WRITE (KW,*) ' LMBERN = ',LMBERN
      WRITE (KW,*) ' LMBUFF = ',LMBUFF
      WRITE (KW,*) ' LMBUFZ = ',LMBUFZ
      WRITE (KW,*) ' LMWA   = ',LMWA
      WRITE (KW,*) ' LPACK  = ',LPACK
      WRITE (KW,*) ' LPACKZ = ',LPACKZ
      WRITE (KW,*) ' LUNPCK = ',LUNPCK
      WRITE (KW,*) ' LUNPKZ = ',LUNPKZ
      WRITE (KW,*) ' LVLTRC = ',LVLTRC
      WRITE (KW,*) ' MAXINT = ',MAXINT
      WRITE (KW,*) ' MBASE  = ',MBASE
      WRITE (KW,*) ' MBLOGS = ',MBLOGS
      WRITE (KW,*) ' MBS2PI = ',MBS2PI
      WRITE (KW,*) ' MBSBRN = ',MBSBRN
      WRITE (KW,*) ' MBSE   = ',MBSE
      WRITE (KW,*) ' MBSEUL = ',MBSEUL
      WRITE (KW,*) ' MBSGAM = ',MBSGAM
      WRITE (KW,*) ' MBSLB  = ',MBSLB
      WRITE (KW,*) ' MBSLI  = ',MBSLI
      WRITE (KW,*) ' MBSPI  = ',MBSPI
      WRITE (KW,*) ' MEXPAB = ',MEXPAB
      WRITE (KW,*) ' MEXPOV = ',MEXPOV
      WRITE (KW,*) ' MEXPUN = ',MEXPUN
      WRITE (KW,*) ' MUNKNO = ',MUNKNO
      WRITE (KW,*) ' MXBASE = ',MXBASE
      WRITE (KW,*) ' MXEXP  = ',MXEXP
      WRITE (KW,*) ' MXEXP2 = ',MXEXP2
      WRITE (KW,*) ' NBITS  = ',NBITS
      WRITE (KW,*) ' NCALL  = ',NCALL
      WRITE (KW,*) ' NDG2MX = ',NDG2MX
      WRITE (KW,*) ' NDG2PI = ',NDG2PI
      WRITE (KW,*) ' NDGEUL = ',NDGEUL
      WRITE (KW,*) ' NDGGAM = ',NDGGAM
      WRITE (KW,*) ' NDIG   = ',NDIG
      WRITE (KW,*) ' NDIGE  = ',NDIGE
      WRITE (KW,*) ' NDIGLB = ',NDIGLB
      WRITE (KW,*) ' NDIGLI = ',NDIGLI
      WRITE (KW,*) ' NDIGMX = ',NDIGMX
      WRITE (KW,*) ' NDIGPI = ',NDIGPI
      WRITE (KW,*) ' NGRD21 = ',NGRD21
      WRITE (KW,*) ' NGRD22 = ',NGRD22
      WRITE (KW,*) ' NGRD52 = ',NGRD52
      WRITE (KW,*) ' NTRACE = ',NTRACE
      WRITE (KW,*) ' NUMBRN = ',NUMBRN
      WRITE (KW,*) ' NWDBRN = ',NWDBRN
      WRITE (KW,*) ' RUNKNO = ',RUNKNO
      WRITE (KW,*) ' SPMAX  = ',SPMAX
      WRITE (KW,*) ' '

      RETURN
      END SUBROUTINE FMVARS

      SUBROUTINE FMWARN

!  Called by one of the FM routines to print a warning message
!  if any error condition arises in that routine.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(6) :: NAME
      INTEGER NCS

      IF (KFLAG >= 0 .OR. NCALL /= 1 .OR. KWARN <= 0) RETURN
      NCS = NCALL
      NAME = NAMEST(NCALL)
      WRITE (KW,  &
             "(/' Error of type KFLAG =',I3,"  //  &
             "' in FM package in routine ',A6/)"   &
            ) KFLAG,NAME

  110 NCALL = NCALL - 1
      IF (NCALL > 0) THEN
          NAME = NAMEST(NCALL)
          WRITE (KW,"( ' called from ',A6)") NAME
          GO TO 110
      ENDIF

      IF (KFLAG == -1) THEN
          WRITE (KW,"(' NDIG must be between 2 and',I10/)") NDIGMX
      ELSE IF (KFLAG == -2) THEN
          WRITE (KW,"(' MBASE must be between 2 and',I10/)") INT(MXBASE)
      ELSE IF (KFLAG == -3) THEN
          WRITE (KW,  &
                 "(' An input argument is not a valid FM number.',"  //  &
                 "'  Its exponent is out of range.'/)"                   &
                )
          WRITE (KW,"(' UNKNOWN has been returned.'/)")
      ELSE IF (KFLAG == -4 .OR. KFLAG == -7) THEN
          WRITE (KW,"(' Invalid input argument for this routine.'/)")
          WRITE (KW,"(' UNKNOWN has been returned.'/)")
      ELSE IF (KFLAG == -5) THEN
          WRITE (KW,"(' The result has overflowed.'/)")
      ELSE IF (KFLAG == -6) THEN
          WRITE (KW,"(' The result has underflowed.'/)")
      ELSE IF (KFLAG == -8 .AND. NAME == 'FMOUT ') THEN
          WRITE (KW,  &
                 "(' The result array is not big enough to hold the',"    //  &
                 "' output character string'/' in the current format.'/"  //  &
                 "' The result ''***...***'' has been returned.'/)"           &
                )
      ELSE IF (KFLAG == -8 .AND. NAME == 'FMREAD') THEN
          WRITE (KW,  &
                 "(' The CMBUFF array is not big enough to hold the',"  //  &
                 "' input character string'/"                           //  &
                 "' UNKNOWN has been returned.'/)"                          &
                )
      ELSE IF (KFLAG == -9) THEN
          WRITE (KW,  &
                 "(' Precision could not be raised enough to'"  //  &
                 ",' provide all requested guard digits.'/)"        &
                )
          WRITE (KW,  &
                 "(I23,' digits were requested (NDIG).'/"            //  &
                 "' Maximum number of digits currently available',"  //  &
                 "' (NDG2MX) is',I7,'.'/)"                               &
                ) NDIG,NDG2MX
          WRITE (KW,"(' UNKNOWN has been returned.'/)")
      ELSE IF (KFLAG == -10) THEN
          IF (NAMEST(NCS) == 'FMM2SP') THEN
              WRITE (KW,  &
                     "(' An FM number was too small in magnitude to ',"  //  &
                     "'convert to single precision.'/)"                      &
                    )
          ELSE
              WRITE (KW,  &
                     "(' An FM number was too small in magnitude to ',"  //  &
                     "'convert to double precision.'/)"                      &
                    )
          ENDIF
          WRITE (KW,"(' Zero has been returned.'/)")
      ENDIF

      NCALL = NCS
      IF (KWARN >= 2) THEN
          STOP
      ENDIF
      RETURN
      END SUBROUTINE FMWARN

      SUBROUTINE FMWRIT(KWRITE,MA)

!  Write MA on unit KWRITE.  Multi-line numbers will have '&' as the
!  last nonblank character on all but the last line.  These numbers can
!  then be read easily using FMREAD.

      USE FMVALS
      IMPLICIT NONE

      INTEGER KWRITE
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      INTEGER J,JF1SAV,JF2SAV,K,KSAVE,L,LAST,LB,ND,NDSAVE,NEXP

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMWRIT'
      NDSAVE = NDIG
      NDIG = MIN(NDG2MX,MAX(NDIG+NGRD52,2))

      CALL FMEQ2(MA,M01,NDSAVE,NDIG)
      KSAVE = KFLAG
      ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
      IF (ND < 2) ND = 2
      NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
      LB = MIN(ND+NEXP,LMBUFF)

      JF1SAV = JFORM1
      JF2SAV = JFORM2
      JFORM1 = 1
      JFORM2 = ND + 6

      CALL FMOUT(M01,CMBUFF,LB)

      KFLAG = KSAVE
      NDIG = NDSAVE
      JFORM1 = JF1SAV
      JFORM2 = JF2SAV
      LAST = LB + 1
      DO J = 1, LB
         IF (CMBUFF(LAST-J) /= ' ' .OR. J == LB) THEN
             L = LAST - J
             IF (MOD(L,73) /= 0) THEN
                 WRITE (KWRITE,"(4X,73A1,' &')") (CMBUFF(K),K=1,L)
             ELSE
                 IF (L > 73) WRITE (KWRITE,"(4X,73A1,' &')")  &
                                    (CMBUFF(K),K=1,L-73)
                 WRITE (KWRITE,"(4X,73A1)") (CMBUFF(K),K=L-72,L)
             ENDIF
             NCALL = NCALL - 1
             RETURN
         ENDIF
      ENDDO
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMWRIT

!  Here are the routines that work with packed FM numbers.  All names
!  are the same as unpacked versions with 'FM' replaced by 'FP'.

!  To convert a program using the FM package from unpacked calls to
!  packed calls make these changes to the program:
!  '(-1:LUNPCK)' to '(-1:LPACK)' in dimensions.
!  'CALL FM' to 'CALL FP'
!  'FMCOMP' to 'FPCOMP'.

!  This packed format is not available when using the FM, IM, or ZM
!  derived types.


      SUBROUTINE FPABS(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMABS(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPABS

      SUBROUTINE FPACOS(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMACOS(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPACOS

      SUBROUTINE FPADD(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMADD(MPA,MPB,MPC)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPADD

      SUBROUTINE FPADD_R1(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMADD(MPA,MPB,MPC)
      CALL FMPACK(MPC,MA)
      RETURN
      END SUBROUTINE FPADD_R1

      SUBROUTINE FPADD_R2(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMADD(MPA,MPB,MPC)
      CALL FMPACK(MPC,MB)
      RETURN
      END SUBROUTINE FPADD_R2

      SUBROUTINE FPADDI(MA,L)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      INTEGER L
      CALL FMUNPK(MA,MPA)
      CALL FMADDI(MPA,L)
      CALL FMPACK(MPA,MA)
      RETURN
      END SUBROUTINE FPADDI

      SUBROUTINE FPASIN(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMASIN(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPASIN

      SUBROUTINE FPATAN(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMATAN(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPATAN

      SUBROUTINE FPATN2(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMATN2(MPA,MPB,MPC)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPATN2

      SUBROUTINE FPBIG(MA)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMBIG(MPA)
      CALL FMPACK(MPA,MA)
      RETURN
      END SUBROUTINE FPBIG

      SUBROUTINE FPCHSH(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMCHSH(MPA,MPB,MPC)
      CALL FMPACK(MPB,MB)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPCHSH

      FUNCTION FPCOMP(MA,LREL,MB)
      USE FMVALS
      IMPLICIT NONE
      LOGICAL FPCOMP,FMCOMP
      CHARACTER(*) :: LREL
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      FPCOMP = FMCOMP(MPA,LREL,MPB)
      RETURN
      END FUNCTION FPCOMP

      SUBROUTINE FPCOS(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMCOS(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPCOS

      SUBROUTINE FPCOSH(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMCOSH(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPCOSH

      SUBROUTINE FPCSSN(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMCSSN(MPA,MPB,MPC)
      CALL FMPACK(MPB,MB)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPCSSN

      SUBROUTINE FPDIG(NSTACK,KST)
      USE FMVALS
      IMPLICIT NONE
      INTEGER NSTACK(19),KST
      CALL FMDIG(NSTACK,KST)
      RETURN
      END SUBROUTINE FPDIG

      SUBROUTINE FPDIM(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMDIM(MPA,MPB,MPC)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPDIM

      SUBROUTINE FPDIV(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMDIV(MPA,MPB,MPC)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPDIV

      SUBROUTINE FPDIV_R1(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMDIV(MPA,MPB,MPC)
      CALL FMPACK(MPC,MA)
      RETURN
      END SUBROUTINE FPDIV_R1

      SUBROUTINE FPDIV_R2(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMDIV(MPA,MPB,MPC)
      CALL FMPACK(MPC,MB)
      RETURN
      END SUBROUTINE FPDIV_R2

      SUBROUTINE FPDIVI(MA,IVAL,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      INTEGER IVAL
      CALL FMUNPK(MA,MPA)
      CALL FMDIVI(MPA,IVAL,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPDIVI

      SUBROUTINE FPDIVI_R1(MA,IVAL)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      INTEGER IVAL
      CALL FMUNPK(MA,MPA)
      CALL FMDIVI(MPA,IVAL,MPB)
      CALL FMPACK(MPB,MA)
      RETURN
      END SUBROUTINE FPDIVI_R1

      SUBROUTINE FPDP2M(X,MA)
      USE FMVALS
      IMPLICIT NONE
      DOUBLE PRECISION X
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMDP2M(X,MPA)
      CALL FMPACK(MPA,MA)
      RETURN
      END SUBROUTINE FPDP2M

      SUBROUTINE FPDPM(X,MA)
      USE FMVALS
      IMPLICIT NONE
      DOUBLE PRECISION X
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMDPM(X,MPA)
      CALL FMPACK(MPA,MA)
      RETURN
      END SUBROUTINE FPDPM

      SUBROUTINE FPEQ(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMEQ(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPEQ

      SUBROUTINE FPEQ2_R1(MA,NDA,NDB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      INTEGER NDA,NDB
      INTEGER NDASAV,NDBSAV,NDGSAV
      NDASAV = NDA
      NDBSAV = NDB
      NDGSAV = NDIG
      NDIG = NDASAV
      CALL FMUNPK(MA,MPA)
      CALL FMEQ2_R1(MPA,NDASAV,NDBSAV)
      NDIG = NDBSAV
      CALL FMPACK(MPA,MA)
      NDA = NDASAV
      NDB = NDBSAV
      NDIG = NDGSAV
      RETURN
      END SUBROUTINE FPEQ2_R1

      SUBROUTINE FPEQU(MA,MB,NDA,NDB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      INTEGER NDA,NDB
      INTEGER NDASAV,NDBSAV,NDGSAV
      NDASAV = NDA
      NDBSAV = NDB
      NDGSAV = NDIG
      NDIG = NDASAV
      CALL FMUNPK(MA,MPA)
      CALL FMEQ2_R1(MPA,NDASAV,NDBSAV)
      NDIG = NDBSAV
      CALL FMPACK(MPA,MB)
      NDA = NDASAV
      NDB = NDBSAV
      NDIG = NDGSAV
      RETURN
      END SUBROUTINE FPEQU

      SUBROUTINE FPEXP(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMEXP(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPEXP

      SUBROUTINE FPFLAG(K)
      USE FMVALS
      IMPLICIT NONE
      INTEGER K
      K = KFLAG
      RETURN
      END SUBROUTINE FPFLAG

      SUBROUTINE FPFORM(FORM,MA,STRING)
      USE FMVALS
      IMPLICIT NONE
      CHARACTER(*) :: FORM,STRING
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMFORM(FORM,MPA,STRING)
      RETURN
      END SUBROUTINE FPFORM

      SUBROUTINE FPFPRT(FORM,MA)
      USE FMVALS
      IMPLICIT NONE
      CHARACTER(*) :: FORM
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMFPRT(FORM,MPA)
      RETURN
      END SUBROUTINE FPFPRT

      SUBROUTINE FPI2M(IVAL,MA)
      USE FMVALS
      IMPLICIT NONE
      INTEGER IVAL
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMI2M(IVAL,MPA)
      CALL FMPACK(MPA,MA)
      RETURN
      END SUBROUTINE FPI2M

      SUBROUTINE FPINP(LINE,MA,LA,LB)
      USE FMVALS
      IMPLICIT NONE
      INTEGER LA,LB
      CHARACTER LINE(LB)
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMINP(LINE,MPA,LA,LB)
      CALL FMPACK(MPA,MA)
      RETURN
      END SUBROUTINE FPINP

      SUBROUTINE FPINT(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMINT(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPINT

      SUBROUTINE FPIPWR(MA,IVAL,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      INTEGER IVAL
      CALL FMUNPK(MA,MPA)
      CALL FMIPWR(MPA,IVAL,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPIPWR

      SUBROUTINE FPLG10(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMLG10(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPLG10

      SUBROUTINE FPLN(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMLN(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPLN

      SUBROUTINE FPLNI(IVAL,MA)
      USE FMVALS
      IMPLICIT NONE
      INTEGER IVAL
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMLNI(IVAL,MPA)
      CALL FMPACK(MPA,MA)
      RETURN
      END SUBROUTINE FPLNI

      SUBROUTINE FPM2DP(MA,X)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      DOUBLE PRECISION X
      CALL FMUNPK(MA,MPA)
      CALL FMM2DP(MPA,X)
      RETURN
      END SUBROUTINE FPM2DP

      SUBROUTINE FPM2I(MA,IVAL)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      INTEGER IVAL
      CALL FMUNPK(MA,MPA)
      CALL FMM2I(MPA,IVAL)
      RETURN
      END SUBROUTINE FPM2I

      SUBROUTINE FPM2SP(MA,X)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      REAL X
      CALL FMUNPK(MA,MPA)
      CALL FMM2SP(MPA,X)
      RETURN
      END SUBROUTINE FPM2SP

      SUBROUTINE FPMAX(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMMAX(MPA,MPB,MPC)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPMAX

      SUBROUTINE FPMIN(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMMIN(MPA,MPB,MPC)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPMIN

      SUBROUTINE FPMOD(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMMOD(MPA,MPB,MPC)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPMOD

      SUBROUTINE FPMPY(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMMPY(MPA,MPB,MPC)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPMPY

      SUBROUTINE FPMPY_R1(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMMPY(MPA,MPB,MPC)
      CALL FMPACK(MPC,MA)
      RETURN
      END SUBROUTINE FPMPY_R1

      SUBROUTINE FPMPY_R2(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMMPY(MPA,MPB,MPC)
      CALL FMPACK(MPC,MB)
      RETURN
      END SUBROUTINE FPMPY_R2

      SUBROUTINE FPMPYI(MA,IVAL,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      INTEGER IVAL
      CALL FMUNPK(MA,MPA)
      CALL FMMPYI(MPA,IVAL,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPMPYI

      SUBROUTINE FPMPYI_R1(MA,IVAL)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      INTEGER IVAL
      CALL FMUNPK(MA,MPA)
      CALL FMMPYI(MPA,IVAL,MPB)
      CALL FMPACK(MPB,MA)
      RETURN
      END SUBROUTINE FPMPYI_R1

      SUBROUTINE FPNINT(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMNINT(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPNINT

      SUBROUTINE FPOUT(MA,LINE,LB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      INTEGER LB
      CHARACTER LINE(LB)
      CALL FMUNPK(MA,MPA)
      CALL FMOUT(MPA,LINE,LB)
      RETURN
      END SUBROUTINE FPOUT

      SUBROUTINE FPPI(MA)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMPI(MPA)
      CALL FMPACK(MPA,MA)
      RETURN
      END SUBROUTINE FPPI

      SUBROUTINE FPPRNT(MA)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMPRNT(MPA)
      RETURN
      END SUBROUTINE FPPRNT

      SUBROUTINE FPPWR(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMPWR(MPA,MPB,MPC)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPPWR

      SUBROUTINE FPREAD(KREAD,MA)
      USE FMVALS
      IMPLICIT NONE
      INTEGER KREAD
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMREAD(KREAD,MPA)
      CALL FMPACK(MPA,MA)
      RETURN
      END SUBROUTINE FPREAD

      SUBROUTINE FPRPWR(MA,KVAL,JVAL,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      INTEGER KVAL,JVAL
      CALL FMUNPK(MA,MPA)
      CALL FMRPWR(MPA,KVAL,JVAL,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPRPWR

      SUBROUTINE FPSET(NPREC)
      USE FMVALS
      IMPLICIT NONE
      INTEGER NPREC
      CALL FMSET(NPREC)
      RETURN
      END SUBROUTINE FPSET

      SUBROUTINE FPSETVAR(STRING)
      USE FMVALS
      IMPLICIT NONE
      CHARACTER(*) :: STRING
      CALL FMSETVAR(STRING)
      RETURN
      END SUBROUTINE FPSETVAR

      SUBROUTINE FPSIGN(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMSIGN(MPA,MPB,MPC)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPSIGN

      SUBROUTINE FPSIN(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMSIN(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPSIN

      SUBROUTINE FPSINH(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMSINH(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPSINH

      SUBROUTINE FPSP2M(X,MA)
      USE FMVALS
      IMPLICIT NONE
      REAL X
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMSP2M(X,MPA)
      CALL FMPACK(MPA,MA)
      RETURN
      END SUBROUTINE FPSP2M

      SUBROUTINE FPSQR(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMSQR(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPSQR

      SUBROUTINE FPSQR_R1(MA)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMSQR(MPA,MPB)
      CALL FMPACK(MPB,MA)
      RETURN
      END SUBROUTINE FPSQR_R1

      SUBROUTINE FPSQRT(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMSQRT(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPSQRT

      SUBROUTINE FPSQRT_R1(MA)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMSQRT(MPA,MPB)
      CALL FMPACK(MPB,MA)
      RETURN
      END SUBROUTINE FPSQRT_R1

      SUBROUTINE FPST2M(STRING,MA)
      USE FMVALS
      IMPLICIT NONE
      CHARACTER(*) :: STRING
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMST2M(STRING,MPA)
      CALL FMPACK(MPA,MA)
      RETURN
      END SUBROUTINE FPST2M

      SUBROUTINE FPSUB(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMSUB(MPA,MPB,MPC)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPSUB

      SUBROUTINE FPSUB_R1(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMSUB(MPA,MPB,MPC)
      CALL FMPACK(MPC,MA)
      RETURN
      END SUBROUTINE FPSUB_R1

      SUBROUTINE FPSUB_R2(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMSUB(MPA,MPB,MPC)
      CALL FMPACK(MPC,MB)
      RETURN
      END SUBROUTINE FPSUB_R2

      SUBROUTINE FPTAN(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMTAN(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPTAN

      SUBROUTINE FPTANH(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMTANH(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPTANH

      SUBROUTINE FPULP(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMULP(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPULP

      SUBROUTINE FPVARS
      CALL FMVARS
      RETURN
      END SUBROUTINE FPVARS

      SUBROUTINE FPWRIT(KWRITE,MA)
      USE FMVALS
      IMPLICIT NONE
      INTEGER KWRITE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMWRIT(KWRITE,MPA)
      RETURN
      END SUBROUTINE FPWRIT

!  The IM routines perform integer multiple-precision arithmetic.


      SUBROUTINE IMABS(MA,MB)

!  MB = ABS(MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      INTEGER KWRNSV,NDSAVE

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMABS ',1,MA,MA)
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMABS '
          CALL IMNTR(2,MA,MA,1)
      ENDIF

      KFLAG = 0
      KWRNSV = KWARN
      KWARN = 0
      CALL IMEQ(MA,MB)
      MB(-1) = 1
      KWARN = KWRNSV

      IF (NTRACE /= 0) CALL IMNTR(1,MB,MB,1)
      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMABS

      SUBROUTINE IMADD(MA,MB,MC)

!  MC = MA + MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MDA,MDAB,MDB
      INTEGER NDSAVE

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMADD ',2,MA,MB)
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMADD '
          CALL IMNTR(2,MA,MB,2)
      ENDIF
      KFLAG = 0

      IF (MA(1) <= 2) THEN
          IF (MB(1) > 2 .OR. MA(1) < 0 .OR. MB(1) < 0) GO TO 110
          IF (MA(1) <= 1) THEN
              MDA = MA(-1) * MA(2)
          ELSE
              MDA = MA(-1) * (MA(2)*MBASE + MA(3))
          ENDIF
          IF (MB(1) <= 1) THEN
              MDB = MB(-1) * MB(2)
          ELSE
              MDB = MB(-1) * (MB(2)*MBASE + MB(3))
          ENDIF
          MDAB = MDA + MDB
          IF (ABS(MDAB) < MBASE) THEN
              MC(0) = MIN(MA(0),MB(0))
              MC(1) = 1
              IF (MDAB == 0) MC(1) = 0
              IF (MDAB < 0) THEN
                  MC(2) = -MDAB
                  MC(-1) = -1
              ELSE
                  MC(2) = MDAB
                  MC(-1) = 1
              ENDIF
              MC(3) = 0
              IF (MDA == 0 .OR. MDB == 0) KFLAG = 1
              GO TO 120
          ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
              MC(0) = MIN(MA(0),MB(0))
              MC(1) = 2
              IF (MDAB < 0) THEN
                  MC(2) = AINT (-MDAB/MBASE)
                  MC(3) = ABS(-MDAB - MBASE*MC(2))
                  MC(-1) = -1
              ELSE
                  MC(2) = AINT (MDAB/MBASE)
                  MC(3) = ABS(MDAB - MBASE*MC(2))
                  MC(-1) = 1
              ENDIF
              IF (MDA == 0 .OR. MDB == 0) KFLAG = 1
              GO TO 120
          ENDIF
      ENDIF

!             Check for special cases.

  110 IF (MA(1) > NDG2MX .OR. MB(1) > NDG2MX .OR.  &
          MA(1) < 0 .OR. MB(1) < 0) THEN
          IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
              CALL IMST2M('UNKNOWN',MC)
              KFLAG = -4
              GO TO 130
          ENDIF
          IF (MA(1) == MEXPOV) THEN
              IF (MA(-1) == MB(-1) .OR. MB(2) == 0) THEN
                  MC(-1) = MA(-1)
                  MC(0) = MA(0)
                  MC(1) = MA(1)
                  MC(2) = MA(2)
                  MC(3) = MA(3)
                  KFLAG = -5
                  GO TO 130
              ELSE
                  KFLAG = -4
                  NAMEST(NCALL) = 'IMADD '
                  CALL FMWARN
                  CALL IMST2M('UNKNOWN',MC)
                  GO TO 130
              ENDIF
          ENDIF
          IF (MB(1) == MEXPOV) THEN
              IF (MB(-1) == MA(-1) .OR. MA(2) == 0) THEN
                  MC(-1) = MB(-1)
                  MC(0) = MB(0)
                  MC(1) = MB(1)
                  MC(2) = MB(2)
                  MC(3) = MB(3)
                  KFLAG = -5
                  GO TO 130
              ELSE
                  KFLAG = -4
                  NAMEST(NCALL) = 'IMADD '
                  CALL FMWARN
                  CALL IMST2M('UNKNOWN',MC)
                  GO TO 130
              ENDIF
          ENDIF
          KFLAG = -4
          NAMEST(NCALL) = 'IMADD '
          CALL FMWARN
          CALL IMST2M('UNKNOWN',MC)
          GO TO 130
      ENDIF

      CALL IMADD2(MA,MB,MC)

  120 IF (MC(1) > NDIGMX) THEN
          IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN
              IF (MC(-1) > 0) THEN
                  CALL IMST2M('OVERFLOW',MC)
              ELSE
                  CALL IMST2M('-OVERFLOW',MC)
              ENDIF
              KFLAG = -5
              NAMEST(NCALL) = 'IMADD '
              CALL FMWARN
          ENDIF
      ENDIF

  130 IF (MC(1) <= 1) MC(3) = 0
      IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMADD

      SUBROUTINE IMADD2(MA,MB,MC)

!  Internal addition routine.  MC = MA + MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MAS,MBS
      INTEGER J,JCOMP,JSIGN,N1
      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (MA(2) == 0) THEN
          CALL IMEQ(MB,MC)
          KFLAG = 1
          IF (KSUB == 1) THEN
              IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
              KFLAG = 0
          ENDIF
          RETURN
      ENDIF
      IF (MB(2) == 0) THEN
          CALL IMEQ(MA,MC)
          KFLAG = 1
          RETURN
      ENDIF

      KFLAG = 0
      N1 = MAX(MA(1),MB(1)) + 1

!             JSIGN is the sign of the result of MA + MB.

      JSIGN = 1
      MAS = MA(-1)
      MBS = MB(-1)
      IF (KSUB == 1) MBS = -MBS

!             See which one is larger in absolute value.

      JCOMP = 2
      IF (MA(1) > MB(1)) THEN
          JCOMP = 1
      ELSE IF (MB(1) > MA(1)) THEN
          JCOMP = 3
      ELSE
          DO J = 2, N1
             IF (MA(J) > MB(J)) THEN
                 JCOMP = 1
                 EXIT
             ENDIF
             IF (MB(J) > MA(J)) THEN
                 JCOMP = 3
                 EXIT
             ENDIF
          ENDDO
      ENDIF

      IF (JCOMP < 3) THEN
          IF (MAS < 0) JSIGN = -1
          IF (MAS*MBS > 0) THEN
              CALL IMADDP(MA,MB)
          ELSE
              CALL IMADDN(MA,MB)
          ENDIF
      ELSE
          IF (MBS < 0) JSIGN = -1
          IF (MAS*MBS > 0) THEN
              CALL IMADDP(MB,MA)
          ELSE
              CALL IMADDN(MB,MA)
          ENDIF
      ENDIF

!             Transfer to MC and fix the sign of the result.

      NDIG = MWA(1)
      IF (NDIG < 2) NDIG = 2
      IF (NDIG > NDG2MX) NDIG = NDG2MX
      CALL FMMOVE(MWA,MC)
      MC(0) = NINT(NDIGMX*ALOGM2)
      MC(-1) = 1
      IF (JSIGN < 0 .AND. MC(2) /= 0) MC(-1) = -1

      IF (KFLAG < 0) THEN
          IF (KSUB == 1) THEN
              NAMEST(NCALL) = 'IMSUB '
          ELSE
              NAMEST(NCALL) = 'IMADD '
          ENDIF
          CALL FMWARN
      ENDIF

      RETURN
      END SUBROUTINE IMADD2

      SUBROUTINE IMADDN(MA,MB)

!  Internal addition routine.  MWA = MA - MB
!  The arguments are such that MA >= MB >= 0.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MK
      INTEGER J,K,KL,KP1,KP2,KPT,KSH,N1

      IF (MA(1) == MEXPOV .OR. MB(1) == MEXPOV) THEN
          KFLAG = -4
          MWA(1) = MUNKNO
          MWA(2) = 1
          MWA(3) = 0
          RETURN
      ENDIF

      N1 = MA(1) + 1
      MK = MA(1) - MB(1)
      K = INT(MK)

!             Subtract MB from MA.

      KP1 = MIN(N1,K+1)
      DO J = 1, KP1
         MWA(J) = MA(J)
      ENDDO
      KP2 = K + 2

!             (Inner Loop)

      DO J = KP2, N1
         MWA(J) = MA(J) - MB(J-K)
      ENDDO

!             Normalize.  Fix the sign of any negative digit.

      IF (K > 0) THEN
          DO J = N1, KP2, -1
             IF (MWA(J) < 0) THEN
                 MWA(J) = MWA(J) + MBASE
                 MWA(J-1) = MWA(J-1) - 1
             ENDIF
          ENDDO
          KPT = KP2 - 1
  110     IF (MWA(KPT) < 0 .AND. KPT >= 3) THEN
              MWA(KPT) = MWA(KPT) + MBASE
              MWA(KPT-1) = MWA(KPT-1) - 1
              KPT = KPT - 1
              GO TO 110
          ENDIF
      ELSE
          DO J = N1, 3, -1
             IF (MWA(J) < 0) THEN
                 MWA(J) = MWA(J) + MBASE
                 MWA(J-1) = MWA(J-1) - 1
             ENDIF
          ENDDO
      ENDIF

!             Shift left if there are any leading zeros in the mantissa.

      DO J = 2, N1
         IF (MWA(J) > 0) THEN
             KSH = J - 2
             GO TO 120
         ENDIF
      ENDDO
      MWA(1) = 0
      MWA(3) = 0
      RETURN

  120 IF (KSH > 0) THEN
          KL = N1 - KSH
          DO J = 2, KL
             MWA(J) = MWA(J+KSH)
          ENDDO
          DO J = KL+1, N1
             MWA(J) = 0
          ENDDO
          MWA(1) = MWA(1) - KSH
      ENDIF

      RETURN
      END SUBROUTINE IMADDN

      SUBROUTINE IMADDP(MA,MB)

!  Internal addition routine.  MWA = MA + MB
!  The arguments are such that MA >= MB >= 0.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MK
      INTEGER J,K,KP2,KPT,N1

      N1 = MA(1) + 1
      MK = MA(1) - MB(1)
      K = INT(MK)

!             Add MA and MB.

      MWA(1) = MA(1) + 1
      MWA(2) = 0
      DO J = 2, K+1
         MWA(J+1) = MA(J)
      ENDDO
      KP2 = K + 2

!             (Inner Loop)

      DO J = KP2, N1
         MWA(J+1) = MA(J) + MB(J-K)
      ENDDO

!             Normalize.  Fix any digit not less than MBASE.

      IF (K > 0) THEN
          DO J = N1+1, KP2, -1
             IF (MWA(J) >= MBASE) THEN
                 MWA(J) = MWA(J) - MBASE
                 MWA(J-1) = MWA(J-1) + 1
             ENDIF
          ENDDO
          KPT = KP2 - 1
  110     IF (MWA(KPT) >= MBASE .AND. KPT >= 3) THEN
              MWA(KPT) = MWA(KPT) - MBASE
              MWA(KPT-1) = MWA(KPT-1) + 1
              KPT = KPT - 1
              GO TO 110
          ENDIF
      ELSE
          DO J = N1+1, 3, -1
             IF (MWA(J) >= MBASE) THEN
                 MWA(J) = MWA(J) - MBASE
                 MWA(J-1) = MWA(J-1) + 1
             ENDIF
          ENDDO
      ENDIF

      RETURN
      END SUBROUTINE IMADDP

      SUBROUTINE IMARGS(KROUTN,NARGS,MA,MB)

!  Check the input arguments to a routine for special cases.

!  KROUTN - Name of the subroutine that was called
!  NARGS  - The number of input arguments (1 or 2)
!  MA     - First input argument
!  MB     - Second input argument (if NARGS is 2)

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(6) :: KROUTN
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER NARGS

      REAL (KIND(1.0D0)) :: MBS
      INTEGER J,KWRNSV,LAST

      KFLAG = -4
      IF (MA(1) == MUNKNO) RETURN
      IF (NARGS == 2) THEN
          IF (MB(1) == MUNKNO) RETURN
      ENDIF
      IF (MBLOGS /= MBASE) CALL FMCONS
      KFLAG = 0

!             Check the validity of parameters.

      IF (NCALL > 1 .AND. KDEBUG == 0) RETURN
      NAMEST(NCALL) = KROUTN

!             Check MBASE.

      IF (MBASE < 2 .OR. MBASE > MXBASE) THEN
          KFLAG = -2
          CALL FMWARN
          MBS = MBASE
          IF (MBASE < 2) MBASE = 2
          IF (MBASE > MXBASE) MBASE = MXBASE
          WRITE (KW,  &
                 "(' MBASE was',I10,'.  It has been changed to',I10,'.')"  &
                ) INT(MBS),INT(MBASE)
          CALL FMCONS
          RETURN
      ENDIF

!             Check exponent range.

      IF (MA(1) > LUNPCK .OR. MA(1) < 0) THEN
          IF (ABS(MA(1)) /= MEXPOV .OR. ABS(MA(2)) /= 1) THEN
              KFLAG = -3
              CALL FMWARN
              CALL IMST2M('UNKNOWN',MA)
              RETURN
          ENDIF
      ENDIF
      IF (NARGS == 2) THEN
          IF (MB(1) > LUNPCK .OR. MB(1) < 0) THEN
              IF (ABS(MB(1)) /= MEXPOV .OR. ABS(MB(2)) /= 1) THEN
                  KFLAG = -3
                  CALL FMWARN
                  CALL IMST2M('UNKNOWN',MB)
                  RETURN
              ENDIF
          ENDIF
      ENDIF

!             Check for properly normalized digits in the
!             input arguments.

      IF (ABS(MA(1)-INT(MA(1))) /= 0) KFLAG = 1
      IF (MA(2) <= (-1) .OR. MA(2) >= MBASE .OR.  &
          ABS(MA(2)-INT(MA(2))) /= 0) KFLAG = 2
      IF (KDEBUG == 0) GO TO 110
      LAST = INT(MA(1)) + 1
      IF (MA(1) > LUNPCK) LAST = 3
      DO J = 3, LAST
         IF (MA(J) < 0 .OR. MA(J) >= MBASE .OR.  &
             ABS(MA(J)-INT(MA(J))) /= 0) THEN
             KFLAG = J
             GO TO 110
         ENDIF
      ENDDO
  110 IF (KFLAG /= 0) THEN
          J = KFLAG
          KFLAG = -4
          KWRNSV = KWARN
          IF (KWARN >= 2) KWARN = 1
          CALL FMWARN
          KWARN = KWRNSV
          IF (KWARN >= 1) THEN
              WRITE (KW,*) ' First invalid array element:  MA(',  &
                           J,') = ',MA(J)
          ENDIF
          CALL IMST2M('UNKNOWN',MA)
          IF (KWARN >= 2) THEN
              STOP
          ENDIF
          RETURN
      ENDIF
      IF (NARGS == 2) THEN
          IF (ABS(MB(1)-INT(MB(1))) /= 0) KFLAG = 1
          IF (MB(2) <= (-1) .OR. MB(2) >= MBASE .OR.  &
              ABS(MB(2)-INT(MB(2))) /= 0) KFLAG = 2
          IF (KDEBUG == 0) GO TO 120
          LAST = INT(MB(1)) + 1
          IF (MB(1) > LUNPCK) LAST = 3
          DO J = 3, LAST
             IF (MB(J) < 0 .OR. MB(J) >= MBASE .OR.  &
                 ABS(MB(J)-INT(MB(J))) /= 0) THEN
                 KFLAG = J
                 GO TO 120
             ENDIF
          ENDDO
  120     IF (KFLAG /= 0) THEN
              J = KFLAG
              KFLAG = -4
              KWRNSV = KWARN
              IF (KWARN >= 2) KWARN = 1
              CALL FMWARN
              KWARN = KWRNSV
              IF (KWARN >= 1) THEN
                  WRITE (KW,*) ' First invalid array element:  MB(',  &
                               J,') = ',MB(J)
              ENDIF
              CALL IMST2M('UNKNOWN',MB)
              IF (KWARN >= 2) THEN
                  STOP
              ENDIF
              RETURN
          ENDIF
      ENDIF
      RETURN
      END SUBROUTINE IMARGS

      SUBROUTINE IMBIG(MA)

!     MA = The biggest representable IM integer.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      INTEGER J

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'IMBIG '

      IF (MBLOGS /= MBASE) CALL FMCONS
      KFLAG = 0
      DO J = 2, NDIGMX+1
         MA(J) = MBASE - 1
      ENDDO
      MA(1) = NDIGMX
      MA(0) = NINT(NDIGMX*ALOGM2)
      MA(-1) = 1

      IF (NTRACE /= 0) CALL IMNTR(1,MA,MA,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE IMBIG

      FUNCTION IMCOMP(MA,LREL,MB)

!  Logical comparison of FM numbers MA and MB.

!  LREL is a CHARACTER description of the comparison to be done:
!  LREL = 'EQ' returns IMCOMP = .TRUE. if MA == MB
!       = 'NE', 'GE', 'GT', 'LE', 'LT' also work like a logical IF.
!       = '==', '/=', '<', '<=', '>', '>=' may be used.

!  Some compilers object to functions with side effects such as
!  changing KFLAG or other module FMVALS variables.  Blocks of
!  code that modify these variables are identified by:
!      C                                                 DELETE START
!        ...
!      C                                                 DELETE STOP
!  These may be removed or commented out to produce a function without
!  side effects.  This disables trace printing in IMCOMP, and error
!  codes are not returned in KFLAG.

      USE FMVALS
      IMPLICIT NONE

      LOGICAL IMCOMP
      CHARACTER(*) :: LREL
      CHARACTER(2) :: JREL
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      INTEGER J,JCOMP,NDSAVE,NLAST,NTRSAV

!                                                 DELETE START
      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMCOMP',2,MA,MB)
      NAMEST(NCALL) = 'IMCOMP'

      IF (NCALL <= LVLTRC .AND. ABS(NTRACE) >= 2) THEN
          WRITE (KW,"(' Input to IMCOMP')")
          NDSAVE = NDIG
          IF (NTRACE > 0) THEN
              CALL IMPRNT(MA)
              IF (INDEX('=/<>',LREL(1:1)) > 0) THEN
                  WRITE (KW,"(8X,A)") LREL
              ELSE
                  WRITE (KW,"(7X,'.',A,'.')") LREL
              ENDIF
              CALL IMPRNT(MB)
          ELSE
              NDIG = MAX(2,INT(MA(1)))
              IF (NDIG > NDG2MX) NDIG = 2
              NTRSAV = NTRACE
              IF (NTRACE < -2) NTRACE = -2
              CALL IMNTRJ(MA,NDIG)
              IF (INDEX('=/<>',LREL(1:1)) > 0) THEN
                  WRITE (KW,"(8X,A)") LREL
              ELSE
                  WRITE (KW,"(7X,'.',A,'.')") LREL
              ENDIF
              NDIG = MAX(2,INT(MB(1)))
              IF (NDIG > NDG2MX) NDIG = 2
              CALL IMNTRJ(MB,NDIG)
              NTRACE = NTRSAV
          ENDIF
          NDIG = NDSAVE
      ENDIF
!                                                 DELETE STOP

!             JCOMP will be 1 if MA > MB
!                           2 if MA == MB
!                           3 if MA < MB

!             Check for special cases.

      JREL = LREL
      IF (LREL /= 'EQ' .AND. LREL /= 'NE' .AND. LREL /= 'LT' .AND.  &
          LREL /= 'GT' .AND. LREL /= 'LE' .AND. LREL /= 'GE') THEN
          IF (LREL == 'eq' .OR. LREL == '==') THEN
              JREL = 'EQ'
          ELSE IF (LREL == 'ne' .OR. LREL == '/=') THEN
              JREL = 'NE'
          ELSE IF (LREL == 'lt' .OR. LREL == '<') THEN
              JREL = 'LT'
          ELSE IF (LREL == 'gt' .OR. LREL == '>') THEN
              JREL = 'GT'
          ELSE IF (LREL == 'le' .OR. LREL == '<=') THEN
              JREL = 'LE'
          ELSE IF (LREL == 'ge' .OR. LREL == '>=') THEN
              JREL = 'GE'
          ELSE
              IMCOMP = .FALSE.
!                                                 DELETE START
              KFLAG = -4
              IF (NCALL /= 1 .OR. KWARN <= 0) GO TO 120
!                                                 DELETE STOP
              IF (KWARN <= 0) GO TO 120
              WRITE (KW,  &
                     "(/' Error of type KFLAG = -4 in FM package in',"   //  &
                     "' routine IMCOMP'//1X,A,' is not one of the six'," //  &
                     "' recognized comparisons.'//' .FALSE. has been',"  //  &
                     "' returned.'/)"                                        &
                    ) LREL
              IF (KWARN >= 2) THEN
                  STOP
              ENDIF
              GO TO 120
          ENDIF
      ENDIF

      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
          IMCOMP = .FALSE.
!                                                 DELETE START
          KFLAG = -4
!                                                 DELETE STOP
          GO TO 120
      ENDIF

      IF (ABS(MA(1)) == MEXPOV .AND. MA(1) == MB(1) .AND.  &
          MA(2) == MB(2) .AND. MA(-1) == MB(-1)) THEN
          IMCOMP = .FALSE.
!                                                 DELETE START
          KFLAG = -4
          IF (NCALL /= 1 .OR. KWARN <= 0) GO TO 120
!                                                 DELETE STOP
          IF (KWARN <= 0) GO TO 120
          WRITE (KW,  &
                 "(/' Error of type KFLAG = -4 in FM package in ',"  //  &
                 "'routine IMCOMP'//' Two numbers in the same ',"    //  &
                 "'overflow category cannot be compared.'//"         //  &
                 "' .FALSE. has been returned.'/)"                       &
                )
          IF (KWARN >= 2) THEN
              STOP
          ENDIF
          GO TO 120
      ENDIF

!             Check for zero.

!                                                 DELETE START
      KFLAG = 0
!                                                 DELETE STOP
      IF (MA(2) == 0) THEN
          JCOMP = 2
          IF (MB(2) == 0) GO TO 110
          IF (MB(-1) < 0) JCOMP = 1
          IF (MB(-1) > 0) JCOMP = 3
          GO TO 110
      ENDIF
      IF (MB(2) == 0) THEN
          JCOMP = 1
          IF (MA(-1) < 0) JCOMP = 3
          GO TO 110
      ENDIF
!             Check for opposite signs.

      IF (MA(-1) > 0 .AND. MB(-1) < 0) THEN
          JCOMP = 1
          GO TO 110
      ENDIF
      IF (MB(-1) > 0 .AND. MA(-1) < 0) THEN
          JCOMP = 3
          GO TO 110
      ENDIF

!             See which one is larger in absolute value.

      IF (MA(1) > MB(1)) THEN
          JCOMP = 1
          GO TO 110
      ENDIF
      IF (MB(1) > MA(1)) THEN
          JCOMP = 3
          GO TO 110
      ENDIF
      NLAST = INT(MA(1)) + 1
      IF (NLAST > NDG2MX+1) NLAST = 2

      DO J = 2, NLAST
         IF (ABS(MA(J)) > ABS(MB(J))) THEN
             JCOMP = 1
             GO TO 110
         ENDIF
         IF (ABS(MB(J)) > ABS(MA(J))) THEN
             JCOMP = 3
             GO TO 110
         ENDIF
      ENDDO

      JCOMP = 2

!             Now match the JCOMP value to the requested comparison.

  110 IF (JCOMP == 1 .AND. MA(-1) < 0) THEN
          JCOMP = 3
      ELSE IF (JCOMP == 3 .AND. MB(-1) < 0) THEN
          JCOMP = 1
      ENDIF

      IMCOMP = .FALSE.
      IF (JCOMP == 1 .AND. (JREL == 'GT' .OR. JREL == 'GE' .OR.  &
                            JREL == 'NE')) IMCOMP = .TRUE.

      IF (JCOMP == 2 .AND. (JREL == 'EQ' .OR. JREL == 'GE' .OR.  &
                            JREL == 'LE')) IMCOMP = .TRUE.

      IF (JCOMP == 3 .AND. (JREL == 'NE' .OR. JREL == 'LT' .OR.  &
                            JREL == 'LE')) IMCOMP = .TRUE.

  120 CONTINUE
!                                                 DELETE START
      IF (NTRACE /= 0) THEN
          IF (NCALL <= LVLTRC .AND. ABS(NTRACE) >= 1) THEN
              IF (KFLAG == 0) THEN
                  WRITE (KW,  &
                         "(' IMCOMP',15X,'Call level =',I2,5X,"  //  &
                         "'MBASE =',I10)"                            &
                        ) NCALL,INT(MBASE)
              ELSE
                  WRITE (KW,  &
                         "(' IMCOMP',6X,'Call level =',I2,4X,"  //  &
                         "'MBASE =',I10,4X,'KFLAG =',I3)"           &
                        ) NCALL,INT(MBASE),KFLAG
              ENDIF
              IF (IMCOMP) THEN
                  WRITE (KW,"(7X,'.TRUE.')")
              ELSE
                  WRITE (KW,"(7X,'.FALSE.')")
              ENDIF
          ENDIF
      ENDIF
      NCALL = NCALL - 1
!                                                 DELETE STOP
      RETURN
      END FUNCTION IMCOMP

      SUBROUTINE IMDIM(MA,MB,MC)

!  MC = DIM(MA,MB)

!  Positive difference.  MC = MA - MB  if MA >= MB,
!                           = 0        otherwise.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      INTEGER KOVFL
      LOGICAL IMCOMP

      KFLAG = 0
      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMDIM ',2,MA,MB)
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMDIM '
          CALL IMNTR(2,MA,MB,2)
      ENDIF

      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
          CALL IMST2M('UNKNOWN',MC)
          KFLAG = -4
          GO TO 110
      ENDIF
      IF (MA(1) < 0 .OR. MB(1) < 0) THEN
          KFLAG = -4
          NAMEST(NCALL) = 'IMDIM '
          CALL FMWARN
          CALL IMST2M('UNKNOWN',MC)
          GO TO 110
      ENDIF
      KOVFL = 0
      IF (MA(1) == MEXPOV .OR. MB(1) == MEXPOV) THEN
          KOVFL = 1
          IF (MA(1) == MEXPOV .AND. MB(1) == MEXPOV .AND.  &
              MA(2) == MB(2) .AND. MA(-1) == MB(-1)) THEN
              KFLAG = -4
              NAMEST(NCALL) = 'IMDIM '
              CALL FMWARN
              CALL IMST2M('UNKNOWN',MC)
              GO TO 110
          ENDIF
      ENDIF

      IF (IMCOMP(MA,'GE',MB)) THEN
          CALL IMSUB(MA,MB,MC)
          IF (KFLAG == 1) KFLAG = 0
      ELSE
          MC(1) = 0
          MC(2) = 0
          MC(3) = 0
          MC(-1) = 1
          MC(0) = NINT(NDG2MX*ALOGM2)
      ENDIF

      IF (MC(1) > NDIGMX) THEN
          IF (MC(1) == MUNKNO) THEN
              KFLAG = -4
              NAMEST(NCALL) = 'IMDIM '
              CALL FMWARN
          ELSE IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN
              IF (MC(-1) > 0) THEN
                  CALL IMST2M('OVERFLOW',MC)
              ELSE
                  CALL IMST2M('-OVERFLOW',MC)
              ENDIF
              KFLAG = -5
              NAMEST(NCALL) = 'IMDIM '
              IF (KOVFL /= 1) CALL FMWARN
          ENDIF
      ENDIF

  110 IF (MC(1) <= 1) MC(3) = 0
      IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE IMDIM

      SUBROUTINE IMDIV(MA,MB,MC)

!  MC = INT(MA/MB)

!  Use IMDIVR if both INT(MA/MB) and MOD(MA,MB) are needed.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
      INTEGER NDSAVE

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMDIV ',2,MA,MB)
      KFLAG = 0
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMDIV '
          CALL IMNTR(2,MA,MB,2)
      ENDIF

      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
          CALL IMST2M('UNKNOWN',MC)
          KFLAG = -4
          GO TO 110
      ENDIF

      CALL IMDIVR(MA,MB,MC,M03)

      IF (MC(1) == MUNKNO) THEN
          KFLAG = -4
          NAMEST(NCALL) = 'IMDIV '
          CALL FMWARN
      ENDIF

  110 IF (MC(1) <= 1) MC(3) = 0
      IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMDIV

      SUBROUTINE IMDIVI(MA,IDIV,MB)

!  MB = INT(MA/IDIV)

!  Use IMDVIR if both INT(MA/IDIV) and MOD(MA,IDIV) are needed.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER IDIV,IREM,NDSAVE

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMDIVI',1,MA,MA)
      KFLAG = 0
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMDIVI'
          CALL IMNTR(2,MA,MA,1)
          CALL IMNTRI(2,IDIV,0)
      ENDIF

      IF (MA(1) == MUNKNO) THEN
          CALL IMST2M('UNKNOWN',MB)
          KFLAG = -4
          GO TO 110
      ENDIF

      CALL IMDVIR(MA,IDIV,MB,IREM)

      IF (MB(1) == MUNKNO) THEN
          KFLAG = -4
          NAMEST(NCALL) = 'IMDIVI'
          CALL FMWARN
      ENDIF

  110 IF (MB(1) <= 1) MB(3) = 0
      IF (NTRACE /= 0) CALL IMNTR(1,MB,MB,1)
      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMDIVI

      SUBROUTINE IMDIVR(MA,MB,MC,MD)

!  MC = INT(MA / MB),    MD = Remainder from the division.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK),  &
                            MD(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MDA,MDAB,MDB,MDR
      DOUBLE PRECISION XB,XBR,XBASE,XMWA
      REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MAXMWA,MB1,  &
                            MBM1,MBS,MCARRY,MKT,MLMAX,MQD
      INTEGER J,JB,JL,K,KA,KB,KL,KLTFLG,KPTMWA,LCRRCT,NA1,NB1,  &
              NDSAVE,NGUARD,NL,NMBWDS,NTRSAV
      LOGICAL IMCOMP

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMDIVR',2,MA,MB)
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMDIVR'
          CALL IMNTR(2,MA,MB,2)
      ENDIF
      KFLAG = 0
      NTRSAV = NTRACE
      NTRACE = 0
      IF (MBLOGS /= MBASE) CALL FMCONS

!             Check for special cases.

      IF (MB(1) == 1 .AND. MA(1) /= MUNKNO) THEN
          IF (MB(-1)*MB(2) == 1) THEN
              CALL IMEQ(MA,MC)
              MD(1) = 0
              MD(2) = 0
              MD(3) = 0
              MD(-1) = 1
              MD(0) = NINT(NDG2MX*ALOGM2)
              GO TO 170
          ELSE IF (MB(-1)*MB(2) == -1) THEN
              CALL IMEQ(MA,MC)
              IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
              MD(1) = 0
              MD(2) = 0
              MD(3) = 0
              MD(-1) = 1
              MD(0) = NINT(NDG2MX*ALOGM2)
              GO TO 170
          ENDIF
      ENDIF
      IF (MA(1) < MB(1) .AND. MB(1) /= MUNKNO) GO TO 110
      IF (MA(1) > NDG2MX .OR. MB(1) > NDG2MX .OR.  &
          MA(1) < 0 .OR. MB(1) < 0 .OR. MB(2) == 0) THEN
          KFLAG = -4
          IF (MA(1) /= MUNKNO .AND. MB(1) /= MUNKNO) THEN
              NAMEST(NCALL) = 'IMDIVR'
              CALL FMWARN
          ENDIF
          CALL IMST2M('UNKNOWN',MC)
          CALL IMST2M('UNKNOWN',MD)
          GO TO 170
      ENDIF
      IF (MA(1) <= 2) THEN
          IF (MB(1) > 2) GO TO 110
          IF (MB(2) == 0) GO TO 110
          IF (MA(1) <= 1) THEN
              MDA = MA(-1) * MA(2)
          ELSE
              MDA = MA(-1) * (MA(2)*MBASE + MA(3))
          ENDIF
          IF (MB(1) <= 1) THEN
              MDB = MB(-1) * MB(2)
          ELSE
              MDB = MB(-1) * (MB(2)*MBASE + MB(3))
          ENDIF
          MDAB = AINT (MDA / MDB)
          MDR = MDA - MDAB*MDB
          IF (ABS(MDAB) < MBASE) THEN
              MC(0) = NINT(NDG2MX*ALOGM2)
              MC(1) = 1
              IF (MDAB == 0) MC(1) = 0
              IF (MDAB >= 0) THEN
                  MC(2) = MDAB
                  MC(-1) = 1
              ELSE
                  MC(2) = -MDAB
                  MC(-1) = -1
              ENDIF
              MC(3) = 0
          ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
              MC(0) = NINT(NDG2MX*ALOGM2)
              MC(1) = 2
              IF (MDAB >= 0) THEN
                  MC(2) = AINT (MDAB/MBASE)
                  MC(3) = ABS(MDAB - MBASE*MC(2))
                  MC(-1) = 1
              ELSE
                  MC(2) = AINT (-MDAB/MBASE)
                  MC(3) = ABS(-MDAB - MBASE*MC(2))
                  MC(-1) = -1
              ENDIF
          ELSE
              GO TO 110
          ENDIF
          IF (ABS(MDR) < MBASE) THEN
              MD(0) = MC(0)
              MD(1) = 1
              IF (MDR == 0) MD(1) = 0
              IF (MDR >= 0) THEN
                  MD(2) = MDR
                  MD(-1) = 1
              ELSE
                  MD(2) = -MDR
                  MD(-1) = -1
              ENDIF
              MD(3) = 0
              GO TO 170
          ELSE IF (ABS(MDR) < MBASE*MBASE) THEN
              MD(0) = MC(0)
              MD(1) = 2
              IF (MDR >= 0) THEN
                  MD(2) = AINT (MDR/MBASE)
                  MD(3) = ABS(MDR - MBASE*MD(2))
                  MD(-1) = 1
              ELSE
                  MD(2) = AINT (-MDR/MBASE)
                  MD(3) = ABS(-MDR - MBASE*MD(2))
                  MD(-1) = -1
              ENDIF
              GO TO 170
          ENDIF
      ENDIF

  110 KLTFLG = 0
      MAS = MA(-1)
      MBS = MB(-1)
      KL = INT(MB(1))
      IF (KL > NDG2MX) KL = 2
      DO J = 0, KL+1
         M01(J) = MB(J)
      ENDDO
      M01(-1) = 1
      IF (KL == 1) M01(3) = 0
      IF (MA(1) == M01(1) .AND. ABS(MA(2)) <= M01(2)) THEN
          DO J = 2, KL+1
             IF (MA(J) /= M01(J)) GO TO 120
          ENDDO
          KLTFLG = 2
  120     IF (KLTFLG == 0) THEN
              DO J = 2, KL+1
                 IF (MA(J) < M01(J)) THEN
                     KLTFLG = 1
                     EXIT
                 ELSE IF (MA(J) > M01(J)) THEN
                     EXIT
                 ENDIF
              ENDDO
          ENDIF
      ENDIF
      IF (MA(1) < MB(1) .OR. KLTFLG >= 1) THEN
          IF (KLTFLG /= 2) THEN
              CALL IMEQ(MA,MD)
              MD(-1) = ABS(MD(-1))
              CALL IMI2M(0,MC)
          ELSE
              CALL IMI2M(1,MC)
              CALL IMI2M(0,MD)
          ENDIF
          GO TO 160
      ENDIF

      NDIG = INT(MA(1))
      IF (NDIG < 2) NDIG = 2

      MACCA = MA(0)
      MACCB = MB(0)

!             NGUARD is the number of guard digits used.

      NGUARD = 1
      NA1 = INT(MA(1)) + 1
      NB1 = INT(MB(1)) + 1

!             Copy MA into the working array.

      DO J = 3, NA1
         MWA(J+1) = MA(J)
      ENDDO
      MWA(1) = MA(1) - MB(1) + 1
      MWA(2) = 0
      NL = NA1 + NGUARD + 3
      DO J = NA1+2, NL
         MWA(J) = 0
      ENDDO

!             Save the sign of MA and MB and then work only with
!             positive numbers.

      MAS = MA(-1)
      MB1 = MB(1)
      MBS = MB(-1)
      MWA(3) = MA(2)

!             NMBWDS is the number of words of MB used to
!             compute the estimated quotient digit MQD.

      NMBWDS = 4
      IF (MBASE < 100) NMBWDS = 7

!             XB is an approximation of MB used in
!             estimating the quotient digits.

      XBASE = DBLE(MBASE)
      XB = 0
      JL = NMBWDS
      IF (JL <= NB1) THEN
          DO J = 2, JL
             XB = XB*XBASE + DBLE(MB(J))
          ENDDO
      ELSE
          DO J = 2, JL
             IF (J <= NB1) THEN
                 XB = XB*XBASE + DBLE(MB(J))
             ELSE
                 XB = XB*XBASE
             ENDIF
          ENDDO
      ENDIF
      IF (JL+1 <= NB1) XB = XB + DBLE(MB(JL+1))/XBASE
      XBR = 1.0D0/XB

!             MLMAX determines when to normalize all of MWA.

      MBM1 = MBASE - 1
      MLMAX = MAXINT/MBM1
      MKT = INTMAX - MBASE
      MLMAX = MIN(MLMAX,MKT)

!             MAXMWA is an upper bound on the size of values in MWA
!             divided by MBASE-1.  It is used to determine whether
!             normalization can be postponed.

      MAXMWA = 0

!             KPTMWA points to the next digit in the quotient.

      KPTMWA = 2

!             This is the start of the division loop.

!             XMWA is an approximation of the active part of MWA
!             used in estimating quotient digits.

  130 KL = KPTMWA + NMBWDS - 1
      IF (KL <= NL) THEN
          XMWA = ((DBLE(MWA(KPTMWA))*XBASE  &
                 + DBLE(MWA(KPTMWA+1)))*XBASE  &
                 + DBLE(MWA(KPTMWA+2)))*XBASE  &
                 + DBLE(MWA(KPTMWA+3))
          DO J = KPTMWA+4, KL
             XMWA = XMWA*XBASE + DBLE(MWA(J))
          ENDDO
      ELSE
          XMWA = DBLE(MWA(KPTMWA))
          DO J = KPTMWA+1, KL
             IF (J <= NL) THEN
                 XMWA = XMWA*XBASE + DBLE(MWA(J))
             ELSE
                 XMWA = XMWA*XBASE
             ENDIF
          ENDDO
      ENDIF

!             MQD is the estimated quotient digit.

      MQD = AINT(XMWA*XBR)
      IF (MQD < 0) MQD = MQD - 1

      IF (MQD > 0) THEN
          MAXMWA = MAXMWA + MQD
      ELSE
          MAXMWA = MAXMWA - MQD
      ENDIF

!             See if MWA must be normalized.

      KA = KPTMWA + 1
      KB = KA + INT(MB1) - 1
      IF (MAXMWA >= MLMAX) THEN
          DO J = KB, KA, -1
             IF (MWA(J) < 0) THEN
                 MCARRY = INT((-MWA(J)-1)/MBASE) + 1
                 MWA(J) = MWA(J) + MCARRY*MBASE
                 MWA(J-1) = MWA(J-1) - MCARRY
             ELSE IF (MWA(J) >= MBASE) THEN
                 MCARRY = -INT(MWA(J)/MBASE)
                 MWA(J) = MWA(J) + MCARRY*MBASE
                 MWA(J-1) = MWA(J-1) - MCARRY
             ENDIF
          ENDDO
          XMWA = 0
          IF (KL <= NL) THEN
              DO J = KPTMWA, KL
                 XMWA = XMWA*XBASE + DBLE(MWA(J))
              ENDDO
          ELSE
              DO J = KPTMWA, KL
                 IF (J <= NL) THEN
                     XMWA = XMWA*XBASE + DBLE(MWA(J))
                 ELSE
                     XMWA = XMWA*XBASE
                 ENDIF
              ENDDO
          ENDIF
          MQD = AINT(XMWA*XBR)
          IF (MQD < 0) MQD = MQD - 1
          IF (MQD > 0) THEN
              MAXMWA = MQD
          ELSE
              MAXMWA = -MQD
          ENDIF
      ENDIF

!             Subtract MQD*MB from MWA.

      JB = KA - 2
      IF (MQD /= 0) THEN

!             Major (Inner Loop)

          DO J = KA, KB
             MWA(J) = MWA(J) - MQD*MB(J-JB)
          ENDDO
      ENDIF

      MWA(KA) = MWA(KA) + MWA(KA-1)*MBASE
      MWA(KPTMWA) = MQD

      KPTMWA = KPTMWA + 1
      IF (KPTMWA-2 < MWA(1)) GO TO 130

!             Final normalization.

      KPTMWA = KPTMWA - 1
      DO J = KPTMWA, 3, -1
         IF (MWA(J) < 0) THEN
             MCARRY = INT((-MWA(J)-1)/MBASE) + 1
             MWA(J) = MWA(J) + MCARRY*MBASE
             MWA(J-1) = MWA(J-1) - MCARRY
         ELSE IF (MWA(J) >= MBASE) THEN
             MCARRY = -INT(MWA(J)/MBASE)
             MWA(J) = MWA(J) + MCARRY*MBASE
             MWA(J-1) = MWA(J-1) - MCARRY
         ENDIF
      ENDDO

      LCRRCT = 0
  140 DO J = KPTMWA+INT(MB1), KPTMWA+2, -1
         IF (MWA(J) < 0) THEN
             MCARRY = INT((-MWA(J)-1)/MBASE) + 1
             MWA(J) = MWA(J) + MCARRY*MBASE
             MWA(J-1) = MWA(J-1) - MCARRY
         ELSE IF (MWA(J) >= MBASE) THEN
             MCARRY = -INT(MWA(J)/MBASE)
             MWA(J) = MWA(J) + MCARRY*MBASE
             MWA(J-1) = MWA(J-1) - MCARRY
         ENDIF
      ENDDO

!             Due to rounding, the remainder may not be between
!             0 and ABS(MB) here.  Correct if necessary.

      IF (MWA(KA) < 0) THEN
          LCRRCT = LCRRCT - 1
          DO J = KA, KB
             MWA(J) = MWA(J) + MB(J-JB)
          ENDDO
          GO TO 140
      ELSE IF (MWA(KA) >= MBASE) THEN
          LCRRCT = LCRRCT + 1
          DO J = KA, KB
             MWA(J) = MWA(J) - MB(J-JB)
          ENDDO
          GO TO 140
      ENDIF
      IF (MWA(2) /= 0 .OR. KPTMWA == 2) THEN
          DO J = 1, INT(MWA(1))+1
             MC(J) = MWA(J)
          ENDDO
      ELSE
          DO J = 3, INT(MWA(1))+1
             MC(J-1) = MWA(J)
          ENDDO
          IF (MC(2) /= 0) THEN
              MC(1) = MWA(1) - 1
          ELSE
              MC(1) = 0
          ENDIF
      ENDIF
      IF (MC(1) <= 1) MC(3) = 0
      MC(0) = MIN(MACCA,MACCB)
      MC(-1) = 1

      IF (MWA(KPTMWA+1) /= 0) THEN
          DO J = 1, INT(MB1)
             MD(J+1) = MWA(KPTMWA+J)
          ENDDO
          MD(1) = MB1
      ELSE
          DO J = 1, INT(MB1)
             IF (MWA(KPTMWA+J) /= 0) THEN
                 DO K = J, INT(MB1)
                    MD(K-J+2) = MWA(KPTMWA+K)
                 ENDDO
                 MD(1) = MB1 + 1 - J
                 GO TO 150
             ENDIF
          ENDDO
          MD(1) = 0
          MD(2) = 0
      ENDIF
  150 IF (MD(1) <= 1) MD(3) = 0
      MD(0) = MIN(MACCA,MACCB)
      MD(-1) = 1

!             If the remainder had to be corrected, make the
!             corresponding adjustment in the quotient.

      IF (MD(1) > M01(1) .OR.  &
         (MD(1) == M01(1) .AND. ABS(MD(2)) >= M01(2))) THEN
          IF (IMCOMP(MD,'GE',M01)) THEN
              CALL IMSUB(MD,M01,M10)
              CALL IMEQ(M10,MD)
              LCRRCT = LCRRCT + 1
          ENDIF
      ENDIF
      IF (LCRRCT /= 0) THEN
          CALL IMI2M(LCRRCT,M02)
          CALL IMADD(M02,MC,M10)
          CALL IMEQ(M10,MC)
      ENDIF

  160 MC(-1) = 1
      MD(-1) = 1
      IF (MAS < 0 .AND. MBS > 0) THEN
          IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1
          IF (MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -1
      ELSE IF (MAS > 0 .AND. MBS < 0)  THEN
          IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1
      ELSE IF (MAS < 0 .AND. MBS < 0)  THEN
          IF (MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -1
      ENDIF

  170 IF (MC(1) <= 1) MC(3) = 0
      IF (MD(1) <= 1) MD(3) = 0
      NTRACE = NTRSAV
      IF (NTRACE /= 0) THEN
          CALL IMNTR(1,MC,MC,1)
          IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN
              IF (NTRACE < 0) THEN
                  NDIG = MAX(2,INT(MD(1)))
                  IF (NDIG > NDG2MX) NDIG = 2
                  NTRSAV = NTRACE
                  IF (NTRACE < -2) NTRACE = -2
                  CALL IMNTRJ(MD,NDIG)
                  NTRACE = NTRSAV
              ELSE
                  CALL IMPRNT(MD)
              ENDIF
          ENDIF
      ENDIF
      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMDIVR

      SUBROUTINE IMDVIR(MA,IDIV,MB,IREM)

!  MB = INT(MA / IDIV),    IREM = Remainder from the division.

!  Division by a one word integer.  The remainder is also a
!  one word integer.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MAS,MDA,MDAB,MDB,MDR,MKT,MODINT,MVALP
      INTEGER IDIV,IREM,J,JDIV,KA,KL,KLTFLG,KPT,N1,NDSAVE,  &
              NMVAL,NTRSAV,NV2

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMDVIR',1,MA,MA)
      KFLAG = 0
      NDSAVE = NDIG
      KLTFLG = 0
      NTRSAV = NTRACE
      NTRACE = 0
      MKT = ABS(IDIV)
      IF (MKT < MBASE) THEN
          M01(0) = MA(0)
          M01(1) = 1
          M01(2) = ABS(IDIV)
          M01(-1) = 1
          IF (IDIV < 0) M01(-1) = -1
          M01(3) = 0
      ELSE IF (MKT < MBASE*MBASE) THEN
          M01(0) = MA(0)
          M01(1) = 2
          M01(2) = INT(MKT/MBASE)
          M01(3) = MKT - M01(2)*MBASE
          M01(-1) = 1
          IF (IDIV < 0) M01(-1) = -1
      ELSE
          CALL IMI2M(IDIV,M01)
      ENDIF
      NTRACE = NTRSAV
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMDVIR'
          CALL IMNTR(2,MA,MA,1)
          CALL IMNTRI(2,IDIV,0)
      ENDIF
      JDIV = ABS(IDIV)

!             Check for special cases.

      IF (MA(1) < 0) THEN
          IREM = IUNKNO
          KFLAG = -4
          NAMEST(NCALL) = 'IMDVIR'
          CALL FMWARN
          CALL IMST2M('UNKNOWN',MB)
          GO TO 150
      ENDIF
      IF (JDIV == 1 .AND. MA(1) /= MUNKNO) THEN
          IF (IDIV == 1) THEN
              CALL IMEQ(MA,MB)
              IREM = 0
              GO TO 150
          ELSE
              CALL IMEQ(MA,MB)
              IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
              IREM = 0
              GO TO 150
          ENDIF
      ENDIF
      IF (MA(1) > NDG2MX .OR. IDIV == 0) THEN
          KFLAG = -4
          IF (MA(1) /= MUNKNO) THEN
              NAMEST(NCALL) = 'IMDVIR'
              CALL FMWARN
          ENDIF
          CALL IMST2M('UNKNOWN',MB)
          IREM = IUNKNO
          GO TO 150
      ENDIF
      IF (MA(1) <= 2) THEN
          IF (MA(1) <= 1) THEN
              MDA = MA(-1) * MA(2)
          ELSE
              MDA = MA(-1) * (MA(2)*MBASE + MA(3))
          ENDIF
          MDB = IDIV
          MDAB = AINT (MDA/MDB)
          MDR = MDA - MDAB*MDB
          IF (ABS(MDAB) < MBASE) THEN
              MB(0) = MA(0)
              MB(1) = 1
              IF (MDAB == 0) MB(1) = 0
              IF (MDAB < 0) THEN
                  MB(2) = -MDAB
                  MB(-1) = -1
              ELSE
                  MB(2) = MDAB
                  MB(-1) = 1
              ENDIF
              MB(3) = 0
          ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
              MB(0) = MA(0)
              MB(1) = 2
              IF (MDAB < 0) THEN
                  MB(2) = AINT (-MDAB/MBASE)
                  MB(3) = ABS(-MDAB - MBASE*MB(2))
                  MB(-1) = -1
              ELSE
                  MB(2) = AINT (MDAB/MBASE)
                  MB(3) = ABS(MDAB - MBASE*MB(2))
                  MB(-1) = 1
              ENDIF
          ELSE
              GO TO 110
          ENDIF
          IREM = INT(MDR)
          GO TO 150
      ENDIF

  110 MAS = MA(-1)
      M01(-1) = 1
      IF (MA(1) <= M01(1)) THEN
          IF (MA(1) == M01(1) .AND. ABS(MA(2)) <= M01(2)) THEN
              DO J = 2, KL+1
                 IF (MA(J) /= M01(J)) GO TO 120
              ENDDO
              KLTFLG = 2
  120         IF (KLTFLG == 0) THEN
                  DO J = 2, KL+1
                     IF (MA(J) < M01(J)) THEN
                         KLTFLG = 1
                         EXIT
                     ENDIF
                  ENDDO
              ENDIF
          ENDIF
          IF (MA(1) < M01(1) .OR. KLTFLG >= 1) THEN
              IF (KLTFLG /= 2) THEN
                  CALL IMM2I(MA,IREM)
                  IREM = ABS(IREM)
                  CALL IMI2M(0,MB)
              ELSE
                  CALL IMI2M(1,MB)
                  IREM = 0
              ENDIF
              GO TO 140
          ENDIF
      ENDIF
      NDIG = INT(MA(1))
      IF (NDIG < 2) NDIG = 2
      N1 = INT(MA(1)) + 1

!             If ABS(IDIV) >= MXBASE use IMDIVR.

      MVALP = ABS(IDIV)
      NMVAL = INT(MVALP)
      NV2 = NMVAL - 1
      IF (ABS(IDIV) > MXBASE .OR. NMVAL /= ABS(IDIV) .OR.  &
          NV2 /= ABS(IDIV)-1) THEN
          CALL IMI2M(IDIV,M03)
          CALL IMDIVR(MA,M03,MB,M11)
          CALL IMEQ(M11,M03)
          CALL IMM2I(M03,IREM)
          GO TO 150
      ENDIF

!             Find the first significant digit of the quotient.

      MKT = MA(2)
      IF (MKT >= MVALP) THEN
          KPT = 2
          GO TO 130
      ENDIF
      DO J = 3, N1
         MKT = MKT*MBASE + MA(J)
         IF (MKT >= MVALP) THEN
             KPT = J
             GO TO 130
         ENDIF
      ENDDO

      CALL IMM2I(MA,IREM)
      CALL IMI2M(0,MB)
      GO TO 150

!             Do the rest of the division.

  130 KA = KPT + 1
      MWA(1) = MA(1) + 2 - KPT
      MWA(2) = INT (MKT/MVALP)
      MODINT = MKT - MWA(2)*MVALP
      IF (KA <= N1) THEN
          KL = 3 - KA

!             (Inner Loop)

          DO J = KA, N1
             MKT = MODINT*MBASE + MA(J)
             MWA(KL+J) = INT (MKT/MVALP)
             MODINT = MKT - MWA(KL+J)*MVALP
          ENDDO
      ENDIF

      MB(0) = MA(0)
      DO J = 1, INT(MWA(1))+1
         MB(J) = MWA(J)
      ENDDO
      IREM = INT(MODINT)

  140 MB(-1) = 1
      IF (MAS < 0 .AND. IDIV > 0) THEN
          IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1
          IREM = -IREM
      ELSE IF (MAS > 0 .AND. IDIV < 0)  THEN
          IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1
      ELSE IF (MAS < 0 .AND. IDIV < 0)  THEN
          IREM = -IREM
      ENDIF

  150 IF (MB(1) <= 1) MB(3) = 0
      IF (NTRACE /= 0 .AND. NCALL <= LVLTRC) THEN
          CALL IMNTR(1,MB,MB,1)
          CALL IMNTRI(1,IREM,0)
      ENDIF

      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMDVIR

      SUBROUTINE IMEQ(MA,MB)

!  MB = MA

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      INTEGER J,KDG

      KDG = MAX(2,INT(MA(1))) + 1
      IF (KDG > LUNPCK) KDG = 3
      DO J = -1, KDG
         MB(J) = MA(J)
      ENDDO
      RETURN
      END SUBROUTINE IMEQ

      SUBROUTINE IMFM2I(MA,MB)

!  MB = INT(MA)

!  Convert from real (FM) format to integer (IM) format.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      INTEGER J,NTRSAV

      NCALL = NCALL + 1
      KFLAG = 0
      NTRSAV = NTRACE
      NTRACE = 0
      CALL FMEQ(MA,MB)
      CALL FMINT(MB,M08)
      CALL FMEQ(M08,MB)
      IF (MB(1) > NDIGMX) THEN
          IF (MB(1) <= NDG2MX .OR. NCALL <= 1) THEN
              KFLAG = -4
              NAMEST(NCALL) = 'IMFM2I'
              CALL FMWARN
              CALL IMST2M('UNKNOWN',MB)
          ENDIF
      ELSE
          DO J = NDIG+2, INT(MA(1))+1
             MB(J) = 0
          ENDDO
      ENDIF
      IF (MB(1) <= 1) MB(3) = 0
      NTRACE = NTRSAV
      NCALL = NCALL - 1

      RETURN
      END SUBROUTINE IMFM2I

      SUBROUTINE IMFORM(FORM,MA,STRING)

!  Convert an IM number (MA) to a character string base 10 (STRING)
!  using character string FORM format.

!  FORM can be one of these types:  Iw,  Fw.d,  Ew.d,  1PEw.d
!       for positive integers w,d.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(*) :: FORM,STRING
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER NDSAVE

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMFORM',1,MA,MA)
      KFLAG = 0
      NAMEST(NCALL) = 'IMFORM'
      NDSAVE = NDIG
      NDIG = INT(MA(1))
      IF (NDIG < 2 .OR. NDIG > NDG2MX) NDIG = 2

      CALL FMFORM(FORM,MA,STRING)

      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMFORM

      SUBROUTINE IMFPRT(FORM,MA)

!  Print an IM number (MA) on unit KW using character
!  string FORM format.

!  FORM can be one of these types:  Iw,  Fw.d,  Ew.d,  1PEw.d
!       for positive integers w,d.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(*) :: FORM
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER NDSAVE

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMFPRT',1,MA,MA)
      KFLAG = 0
      NAMEST(NCALL) = 'IMFPRT'
      NDSAVE = NDIG
      NDIG = INT(MA(1))
      IF (NDIG < 2 .OR. NDIG > NDG2MX) NDIG = 2

      CALL FMFPRT(FORM,MA)

      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMFPRT

      SUBROUTINE IMGCD(MA,MB,MC)

!  MC is returned as the greatest common divisor of MA and MB.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
      INTEGER NDSAVE

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMGCD ',2,MA,MB)
      KFLAG = 0
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMGCD '
          CALL IMNTR(2,MA,MB,2)
      ENDIF

!             Check for special cases.

      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
          CALL IMST2M('UNKNOWN',MC)
          KFLAG = -4
          GO TO 120
      ELSE IF (MB(2) == 0) THEN
          CALL IMABS(MA,MC)
          GO TO 120
      ELSE IF (MA(2) == 0) THEN
          CALL IMABS(MB,MC)
          GO TO 120
      ELSE IF (MB(1) == 1 .AND. ABS(MB(2)) == 1) THEN
          CALL IMI2M(1,MC)
          GO TO 120
      ELSE IF (MA(1) == 1 .AND. ABS(MA(2)) == 1) THEN
          CALL IMI2M(1,MC)
          GO TO 120
      ELSE IF (MA(1) >= NDG2MX .OR. MB(1) >= NDG2MX .OR.  &
          MA(1) < 0 .OR. MB(1) < 0) THEN
          KFLAG = -4
          NAMEST(NCALL) = 'IMGCD '
          CALL FMWARN
          CALL IMST2M('UNKNOWN',MC)
          GO TO 120
      ENDIF

      CALL IMABS(MA,M05)
      CALL IMABS(MB,M04)
      CALL IMMAX(M05,M04,M03)
      CALL IMMIN(M05,M04,M11)
      CALL IMEQ(M11,M04)
  110 CALL IMDIVR(M03,M04,MC,M05)
      IF (M05(2) /= 0) THEN
          CALL IMEQ(M04,M03)
          CALL IMEQ(M05,M04)
          GO TO 110
      ENDIF
      CALL IMEQ(M04,MC)

      IF (MC(1) == MUNKNO) THEN
          KFLAG = -4
          NAMEST(NCALL) = 'IMGCD '
          CALL FMWARN
      ENDIF

  120 IF (MC(1) <= 1) MC(3) = 0
      IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMGCD

      SUBROUTINE IMI2FM(MA,MB)

!  MB = MA

!  Convert from integer (IM) format to real (FM) format.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      INTEGER KDG

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMI2FM',1,MA,MA)
      KFLAG = 0
      KDG = MAX(2,INT(MA(1)))
      IF (KDG > NDG2MX) KDG = 2
      CALL FMEQU(MA,MB,KDG,NDIG)
      MB(0) = NINT(NDG2MX*ALOGM2)
      NCALL = NCALL - 1

      RETURN
      END SUBROUTINE IMI2FM

      SUBROUTINE IMI2M(IVAL,MA)

!  MA = IVAL

!  Convert a one word integer to IM format.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER IVAL

      INTEGER NDSAVE

      NCALL = NCALL + 1
      KFLAG = 0
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMI2M '
          CALL IMNTRI(2,IVAL,1)

          NDIG = 4
          CALL FMIM(IVAL,MA)
          IF (MA(1) > 4) THEN
              NDIG = NDIGMX
              CALL FMIM(IVAL,MA)
          ENDIF

          CALL IMNTR(1,MA,MA,1)
      ELSE
          NDIG = 4
          CALL FMIM(IVAL,MA)
          IF (MA(1) > 4) THEN
              NDIG = NDIGMX
              CALL FMIM(IVAL,MA)
          ENDIF
      ENDIF
      IF (MA(1) <= 1) MA(3) = 0
      NDIG = NDSAVE
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE IMI2M

      SUBROUTINE IMINP(LINE,MA,LA,LB)

!  Convert an array of characters to multiple precision integer format.

!  LINE is an A1 character array of length LB to be converted
!       to IM format and returned in MA.
!  LA is a pointer telling the routine where in the array to begin
!     the conversion.
!  LB is a pointer to the last character of the field for that number.

      USE FMVALS
      IMPLICIT NONE

      INTEGER KFSAVE,NDSAVE,LA,LB
      CHARACTER LINE(LB)
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      NCALL = NCALL + 1
      KFLAG = 0
      NDSAVE = NDIG
      NAMEST(NCALL) = 'IMINP '

      NDIG = NDIGMX
      CALL FMINP(LINE,MA,LA,LB)
      KFSAVE = KFLAG
      CALL FMINT(MA,M08)
      CALL FMEQ(M08,MA)
      KFLAG = KFSAVE

      IF (MA(1) > NDG2MX .AND. MA(1) < MEXPOV) THEN
          KFLAG = -9
          NDIG = INT(MA(1))
          CALL FMWARN
          MA(-1) = 1
          MA(0) = NINT(NDG2MX*ALOGM2)
          MA(1) = MUNKNO
          MA(2) = 1
          MA(3) = 0
      ENDIF

      IF (MA(1) <= 1) MA(3) = 0
      NDIG = NDSAVE
      IF (NTRACE /= 0) CALL IMNTR(1,MA,MA,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE IMINP

      SUBROUTINE IMM2DP(MA,X)

!  X = MA

!  Convert an IM number to double precision.

!  If KFLAG = -4 is returned for a value of MA that is in the range
!  of the machine's double precision number system, change the
!  definition of DPMAX in routine FMSET to reflect the current machine's
!  range.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      DOUBLE PRECISION X

      INTEGER KRESLT,NDSAVE

      NCALL = NCALL + 1
      KFLAG = 0
      NAMEST(NCALL) = 'IMM2DP'
      KRESLT = 0
      IF (ABS(MA(1)) > MEXPAB) THEN
          CALL FMARGS('IMM2DP',1,MA,MA,KRESLT)
      ENDIF
      IF (NTRACE /= 0) CALL IMNTR(2,MA,MA,1)
      IF (KRESLT /= 0) THEN

!             Here no valid result can be returned.  Set X to some
!             value that the user is likely to recognize as wrong.

          X = DBLE(RUNKNO)
          KFLAG = -4
          IF (MA(1) /= MUNKNO) CALL FMWARN
          IF (NTRACE /= 0) CALL IMNTRR(1,X,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF

      NDSAVE = NDIG
      NDIG = MAX(2,INT(MA(1)))
      IF (NDIG > NDG2MX) NDIG = 2
      CALL FMMD(MA,X)

      IF (NTRACE /= 0) CALL IMNTRR(1,X,1)
      NDIG = NDSAVE
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE IMM2DP

      SUBROUTINE IMM2I(MA,IVAL)

!  IVAL = MA

!  Convert an IM number to a one word integer.

!  KFLAG =  0 is returned if the conversion is exact.
!        = -4 is returned if MA is larger than INTMAX in magnitude.
!             IVAL = IUNKNO is returned as an indication that IVAL
!             could not be computed without integer overflow.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      INTEGER IVAL,NDSAVE

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMM2I ',1,MA,MA)
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMM2I '
          CALL IMNTR(2,MA,MA,1)
      ENDIF

      NDIG = INT(MA(1))
      IF (NDIG < 2) NDIG = 2
      IF (NDIG > NDG2MX) NDIG = 2
      KFLAG = 0
      CALL FMM2I(MA,IVAL)

      IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN
          CALL IMNTRI(1,IVAL,1)
      ENDIF
      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMM2I

      SUBROUTINE IMMAX(MA,MB,MC)

!  MC = MAX(MA,MB)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      INTEGER KWRNSV
      LOGICAL IMCOMP

      KFLAG = 0
      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMMAX ',2,MA,MB)
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMMAX '
          CALL IMNTR(2,MA,MB,2)
      ENDIF

      KWRNSV = KWARN
      KWARN = 0
      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
          CALL IMST2M('UNKNOWN',MC)
          KFLAG = -4
      ELSE IF (IMCOMP(MA,'LT',MB)) THEN
          CALL IMEQ(MB,MC)
      ELSE
          CALL IMEQ(MA,MC)
      ENDIF

      IF (MC(1) <= 1) MC(3) = 0
      KWARN = KWRNSV
      IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE IMMAX

      SUBROUTINE IMMIN(MA,MB,MC)

!  MC = MIN(MA,MB)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      INTEGER KWRNSV
      LOGICAL IMCOMP

      KFLAG = 0
      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMMIN ',2,MA,MB)
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMMIN '
          CALL IMNTR(2,MA,MB,2)
      ENDIF

      KWRNSV = KWARN
      KWARN = 0
      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
          CALL IMST2M('UNKNOWN',MC)
          KFLAG = -4
      ELSE IF (IMCOMP(MA,'GT',MB)) THEN
          CALL IMEQ(MB,MC)
      ELSE
          CALL IMEQ(MA,MC)
      ENDIF

      IF (MC(1) <= 1) MC(3) = 0
      KWARN = KWRNSV
      IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE IMMIN

      SUBROUTINE IMMOD(MA,MB,MC)

!  MC = MOD(MA,MB)

!  Use IMDIVR if both INT(MA/MB) and MOD(MA,MB) are needed.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
      INTEGER NDSAVE

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMMOD ',2,MA,MB)
      KFLAG = 0
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMMOD '
          CALL IMNTR(2,MA,MB,2)
      ENDIF

      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
          CALL IMST2M('UNKNOWN',MC)
          KFLAG = -4
          GO TO 110
      ENDIF

      CALL IMDIVR(MA,MB,M03,MC)

      IF (MC(1) == MUNKNO) THEN
          KFLAG = -4
          NAMEST(NCALL) = 'IMMOD '
          CALL FMWARN
      ENDIF

  110 IF (MC(1) <= 1) MC(3) = 0
      IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMMOD

      SUBROUTINE IMMPY(MA,MB,MC)

!  MC = MA * MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MDAB
      INTEGER KOVFL,NDSAVE

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMMPY ',2,MA,MB)
      KFLAG = 0
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMMPY '
          CALL IMNTR(2,MA,MB,2)
      ENDIF

      IF (MA(1) <= 1) THEN
          IF (MB(1) > 1) GO TO 110
          MDAB = MA(-1) * MA(2) * MB(-1) * MB(2)
          IF (ABS(MDAB) < MBASE) THEN
              MC(0) = MIN(MA(0),MB(0))
              MC(1) = 1
              IF (MDAB == 0) MC(1) = 0
              IF (MDAB >= 0) THEN
                  MC(2) = MDAB
                  MC(-1) = 1
              ELSE
                  MC(2) = -MDAB
                  MC(-1) = -1
              ENDIF
              MC(3) = 0
              GO TO 120
          ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
              MC(0) = MIN(MA(0),MB(0))
              MC(1) = 2
              IF (MDAB >= 0) THEN
                  MC(2) = AINT (MDAB/MBASE)
                  MC(3) = ABS(MDAB - MBASE*MC(2))
                  MC(-1) = 1
              ELSE
                  MC(2) = AINT (-MDAB/MBASE)
                  MC(3) = ABS(-MDAB - MBASE*MC(2))
                  MC(-1) = -1
              ENDIF
              GO TO 120
          ENDIF
      ENDIF

!             Check for special cases.

  110 KOVFL = 0
      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
          KFLAG = -4
          CALL IMST2M('UNKNOWN',MC)
          GO TO 130
      ENDIF
      IF (MA(2) == 0 .OR. MB(2) == 0) THEN
          MC(-1) = 1
          MC(0) = NINT(NDG2MX*ALOGM2)
          MC(1) = 0
          MC(2) = 0
          MC(3) = 0
          GO TO 130
      ENDIF
      IF (MA(1) == MEXPOV .OR. MB(1) == MEXPOV) THEN
          KOVFL = 1
          KFLAG = -5
          IF (MA(-1)*MB(-1) < 0) THEN
              CALL IMST2M('-OVERFLOW',MC)
          ELSE
              CALL IMST2M('OVERFLOW',MC)
          ENDIF
          GO TO 130
      ENDIF
      IF (MA(1) < 0 .OR. MB(1) < 0) THEN
          KFLAG = -4
          NAMEST(NCALL) = 'IMMPY '
          CALL FMWARN
          CALL IMST2M('UNKNOWN',MC)
          GO TO 130
      ENDIF
      IF (MB(1) == 1 .AND. MB(2) == 1 .AND. MB(-1) == 1) THEN
          CALL IMEQ(MA,MC)
          GO TO 120
      ELSE IF (MB(1) == 1 .AND. MB(2) == 1 .AND. MB(-1) == -1) THEN
          CALL IMEQ(MA,MC)
          IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
          GO TO 120
      ELSE IF (MA(1) == 1 .AND. MA(2) == 1 .AND. MA(-1) == 1) THEN
          CALL IMEQ(MB,MC)
          GO TO 120
      ELSE IF (MA(1) == 1 .AND. MA(2) == 1 .AND. MA(-1) == -1) THEN
          CALL IMEQ(MB,MC)
          IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
          GO TO 120
      ENDIF
      NDIG = INT(MA(1) + MB(1))
      IF (NDIG > NDIGMX) THEN
          IF (NCALL == 1 .OR. NDIG > NDG2MX) THEN
              IF (MA(-1)*MB(-1) > 0) THEN
                  CALL IMST2M('OVERFLOW',MC)
              ELSE
                  CALL IMST2M('-OVERFLOW',MC)
              ENDIF
              KFLAG = -5
              NAMEST(NCALL) = 'IMMPY '
              CALL FMWARN
              GO TO 130
          ENDIF
      ENDIF

      IF (NDIG < 2) NDIG = 2
      IF (NDIG > NDG2MX) NDIG = NDG2MX
      CALL IMMPY2(MA,MB)

!             Transfer to MC and fix the sign of the result.

      NDIG = MWA(1)
      IF (NDIG < 2) NDIG = 2
      IF (NDIG > NDG2MX) NDIG = NDG2MX
      IF (MA(-1)*MB(-1) < 0) THEN
          CALL FMMOVE(MWA,MC)
          MC(0) = NINT(NDIGMX*ALOGM2)
          MC(-1) = -1
      ELSE
          CALL FMMOVE(MWA,MC)
          MC(0) = NINT(NDIGMX*ALOGM2)
          MC(-1) = 1
      ENDIF

      IF (NDIG > NDIGMX) NDIG = 2
  120 IF (MC(1) > NDIGMX) THEN
          IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN
              IF (MC(-1) > 0) THEN
                  CALL IMST2M('OVERFLOW',MC)
              ELSE
                  CALL IMST2M('-OVERFLOW',MC)
              ENDIF
              KFLAG = -5
              NAMEST(NCALL) = 'IMMPY '
              IF (KOVFL /= 1) CALL FMWARN
          ENDIF
      ENDIF

  130 IF (MC(1) <= 1) MC(3) = 0
      IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMMPY

      SUBROUTINE IMMPY2(MA,MB)

!  Internal multiplication of MA*MB.  The result is returned in MWA.
!  Both MA and MB are positive.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MAXMWA,MBJ,MBM1,MKT,MMAX
      INTEGER J,JM1,K,KB,KL,KLMA,KLMB,N1

      N1 = NDIG + 1
      MWA(1) = MA(1) + MB(1)
      MWA(N1+1) = 0

!             The multiplication loop begins here.

!             MAXMWA is an upper bound on the size of values in MWA
!                    divided by (MBASE-1).  It is used to determine
!                    whether to normalize before the next digit is
!                    multiplied.

      MBM1 = MBASE - 1
      MMAX = INTMAX - MBASE
      MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX)
      MBJ = MB(2)
      MWA(2) = 0
      KLMA = INT(MA(1))
      DO K = KLMA+3, N1
         MWA(K) = 0
      ENDDO

!             (Inner Loop)

      DO K = 2, KLMA+1
         MWA(K+1) = MA(K)*MBJ
      ENDDO
      MAXMWA = MBJ
      KLMB = INT(MB(1))
      DO J = 3, KLMB+1
         MBJ = MB(J)
         IF (MBJ /= 0) THEN
             MAXMWA = MAXMWA + MBJ
             JM1 = J - 1
             KL = KLMA + 1

!                       Major (Inner Loop)

             DO K = J+1, J+KLMA
                MWA(K) = MWA(K) + MA(K-JM1)*MBJ
             ENDDO
         ENDIF

         IF (MAXMWA > MMAX) THEN
             MAXMWA = 0

!                       Here normalization is only required for the
!                       range of digits currently changing in MWA.

             DO KB = JM1+KL, JM1+2, -1
                MKT = INT (MWA(KB)/MBASE)
                MWA(KB-1) = MWA(KB-1) + MKT
                MWA(KB) = MWA(KB) - MKT*MBASE
             ENDDO
         ENDIF
      ENDDO

!             Perform the final normalization.  (Inner Loop)

      DO KB = N1, 3, -1
         MKT = INT (MWA(KB)/MBASE)
         MWA(KB-1) = MWA(KB-1) + MKT
         MWA(KB) = MWA(KB) - MKT*MBASE
      ENDDO

      RETURN
      END SUBROUTINE IMMPY2

      SUBROUTINE IMMPYI(MA,IVAL,MB)

!  MB = MA * IVAL

!  Multiplication by a one word integer.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MAS,MCARRY,MDAB,MKT,MVAL
      INTEGER IVAL,J,KA,KB,KC,KOVFL,KSHIFT,N1,NDSAVE,NMVAL,  &
              NTRSAV,NV2

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMMPYI',1,MA,MA)
      KFLAG = 0
      NDSAVE = NDIG
      NTRSAV = NTRACE
      NTRACE = 0
      NTRACE = NTRSAV
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMMPYI'
          CALL IMNTR(2,MA,MA,1)
          CALL IMNTRI(2,IVAL,0)
      ENDIF
      MAS = MA(-1)

      IF (MA(1) <= 1) THEN
          MDAB = MA(-1) * MA(2) * IVAL
          IF (ABS(MDAB) < MBASE) THEN
              MB(0) = MA(0)
              MB(1) = 1
              IF (MDAB == 0) MB(1) = 0
              MB(-1) = 1
              IF (MDAB < 0) MB(-1) = -1
              MB(2) = ABS(MDAB)
              MB(3) = 0
              GO TO 120
          ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
              MB(0) = MA(0)
              MB(1) = 2
              MB(-1) = 1
              IF (MDAB < 0) MB(-1) = -1
              MDAB = ABS(MDAB)
              MB(2) = AINT (MDAB/MBASE)
              MB(3) = MDAB - MBASE*MB(2)
              GO TO 120
          ENDIF
      ENDIF

!             Check for special cases.

      KOVFL = 0
      IF (MA(1) == MEXPOV) KOVFL = 1
      IF (MA(1) < 0) THEN
          KFLAG = -4
          NAMEST(NCALL) = 'IMMPYI'
          CALL FMWARN
          CALL IMST2M('UNKNOWN',MB)
          GO TO 130
      ENDIF
      IF (MA(1) == MUNKNO) THEN
          KFLAG = -4
          CALL IMST2M('UNKNOWN',MB)
          GO TO 130
      ELSE IF (IVAL == 0) THEN
          CALL IMI2M(0,MB)
          GO TO 120
      ELSE IF (IVAL == 1) THEN
          CALL IMEQ(MA,MB)
          GO TO 120
      ELSE IF (IVAL == -1) THEN
          CALL IMEQ(MA,MB)
          IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
          GO TO 120
      ELSE IF (MA(1) == 1 .AND. MA(2)*MA(-1) == 1) THEN
          CALL IMI2M(IVAL,MB)
          GO TO 120
      ELSE IF (MA(1) == 1 .AND. MA(2)*MA(-1) == -1) THEN
          CALL IMI2M(IVAL,MB)
          IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
          GO TO 120
      ELSE IF (MA(1) == MEXPOV) THEN
          KFLAG = -5
          CALL IMST2M('OVERFLOW',MB)
          GO TO 110
      ENDIF

!             Work with positive numbers.

      MVAL = ABS(IVAL)
      NMVAL = INT(MVAL)
      NV2 = NMVAL - 1
      NDIG = INT(MA(1))
      N1 = NDIG + 1

!             To leave room for normalization, shift the product
!             to the right KSHIFT places in MWA.

      KSHIFT = INT((LOG(DBLE(MA(2)+1)*DBLE(MVAL)))/DLOGMB)

!             If IVAL is too big, use IMMPY.

      IF (KSHIFT > NDIG .OR. MVAL > MAXINT/MBASE .OR.  &
          NMVAL /= ABS(IVAL) .OR. NV2 /= ABS(IVAL)-1) THEN
          CALL IMI2M(IVAL,M01)
          CALL IMMPY(MA,M01,MB)
          GO TO 120
      ENDIF

      MWA(1) = MA(1) + KSHIFT
      KA = 2 + KSHIFT
      KB = N1 + KSHIFT
      KC = NDIG + 5
      DO J = KB, KC
         MWA(J) = 0
      ENDDO

      MCARRY = 0

!             This is the main multiplication loop.

      DO J = KB, KA, -1
         MKT = MA(J-KSHIFT)*MVAL + MCARRY
         MCARRY = INT (MKT/MBASE)
         MWA(J) = MKT - MCARRY*MBASE
      ENDDO

!             Resolve the final carry.

      DO J = KA-1, 2, -1
         MKT = INT (MCARRY/MBASE)
         MWA(J) = MCARRY - MKT*MBASE
         MCARRY = MKT
      ENDDO

!             Now the first significant digit in the product is in
!             MWA(2) or MWA(3).

      MB(0) = MA(0)
      IF (MWA(2) == 0) THEN
          MB(1) = MWA(1) - 1
          DO J = 3, KB
             MB(J-1) = MWA(J)
          ENDDO
      ELSE
          MB(1) = MWA(1)
          DO J = 2, KB
             MB(J) = MWA(J)
          ENDDO
      ENDIF

!             Put the sign on the result.

  110 MB(-1) = 1
      IF ((IVAL > 0 .AND. MAS < 0) .OR. (IVAL < 0 .AND.MAS > 0))  &
           MB(-1) = -1

  120 IF (MB(1) > NDIGMX) THEN
          IF (NCALL == 1 .OR. MB(1) > NDG2MX) THEN
              IF (MB(-1) > 0) THEN
                  CALL IMST2M('OVERFLOW',MB)
              ELSE
                  CALL IMST2M('-OVERFLOW',MB)
              ENDIF
              KFLAG = -5
              NAMEST(NCALL) = 'IMMPYI'
              IF (KOVFL /= 1) CALL FMWARN
          ENDIF
      ENDIF

  130 IF (MB(1) <= 1) MB(3) = 0
      IF (NTRACE /= 0) CALL IMNTR(1,MB,MB,1)
      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMMPYI

      SUBROUTINE IMMPYM(MA,MB,MC,MD)

!  MD = MA * MB mod MC

!  This routine is slightly faster than calling IMMPY and IMMOD
!  separately, and it works for cases where IMMPY would return
!  OVERFLOW.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK),  &
                            MD(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MAS,MAXMWA,MBM1,MBS,MC1,MCARRY,  &
                            MDC,MDAB,MKT,MLMAX,MQD
      DOUBLE PRECISION  XB,XBASE,XBR,XMWA
      INTEGER J,JB,JL,K,KA,KB,KL,KLTFLG,KPTMWA,N1,NA1,NC1,NDSAVE,  &
              NGUARD,NL,NMCWDS,NTRSAV
      LOGICAL IMCOMP

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMMPYM',2,MA,MB)
      NDSAVE = NDIG
      KFLAG = 0
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMMPYM'
          CALL IMNTR(2,MA,MB,2)
          IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
              IF (NTRACE < 0) THEN
                  NDIG = MAX(2,INT(MC(1)))
                  IF (NDIG > NDG2MX) NDIG = 2
                  NTRSAV = NTRACE
                  IF (NTRACE < -2) NTRACE = -2
                  CALL IMNTRJ(MC,NDIG)
                  NTRACE = NTRSAV
                  NDIG = NDSAVE
              ELSE
                  CALL IMPRNT(MC)
              ENDIF
          ENDIF
      ENDIF

      IF (MA(1) <= 1) THEN
          IF (MB(1) > 1) GO TO 110
          IF (MA(1) < 0 .OR. MB(1) < 0) GO TO 110
          MDAB = MA(-1) * MA(2) * MB(-1) * MB(2)
          IF (MC(1) <= 2) THEN
              IF (MC(2) == 0) GO TO 110
              IF (MC(1) <= 1) THEN
                  MDC = MC(-1) * MC(2)
              ELSE
                  MDC = MC(-1) * (MC(2)*MBASE + MC(3))
              ENDIF
              MDAB = MOD(MDAB,MDC)
          ENDIF
          IF (ABS(MDAB) < MBASE) THEN
              MD(0) = MIN(MA(0),MB(0),MC(0))
              MD(1) = 1
              IF (MDAB == 0) MD(1) = 0
              MD(-1) = 1
              IF (MDAB < 0) MD(-1) = -1
              MD(2) = ABS(MDAB)
              MD(3) = 0
              GO TO 160
          ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
              MD(0) = MIN(MA(0),MB(0),MC(0))
              MD(1) = 2
              MD(-1) = 1
              IF (MDAB < 0) MD(-1) = -1
              MDAB = ABS(MDAB)
              MD(2) = AINT (MDAB/MBASE)
              MD(3) = MDAB - MBASE*MD(2)
              GO TO 160
          ENDIF
      ENDIF

!             Check for special cases.

  110 IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR. MC(1) == MUNKNO) THEN
          KFLAG = -4
          CALL IMST2M('UNKNOWN',MD)
          GO TO 170
      ELSE IF (MC(2) == 0 .OR. MA(1) < 0 .OR. MB(1) < 0 .OR. MC(1) < 0) THEN
          KFLAG = -4
          NAMEST(NCALL) = 'IMMPYM'
          CALL FMWARN
          CALL IMST2M('UNKNOWN',MD)
          GO TO 170
      ELSE IF (MA(2) == 0 .OR. MB(2) == 0) THEN
          CALL IMI2M(0,MD)
          GO TO 170
      ELSE IF (MC(1) == 1 .AND. MC(2) == 1) THEN
          CALL IMI2M(0,MD)
          GO TO 170
      ELSE IF (MB(1) == 1 .AND. MB(2) == 1 .AND. MB(-1) == 1) THEN
          CALL IMMOD(MA,MC,MD)
          GO TO 160
      ELSE IF (MB(1) == 1 .AND. MB(2) == 1 .AND. MB(-1) == -1) THEN
          CALL IMMOD(MA,MC,MD)
          IF (MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -MD(-1)
          GO TO 160
      ELSE IF (MA(1) == 1 .AND. MA(2) == 1 .AND. MA(-1) == 1) THEN
          CALL IMMOD(MB,MC,MD)
          GO TO 160
      ELSE IF (MA(1) == 1 .AND. MA(2) == 1 .AND. MA(-1) == -1) THEN
          CALL IMMOD(MB,MC,MD)
          IF (MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -MD(-1)
          GO TO 160
      ELSE IF (MA(1) > NDG2MX .OR. MB(1) > NDG2MX .OR.  &
          MC(1) > NDG2MX) THEN
          KFLAG = -4
          NAMEST(NCALL) = 'IMMPYM'
          CALL FMWARN
          CALL IMST2M('UNKNOWN',MD)
          GO TO 170
      ENDIF

      NDIG = INT(MA(1) + MB(1))
      IF (NDIG < 2) NDIG = 2
      IF (NDIG > LMWA) NDIG = LMWA

!             Save the sign of MA and MB and then work only with
!             positive numbers.

      MAS = MA(-1)
      MBS = MB(-1)

      N1 = NDIG + 1

!             It is faster if the second argument is the one
!             with fewer digits.

      IF (MA(1) < MB(1)) THEN
          CALL IMMPY2(MB,MA)
      ELSE
          CALL IMMPY2(MA,MB)
      ENDIF

!             Now do the division to find MWA mod MC.

      KLTFLG = 0
      IF (MWA(2) == 0) THEN
          MWA(1) = MWA(1) - 1
      ELSE
          DO J = N1, 2, -1
             MWA(J+1) = MWA(J)
          ENDDO
          MWA(2) = 0
      ENDIF
      KL = INT(MC(1))
      IF (KL > LMWA) KL = 2
      DO J = -1, KL+1
         M01(J) = MC(J)
      ENDDO
      M01(-1) = 1
      IF (MWA(1) == M01(1) .AND. ABS(MWA(3)) <= M01(2)) THEN
          DO J = 4, N1
             M02(J-1) = MWA(J)
          ENDDO
          M02(2) = ABS(MWA(3))
          M02(1) = MWA(1)
          IF (IMCOMP(M02,'EQ',M01)) THEN
              KLTFLG = 2
          ELSE IF (IMCOMP(M02,'LT',M01)) THEN
              KLTFLG = 1
          ENDIF
      ENDIF
      IF (MWA(1) < MC(1) .OR. KLTFLG >= 1) THEN
          IF (KLTFLG /= 2) THEN
              DO J = 3, N1+1
                 MD(J-1) = MWA(J)
              ENDDO
              MD(1) = MWA(1)
              MD(0) = MIN(MA(0),MB(0),MC(0))
          ELSE
              CALL IMI2M(0,MD)
          ENDIF
          GO TO 150
      ENDIF

      NDIG = INT(MWA(1))
      IF (NDIG < 2) NDIG = 2

!             NGUARD is the number of guard digits used.

      NGUARD = 1
      NA1 = INT(MWA(1)) + 1
      NC1 = INT(MC(1)) + 1
      MWA(1) = MWA(1) - MC(1) + 1
      NL = NA1 + NGUARD + 3
      DO J = NA1+2, NL
         MWA(J) = 0
      ENDDO

!             Work only with positive numbers.

      MC1 = MC(1)

!             NMCWDS is the number of words of MC used to
!             compute the estimated quotient digit MQD.

      NMCWDS = 4
      IF (MBASE < 100) NMCWDS = 7

!             XB is an approximation of MC used in
!             estimating the quotient digits.

      XBASE = DBLE(MBASE)
      XB = 0
      JL = NMCWDS
      IF (JL <= NC1) THEN
          DO J = 2, JL
             XB = XB*XBASE + DBLE(MC(J))
          ENDDO
      ELSE
          DO J = 2, JL
             IF (J <= NC1) THEN
                 XB = XB*XBASE + DBLE(MC(J))
             ELSE
                 XB = XB*XBASE
             ENDIF
          ENDDO
      ENDIF
      IF (JL+1 <= NC1) XB = XB + DBLE(MC(JL+1))/XBASE
      XBR = 1.0D0/XB

!             MLMAX determines when to normalize all of MWA.

      MBM1 = MBASE - 1
      MLMAX = MAXINT/MBM1
      MKT = INTMAX - MBASE
      MLMAX = MIN(MLMAX,MKT)

!             MAXMWA is an upper bound on the size of values in MWA
!             divided by MBASE-1.  It is used to determine whether
!             normalization can be postponed.

      MAXMWA = 0

!             KPTMWA points to the next digit in the quotient.

      KPTMWA = 2

!             This is the start of the division loop.

!             XMWA is an approximation of the active part of MWA
!             used in estimating quotient digits.

  120 KL = KPTMWA + NMCWDS - 1
      IF (KL <= NL) THEN
          XMWA = ((DBLE(MWA(KPTMWA))*XBASE  &
                 + DBLE(MWA(KPTMWA+1)))*XBASE  &
                 + DBLE(MWA(KPTMWA+2)))*XBASE  &
                 + DBLE(MWA(KPTMWA+3))
          DO J = KPTMWA+4, KL
             XMWA = XMWA*XBASE + DBLE(MWA(J))
          ENDDO
      ELSE
          XMWA = DBLE(MWA(KPTMWA))
          DO J = KPTMWA+1, KL
             IF (J <= NL) THEN
                 XMWA = XMWA*XBASE + DBLE(MWA(J))
             ELSE
                 XMWA = XMWA*XBASE
             ENDIF
          ENDDO
      ENDIF

!             MQD is the estimated quotient digit.

      MQD = AINT(XMWA*XBR)
      IF (MQD < 0) MQD = MQD - 1

      IF (MQD > 0) THEN
          MAXMWA = MAXMWA + MQD
      ELSE
          MAXMWA = MAXMWA - MQD
      ENDIF

!             See if MWA must be normalized.

      KA = KPTMWA + 1
      KB = KA + INT(MC1) - 1
      IF (MAXMWA >= MLMAX) THEN
          DO J = KB, KA, -1
             IF (MWA(J) < 0) THEN
                 MCARRY = INT((-MWA(J)-1)/MBASE) + 1
                 MWA(J) = MWA(J) + MCARRY*MBASE
                 MWA(J-1) = MWA(J-1) - MCARRY
             ELSE IF (MWA(J) >= MBASE) THEN
                 MCARRY = -INT(MWA(J)/MBASE)
                 MWA(J) = MWA(J) + MCARRY*MBASE
                 MWA(J-1) = MWA(J-1) - MCARRY
             ENDIF
          ENDDO
          XMWA = 0
          IF (KL <= NL) THEN
              DO J = KPTMWA, KL
                 XMWA = XMWA*XBASE + DBLE(MWA(J))
              ENDDO
          ELSE
              DO J = KPTMWA, KL
                 IF (J <= NL) THEN
                     XMWA = XMWA*XBASE + DBLE(MWA(J))
                 ELSE
                     XMWA = XMWA*XBASE
                 ENDIF
              ENDDO
          ENDIF
          MQD = AINT(XMWA*XBR)
          IF (MQD < 0) MQD = MQD - 1
          IF (MQD > 0) THEN
              MAXMWA = MQD
          ELSE
              MAXMWA = -MQD
          ENDIF
      ENDIF

!             Subtract MQD*MC from MWA.

      JB = KA - 2
      IF (MQD /= 0) THEN

!             Major (Inner Loop)

          DO J = KA, KB
             MWA(J) = MWA(J) - MQD*MC(J-JB)
          ENDDO
      ENDIF

      MWA(KA) = MWA(KA) + MWA(KA-1)*MBASE
      MWA(KPTMWA) = MQD

      KPTMWA = KPTMWA + 1
      IF (KPTMWA-2 < MWA(1)) GO TO 120

!             Final normalization.

      KPTMWA = KPTMWA - 1
      DO J = KPTMWA, 3, -1
         IF (MWA(J) < 0) THEN
             MCARRY = INT((-MWA(J)-1)/MBASE) + 1
             MWA(J) = MWA(J) + MCARRY*MBASE
             MWA(J-1) = MWA(J-1) - MCARRY
         ELSE IF (MWA(J) >= MBASE) THEN
             MCARRY = -INT(MWA(J)/MBASE)
             MWA(J) = MWA(J) + MCARRY*MBASE
             MWA(J-1) = MWA(J-1) - MCARRY
         ENDIF
      ENDDO

  130 DO J = KPTMWA+INT(MC1), KPTMWA+2, -1
         IF (MWA(J) < 0) THEN
             MCARRY = INT((-MWA(J)-1)/MBASE) + 1
             MWA(J) = MWA(J) + MCARRY*MBASE
             MWA(J-1) = MWA(J-1) - MCARRY
         ELSE IF (MWA(J) >= MBASE) THEN
             MCARRY = -INT(MWA(J)/MBASE)
             MWA(J) = MWA(J) + MCARRY*MBASE
             MWA(J-1) = MWA(J-1) - MCARRY
         ENDIF
      ENDDO

!             Due to rounding, the remainder may not be between
!             0 and ABS(MC) here.  Correct if necessary.

      IF (MWA(KA) < 0) THEN
          DO J = KA, KB
             MWA(J) = MWA(J) + MC(J-JB)
          ENDDO
          GO TO 130
      ELSE IF (MWA(KA) >= MBASE) THEN
          DO J = KA, KB
             MWA(J) = MWA(J) - MC(J-JB)
          ENDDO
          GO TO 130
      ENDIF

      IF (MWA(KPTMWA+1) /= 0) THEN
          DO J = 1, INT(MC1)
             MD(J+1) = MWA(KPTMWA+J)
          ENDDO
          MD(1) = MC1
      ELSE
          DO J = 1, INT(MC1)
             IF (MWA(KPTMWA+J) /= 0) THEN
                 DO K = J, INT(MC1)
                    MD(K-J+2) = MWA(KPTMWA+K)
                 ENDDO
                 MD(1) = MC1 + 1 - J
                 GO TO 140
             ENDIF
          ENDDO
          MD(1) = 0
          MD(2) = 0
      ENDIF
  140 IF (MD(1) <= 1) MD(3) = 0
      MD(0) = MIN(MA(0),MB(0),MC(0))

      IF (MD(1) > M01(1) .OR.  &
         (MD(1) == M01(1) .AND. ABS(MD(2)) >= M01(2))) THEN
          MD(-1) = 1
          IF (IMCOMP(MD,'GE',M01)) THEN
              CALL IMSUB(MD,M01,M10)
              CALL IMEQ(M10,MD)
          ENDIF
      ENDIF

  150 MD(-1) = 1
      IF (MAS*MBS < 0) THEN
          IF (MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -MD(-1)
      ENDIF

      IF (NDIG > NDIGMX) NDIG = 2
  160 IF (MD(1) == MUNKNO) THEN
          KFLAG = -4
          NAMEST(NCALL) = 'IMMPYM'
          CALL FMWARN
      ENDIF

  170 IF (MD(1) <= 1) MD(3) = 0
      IF (NTRACE /= 0) CALL IMNTR(1,MD,MD,1)
      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMMPYM

      SUBROUTINE IMNTR(NTR,MA,MB,NARG)

!  Print IM numbers in base 10 format.
!  This is used for trace output from the IM routines.

!  NTR =  1 if a result of an IM call is to be printed.
!      =  2 to print input argument(s) to an IM call.

!  MA  -  the IM number to be printed.

!  MB  -  an optional second IM number to be printed.

!  NARG - the number of arguments.  NARG = 1 if only MA is to be
!         printed, and NARG = 2 if both MA and MB are to be printed.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER NARG,NDSAVE,NTR,NTRSAV
      CHARACTER(6) :: NAME

      IF (NTRACE == 0) RETURN
      IF (NCALL > LVLTRC) RETURN
      IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN

      IF (NTR == 2) THEN
          NAME = NAMEST(NCALL)
          WRITE (KW,"(' Input to ',A6)") NAME
      ELSE
          NAME = NAMEST(NCALL)
          IF (KFLAG == 0) THEN
              WRITE (KW,  &
                     "(' ',A6,15X,'Call level =',I2,5X,'MBASE =',"  //  &
                     "I10)"                                             &
                    ) NAME,NCALL,INT(MBASE)
          ELSE
              WRITE (KW,  &
                     "(' ',A6,6X,'Call level =',I2,4X,'MBASE =',"  //  &
                     "I10,4X,'KFLAG =',I3)"                            &
                    ) NAME,NCALL,INT(MBASE),KFLAG
          ENDIF
      ENDIF

      NDSAVE = NDIG
      IF (NTRACE < 0) THEN
          NDIG = MAX(2,INT(MA(1)))
          IF (NDIG > NDG2MX) NDIG = 2
          NTRSAV = NTRACE
          IF (NTRACE < -2) NTRACE = -2
          CALL IMNTRJ(MA,NDIG)
          IF (NARG == 2) THEN
              NDIG = MAX(2,INT(MB(1)))
              IF (NDIG > NDG2MX) NDIG = 2
              CALL IMNTRJ(MB,NDIG)
          ENDIF
          NTRACE = NTRSAV
      ENDIF

      IF (NTRACE > 0) THEN
          CALL IMPRNT(MA)
          IF (NARG == 2) CALL IMPRNT(MB)
      ENDIF

      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMNTR

      SUBROUTINE IMNTRI(NTR,N,KNAM)

!  Internal routine for trace output of integer variables.

!  NTR = 1 for output values
!        2 for input values

!  N     Integer to be printed.

!  KNAM  is positive if the routine name is to be printed.

      USE FMVALS
      IMPLICIT NONE

      INTEGER NTR,N,KNAM

      CHARACTER(6) :: NAME

      IF (NTRACE == 0) RETURN
      IF (NCALL > LVLTRC) RETURN
      IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN

      IF (NTR == 2 .AND. KNAM > 0) THEN
          NAME = NAMEST(NCALL)
          WRITE (KW,"(' Input to ',A6)") NAME
      ENDIF
      IF (NTR == 1 .AND. KNAM > 0) THEN
          NAME = NAMEST(NCALL)
          IF (KFLAG == 0) THEN
              WRITE (KW,"(' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10)")  &
                     NAME,NCALL,INT(MBASE)
          ELSE
              WRITE (KW,  &
                     "(' ',A6,6X,'Call level =',I2,4X,'MBASE =',"  //  &
                     "I10,4X,'KFLAG =',I3)"                            &
                    ) NAME,NCALL,INT(MBASE),KFLAG
          ENDIF
      ENDIF

      WRITE (KW,"(1X,I18)") N

      RETURN
      END SUBROUTINE IMNTRI

      SUBROUTINE IMNTRJ(MA,ND)

!  Print trace output in internal base MBASE format.  The number to
!  be printed is in MA.

!  ND is the number of base MBASE digits to be printed.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER ND

      CHARACTER(50) :: FORM
      INTEGER J,L,N,N1

      N1 = ND + 1

      L = INT(LOG10(DBLE(MBASE-1))) + 2
      N = (KSWIDE-23)/L
      IF (N > 10) N = 5*(N/5)
      IF (ND <= N) THEN
          WRITE (FORM,"(' (1X,I19,I',I2,',',I3,'I',I2,') ')") L+2, N-1, L
      ELSE
          WRITE (FORM,  &
                 "(' (1X,I19,I',I2,',',I3,'I',I2,'/(22X,',I3,'I',I2,')) ')"  &
                ) L+2, N-1, L, N, L
      ENDIF
      IF (INT(MA(1)) >= 2) THEN
          WRITE (KW,FORM) INT(MA(1)),INT(MA(-1)*MA(2)),(INT(MA(J)),J=3,N1)
      ELSE
          WRITE (KW,FORM) INT(MA(1)),INT(MA(-1)*MA(2)),(0,J=3,N1)
      ENDIF

      RETURN
      END SUBROUTINE IMNTRJ

      SUBROUTINE IMNTRR(NTR,X,KNAM)

!  Internal routine for trace output of real variables.

!  NTR - 1 for output values
!        2 for input values

!  X   - Double precision value to be printed if NX == 1

!  KNAM - Positive if the routine name is to be printed.

      USE FMVALS
      IMPLICIT NONE

      INTEGER NTR,KNAM
      DOUBLE PRECISION X

      CHARACTER(6) :: NAME

      IF (NTRACE == 0) RETURN
      IF (NCALL > LVLTRC) RETURN
      IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN

      IF (NTR == 2 .AND. KNAM > 0) THEN
          NAME = NAMEST(NCALL)
          WRITE (KW,"(' Input to ',A6)") NAME
      ENDIF
      IF (NTR == 1 .AND. KNAM > 0) THEN
          NAME = NAMEST(NCALL)
          IF (KFLAG == 0) THEN
              WRITE (KW,"(' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10)")  &
                     NAME,NCALL,INT(MBASE)
          ELSE
              WRITE (KW,  &
                     "(' ',A6,6X,'Call level =',I2,4X,'MBASE =',"  //  &
                     "I10,4X,'KFLAG =',I3)"                            &
                    ) NAME,NCALL,INT(MBASE),KFLAG
          ENDIF
      ENDIF

      WRITE (KW,"(1X,D30.20)") X

      RETURN
      END SUBROUTINE IMNTRR

      SUBROUTINE IMOUT(MA,LINE,LB)

!  Convert an integer multiple precision number to a character array
!  for output.

!  MA   is an IM number to be converted to an A1 character
!       array in base 10 format
!  LINE is the CHARACTER*1 array in which the result is returned.
!  LB   is the length of LINE.

      USE FMVALS
      IMPLICIT NONE

      INTEGER JF1SAV,JF2SAV,LB,NDSAVE
      CHARACTER LINE(LB)
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMOUT ',1,MA,MA)
      KFLAG = 0
      NDSAVE = NDIG
      NAMEST(NCALL) = 'IMOUT '

      NDSAVE = NDIG
      JF1SAV = JFORM1
      JF2SAV = JFORM2
      JFORM1 = 2
      JFORM2 = 0
      NDIG = MAX(2,INT(MA(1)))
      IF (NDIG > NDG2MX) NDIG = 2
      CALL FMOUT(MA,LINE,LB)

      NDIG = NDSAVE
      JFORM1 = JF1SAV
      JFORM2 = JF2SAV
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE IMOUT

      SUBROUTINE IMPACK(MA,MP)

!  MA is packed two base NDIG digits per word and returned in MP.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MP(-1:LPACK)

      INTEGER J,KP,KMA1

      KMA1 = INT(MA(1))
      IF (KMA1 <= 2 .OR. KMA1 > NDG2MX) KMA1 = 2
      KP = 2
      MP(0) = MA(0)
      MP(1) = MA(1)
      MP(2) = ABS(MA(2))*MBASE + MA(3)
      MP(-1) = 1
      IF (MA(-1) < 0) MP(-1) = -1
      IF (KMA1 >= 4) THEN
          DO J = 4, KMA1, 2
             KP = KP + 1
             MP(KP) = MA(J)*MBASE + MA(J+1)
          ENDDO
      ENDIF
      IF (MOD(KMA1,2) == 1) MP(KP+1) = MA(KMA1+1)*MBASE
      RETURN
      END SUBROUTINE IMPACK

      SUBROUTINE IMPMOD(MA,MB,MC,MD)

!  MD = MOD(MA**MB,MC)

!  The binary multiplication method used requires an average of
!  1.5 * LOG2(MB) operations.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK),  &
                            MD(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACCB,MBS
      INTEGER IREM,KWRNSV,NDSAVE,NTRSAV

      KFLAG = 0
      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMPMOD',2,MA,MB)
      IF (KDEBUG == 1) CALL IMARGS('IMPMOD',1,MC,MC)
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMPMOD'
          CALL IMNTR(2,MA,MB,2)
          IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
              IF (NTRACE < 0) THEN
                  NDIG = MAX(2,INT(MC(1)))
                  IF (NDIG > NDG2MX) NDIG = 2
                  NTRSAV = NTRACE
                  IF (NTRACE < -2) NTRACE = -2
                  CALL IMNTRJ(MC,NDIG)
                  NTRACE = NTRSAV
                  NDIG = NDSAVE
              ELSE
                  CALL IMPRNT(MC)
              ENDIF
          ENDIF
      ENDIF
      MBS = MB(-1)
      MACCA = MA(0)
      MACCB = MB(0)

!             Check for special cases.

      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR. MC(1) == MUNKNO .OR.  &
          MA(1) == MEXPOV .OR. MB(1) == MEXPOV .OR. MC(1) == MEXPOV .OR.  &
          MA(1) < 0 .OR. MB(1) < 0 .OR. MC(1) < 0 .OR.  &
          (MB(-1)*MB(2) <= 0 .AND. MA(2) == 0) .OR. MC(2) == 0) THEN
          KFLAG = -4
          IF (MA(1) /= MUNKNO .AND. MB(1) /= MUNKNO .AND. MC(1) /= MUNKNO) THEN
              NAMEST(NCALL) = 'IMPMOD'
              CALL FMWARN
          ENDIF
          CALL IMST2M('UNKNOWN',MD)
          IF (NTRACE /= 0) CALL IMNTR(1,MD,MD,1)
          NDIG = NDSAVE
          NCALL = NCALL - 1
          RETURN
      ENDIF

      IF (MB(2) == 0) THEN
          CALL IMI2M(1,MD)
          IF (NTRACE /= 0) CALL IMNTR(1,MD,MD,1)
          NDIG = NDSAVE
          NCALL = NCALL - 1
          RETURN
      ENDIF

      IF (MB(1) == 1 .AND. ABS(MB(2)) == 1) THEN
          KWRNSV = KWARN
          KWARN = 0
          IF (MB(-1) == 1) THEN
              CALL IMMOD(MA,MC,MD)
          ELSE
              CALL IMI2M(1,M05)
              CALL IMDIVR(M05,MA,M04,M06)
              CALL IMMOD(M04,MC,MD)
          ENDIF
          IF (NTRACE /= 0) CALL IMNTR(1,MD,MD,1)
          NDIG = NDSAVE
          NCALL = NCALL - 1
          KWARN = KWRNSV
          RETURN
      ENDIF

      IF (MA(2) == 0) THEN
          CALL IMI2M(0,MD)
          IF (NTRACE /= 0) CALL IMNTR(1,MD,MD,1)
          NDIG = NDSAVE
          NCALL = NCALL - 1
          RETURN
      ENDIF

!             Initialize.

      KWRNSV = KWARN
      KWARN = 0
      CALL IMABS(MB,M06)
      CALL IMDIVR(MA,MC,M04,M05)
      CALL IMEQ(MC,M04)
      CALL IMDVIR(M06,2,MD,IREM)
      IF (IREM == 0) THEN
          CALL IMI2M(1,MD)
      ELSE
          CALL IMEQ(M05,MD)
      ENDIF
      CALL IMDVIR(M06,2,M11,IREM)
      CALL IMEQ(M11,M06)

!             This is the multiplication loop.

  110 CALL IMDVIR(M06,2,M11,IREM)
      CALL IMEQ(M11,M06)
      CALL IMMPYM(M05,M05,M04,M13)
      CALL IMEQ(M13,M05)
      IF (IREM == 1) THEN
          CALL IMMPYM(M05,MD,M04,M13)
          CALL IMEQ(M13,MD)
      ENDIF
      IF (M06(2) > 0 .AND. MD(2) /= 0) GO TO 110

      IF (MBS < 0) THEN
          CALL IMI2M(1,M05)
          CALL IMDIVR(M05,MD,M11,M06)
          CALL IMEQ(M11,MD)
      ENDIF
      KWARN = KWRNSV
      MD(0) = MIN(MACCA,MACCB)
      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'IMPMOD'
          CALL FMWARN
      ENDIF
      IF (MD(1) <= 1) MD(3) = 0
      IF (NTRACE /= 0) CALL IMNTR(1,MD,MD,1)
      NDIG = NDSAVE
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE IMPMOD

      SUBROUTINE IMPRNT(MA)

!  Print MA in base 10 format.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      INTEGER JF1SAV,JF2SAV,NDSAVE

      NDSAVE = NDIG
      JF1SAV = JFORM1
      JF2SAV = JFORM2
      JFORM1 = 2
      JFORM2 = 0
      NDIG = MAX(2,INT(MA(1)))
      IF (NDIG > NDG2MX) NDIG = 2
      CALL FMPRNT(MA)
      JFORM1 = JF1SAV
      JFORM2 = JF2SAV
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMPRNT

      SUBROUTINE IMPWR(MA,MB,MC)

!  MC = MA ** MB

!  The binary multiplication method used requires an average of
!  1.5 * LOG2(MB) multiplications.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS
      INTEGER IREM,IREMB,JSIGN,KWRNSV

      KFLAG = 0
      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMPWR ',2,MA,MB)
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMPWR '
          CALL IMNTR(2,MA,MB,2)
      ENDIF
      MAS = MA(-1)
      MBS = MB(-1)
      MACCA = MA(0)
      MACCB = MB(0)
      KWRNSV = KWARN

!             Check for special cases.

      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR. MA(1) < 0 .OR.  &
          MB(1) < 0 .OR. ((MB(-1) < 0 .OR. MB(2) == 0) .AND. MA(2) == 0)) THEN
          KFLAG = -4
          IF (MA(1) /= MUNKNO .AND. MB(1) /= MUNKNO) THEN
              KWARN = KWRNSV
              NAMEST(NCALL) = 'IMPWR '
              CALL FMWARN
          ENDIF
          CALL IMST2M('UNKNOWN',MC)
          GO TO 130
      ENDIF

      IF (MB(2) == 0) THEN
          CALL IMI2M(1,MC)
          GO TO 130
      ENDIF

      IF (MA(1) == 1 .AND. MA(2) == 1) THEN
          KWARN = 0
          IF (MAS == 1) THEN
              CALL IMI2M(1,MC)
          ELSE
              CALL IMI2M(2,M05)
              CALL IMDIVR(MB,M05,M11,M06)
              CALL IMEQ(M11,M05)
              IF (M06(1) == MUNKNO) THEN
                  KFLAG = -4
                  KWARN = KWRNSV
                  NAMEST(NCALL) = 'IMPWR '
                  CALL FMWARN
                  CALL IMST2M('UNKNOWN',MC)
              ELSE IF (M06(2) == 0) THEN
                  CALL IMI2M(1,MC)
              ELSE
                  CALL IMI2M(-1,MC)
              ENDIF
          ENDIF
          GO TO 130
      ENDIF

      IF (MB(1) == 1 .AND. MB(2) == 1) THEN
          KWARN = 0
          IF (MBS == 1) THEN
              CALL IMEQ(MA,MC)
          ELSE
              CALL IMI2M(1,M05)
              CALL IMDIVR(M05,MA,MC,M06)
          ENDIF
          GO TO 130
      ENDIF

      IF (MA(2) == 0) THEN
          CALL IMI2M(0,MC)
          GO TO 130
      ENDIF

      IF (MB(1) == MEXPOV) THEN
          IF (MBS < 0) THEN
              CALL IMI2M(0,MC)
          ELSE IF (MAS > 0) THEN
              CALL IMST2M('OVERFLOW',MC)
              KFLAG = -5
          ELSE
              KFLAG = -4
              KWARN = KWRNSV
              NAMEST(NCALL) = 'IMPWR '
              CALL FMWARN
              CALL IMST2M('UNKNOWN',MC)
          ENDIF
          GO TO 130
      ENDIF

      IF (MA(1) == MEXPOV) THEN
          JSIGN = 1
          IF (MA(-1) < 0) JSIGN = -1
          IF (MBS > 0) THEN
              CALL IMDVIR(MB,2,MC,IREM)
              CALL IMST2M('OVERFLOW',MC)
              MC(-1) = JSIGN**IREM
              KFLAG = -5
          ELSE
              CALL IMI2M(0,MC)
          ENDIF
          GO TO 130
      ENDIF

!             Initialize.

      KWARN = 0
      CALL IMABS(MB,M06)

      CALL IMEQ(MA,M05)

      CALL IMDVIR(MB,2,MC,IREMB)
      IF (IREMB == 0) THEN
          CALL IMI2M(1,MC)
      ELSE
          CALL IMEQ(M05,MC)
      ENDIF
      CALL IMDVIR(M06,2,M11,IREM)
      CALL IMEQ(M11,M06)

!             This is the multiplication loop.

  110 CALL IMDVIR(M06,2,M11,IREM)
      CALL IMEQ(M11,M06)
      CALL IMSQR(M05,M12)
      CALL IMEQ(M12,M05)
      IF (IREM == 1) THEN
          CALL IMMPY(M05,MC,M10)
          CALL IMEQ(M10,MC)
      ENDIF
      IF (M05(1) == MEXPOV) THEN
          CALL IMEQ(M05,MC)
          IF (MAS < 0 .AND. IREMB == 1) MC(-1) = -1
          GO TO 120
      ENDIF
      IF (M06(2) > 0) GO TO 110

  120 IF (MBS < 0) THEN
          CALL IMI2M(1,M05)
          CALL IMDIVR(M05,MC,M11,M06)
          CALL IMEQ(M11,MC)
      ENDIF

      MC(0) = MIN(MACCA,MACCB)
      IF (MC(1) > NDIGMX) THEN
          IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN
              IF (MC(-1) > 0) THEN
                  CALL IMST2M('OVERFLOW',MC)
              ELSE
                  CALL IMST2M('-OVERFLOW',MC)
              ENDIF
              KFLAG = -5
              KWARN = KWRNSV
              NAMEST(NCALL) = 'IMPWR '
              CALL FMWARN
          ENDIF
      ENDIF

  130 IF (MC(1) <= 1) MC(3) = 0
      KWARN = KWRNSV
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMPWR '
          CALL IMNTR(1,MC,MC,1)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE IMPWR

      SUBROUTINE IMREAD(KREAD,MA)

!  Read MA on unit KREAD.  Multi-line numbers will have '&' as the
!  last nonblank character on all but the last line.  Only one
!  number is allowed on the line(s).
      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER KREAD

      INTEGER NDSAVE,KWRNSV

      NCALL = NCALL + 1
      NDSAVE = NDIG
      NDIG = NDIGMX
      CALL FMREAD(KREAD,M02)
      KWRNSV = KWARN
      KWARN = 0
      CALL FMNINT(M02,MA)
      IF (MA(1) <= 1) MA(3) = 0
      KWARN = KWRNSV
      NDIG = NDSAVE
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE IMREAD

      SUBROUTINE IMSIGN(MA,MB,MC)

!  MC = SIGN(MA,MB)

!  MC is set to ABS(MA) if MB is positive or zero,
!     or -ABS(MA) if MB is negative.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      INTEGER KWRNSV,NDSAVE

      KFLAG = 0
      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMSIGN',2,MA,MB)
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMSIGN'
          CALL IMNTR(2,MA,MB,2)
      ENDIF

      NDIG = INT(MA(1))
      IF (NDIG < 2) NDIG = 2
      IF (NDIG > NDG2MX) NDIG = 2
      KWRNSV = KWARN
      KWARN = 0
      IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
          CALL IMST2M('UNKNOWN',MC)
          KFLAG = -4
      ELSE IF (MA(1) < 0 .OR. MB(1) < 0) THEN
          KFLAG = -4
          NAMEST(NCALL) = 'IMSIGN'
          CALL FMWARN
          CALL IMST2M('UNKNOWN',MC)
      ELSE IF (MB(-1) >= 0) THEN
          CALL IMEQ(MA,MC)
          MC(-1) = 1
      ELSE
          CALL IMEQ(MA,MC)
          IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1
      ENDIF

      IF (MC(1) <= 1) MC(3) = 0
      KWARN = KWRNSV
      IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMSIGN

      SUBROUTINE IMSQR(MA,MB)

!  MB = MA * MA

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MDAB
      INTEGER KOVFL,NDSAVE

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMSQR ',1,MA,MA)
      KFLAG = 0
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMSQR '
          CALL IMNTR(2,MA,MA,1)
      ENDIF

      IF (MA(1) <= 1) THEN
          IF (MA(1) < 0) GO TO 110
          MDAB = MA(2) * MA(2)
          IF (ABS(MDAB) < MBASE) THEN
              MB(0) = MA(0)
              MB(1) = 1
              IF (MDAB == 0) MB(1) = 0
              MB(2) = MDAB
              MB(3) = 0
              GO TO 120
          ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
              MB(0) = MA(0)
              MB(1) = 2
              MB(2) = AINT (MDAB/MBASE)
              MB(3) = MDAB - MBASE*MB(2)
              GO TO 120
          ENDIF
      ENDIF

!             Check for special cases.

  110 KOVFL = 0
      IF (MA(1) == MUNKNO) THEN
          KFLAG = -4
          CALL IMST2M('UNKNOWN',MB)
          GO TO 130
      ENDIF
      IF (MA(2) == 0) THEN
          MB(-1) = 1
          MB(0) = NINT(NDG2MX*ALOGM2)
          MB(1) = 0
          MB(2) = 0
          MB(3) = 0
          GO TO 130
      ENDIF
      IF (MA(1) == MEXPOV) THEN
          KOVFL = 1
          KFLAG = -5
          CALL IMST2M('OVERFLOW',MB)
          GO TO 130
      ENDIF
      IF (MA(1) == 1 .AND. ABS(MA(2)) == 1) THEN
          CALL IMI2M(1,MB)
          GO TO 120
      ELSE IF (MA(1) < 0) THEN
          KFLAG = -4
          NAMEST(NCALL) = 'IMSQR '
          CALL FMWARN
          CALL IMST2M('UNKNOWN',MB)
          GO TO 130
      ENDIF

      NDIG = INT(MA(1) + MA(1))
      IF (NDIG > NDIGMX) THEN
          IF (NCALL == 1 .OR. NDIG > NDG2MX) THEN
              CALL IMST2M('OVERFLOW',MB)
              KFLAG = -5
              NAMEST(NCALL) = 'IMSQR '
              CALL FMWARN
              GO TO 130
          ENDIF
      ENDIF

      IF (NDIG < 2) NDIG = 2
      IF (NDIG > NDG2MX) NDIG = NDG2MX

      CALL IMSQR2(MA,MB)

      IF (NDIG > NDIGMX) NDIG = 2
  120 IF (MB(1) > NDIGMX) THEN
          IF (NCALL == 1 .OR. MB(1) > NDG2MX) THEN
              IF (MB(-1) > 0) THEN
                  CALL IMST2M('OVERFLOW',MB)
              ELSE
                  CALL IMST2M('-OVERFLOW',MB)
              ENDIF
              KFLAG = -5
              NAMEST(NCALL) = 'IMSQR '
              IF (KOVFL /= 1) CALL FMWARN
          ENDIF
      ENDIF

  130 IF (MB(1) <= 1) MB(3) = 0
      MB(-1) = 1
      IF (NTRACE /= 0) CALL IMNTR(1,MB,MB,1)
      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMSQR

      SUBROUTINE IMSQR2(MA,MB)

!  MB = MA*MA.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MAXMAX,MAXMWA,MBJ,MBKJ,MBM1,  &
                            MBNORM,MK,MKA,MKT,MMAX,MT
      INTEGER J,JM1,K,KB,KI,KJ,KL,KNZ,KOVUN,KWA,  &
              L,N1

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > NDG2MX/2 .OR. KDEBUG == 1 .OR.  &
          MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          IF (MA(1) == MUNKNO) KOVUN = 2
          NCALL = NCALL + 1
          CALL IMMPY(MA,MA,MB)
          NCALL = NCALL - 1
          IF ((KFLAG < 0 .AND. KOVUN == 0) .OR.  &
              (KFLAG == -4 .AND. KOVUN == 1)) THEN
              NAMEST(NCALL) = 'IMSQR '
              CALL FMWARN
          ENDIF
          GO TO 120
      ELSE IF (MA(2) == 0) THEN
          CALL IMEQ(MA,MB)
          GO TO 120
      ENDIF
      KFLAG = 0
      MAXMAX = 0

      N1 = INT(MA(1)) + 1
      MWA(1) = MA(1) + MA(1)

      L = N1 + INT(MA(1))
      MWA(L+1) = 0

!             The multiplication loop begins here.

!             MBNORM is the minimum number of digits that can be
!                    multiplied before normalization is required.
!             MAXMWA is an upper bound on the size of values in MWA
!                    divided by (MBASE-1).  It is used to determine
!                    whether to normalize before the next digit is
!                    multiplied.

      MBM1 = MBASE - 1
      MBNORM = AINT (MAXINT/(MBM1*MBM1))
      MMAX = INTMAX - MBASE
      MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX)
      IF (MBNORM > 1) THEN
          MBJ = MA(2)

!             Count the trailing zeros in MA.

          IF (MA(N1) /= 0) THEN
              KNZ = N1
          ELSE
              DO J = INT(MA(1)), 2, -1
                 IF (MA(J) /= 0) THEN
                     KNZ = J
                     GO TO 110
                 ENDIF
              ENDDO
          ENDIF

  110     MWA(2) = 0
          MWA(3) = 0
          DO K = N1+1, L
             MWA(K) = 0
          ENDDO

!             (Inner Loop)

          DO K = 3, N1
             MWA(K+1) = MA(K)*MBJ
          ENDDO
          MAXMWA = MBJ
          DO J = 3, N1
             MBJ = MA(J)
             IF (MBJ /= 0) THEN
                 MAXMWA = MAXMWA + MBJ
                 JM1 = J - 1
                 KL = MIN(KNZ,L-JM1)

!                       Major (Inner Loop)

                 DO K = 2*J, JM1+KL
                    MWA(K) = MWA(K) + MA(K-JM1)*MBJ
                 ENDDO
             ENDIF

             IF (MAXMWA > MMAX) THEN
                 MAXMAX = MAX(MAXMAX,MAXMWA)
                 MAXMWA = 0

!                       Normalization is only required for the
!                       range of digits currently changing in MWA.

                 DO KB = JM1+KL, 2*J, -1
                    MKT = INT (MWA(KB)/MBASE)
                    MWA(KB-1) = MWA(KB-1) + MKT
                    MWA(KB) = MWA(KB) - MKT*MBASE
                 ENDDO
             ENDIF
          ENDDO

!             Double MWA, add the square terms, and perform
!             the final normalization.  (Inner Loop)

          IF (2*MAX(MAXMAX,MAXMWA)+MBASE > MMAX) THEN
              DO KB = L, 4, -1
                 MKT = INT (MWA(KB)/MBASE)
                 MWA(KB-1) = MWA(KB-1) + MKT
                 MWA(KB) = MWA(KB) - MKT*MBASE
              ENDDO
          ENDIF

          DO J = 3, L-1, 2
             IF ((J+1)/2 <= N1) THEN
                 MKA = MA((J+1)/2)
                 MWA(J) = 2*MWA(J) + MKA*MKA
                 MWA(J+1) = 2*MWA(J+1)
             ELSE
                 MWA(J) = 2*MWA(J)
                 MWA(J+1) = 2*MWA(J+1)
             ENDIF
          ENDDO
          IF (MOD(L,2) == 1) THEN
              IF ((L+1)/2 <= N1) THEN
                  MKA = MA((L+1)/2)
                  MWA(L) = 2*MWA(L) + MKA*MKA
              ELSE
                  MWA(L) = 2*MWA(L)
              ENDIF
          ENDIF

          DO KB = L, 3, -1
             MKT = INT (MWA(KB)/MBASE)
             MWA(KB-1) = MWA(KB-1) + MKT
             MWA(KB) = MWA(KB) - MKT*MBASE
          ENDDO

      ELSE

!             If normalization must be done for each digit, combine
!             the two loops and normalize as the digits are multiplied.

          DO J = 2, L
             MWA(J) = 0
          ENDDO
          KJ = NDIG + 2
          DO J = 2, N1
             KJ = KJ - 1
             MBKJ = MA(KJ)
             IF (MBKJ == 0) CYCLE
             KL = L - KJ + 1
             IF (KL > N1) KL = N1
             KI = KL + 2
             KWA = KL+ KJ + 1
             MK = 0
             DO K = 2, KL
                MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MK
                MK = INT (MT/MBASE)
                MWA(KWA-K) = MT - MBASE*MK
             ENDDO
             MWA(KWA-KL-1) = MK
          ENDDO

      ENDIF

!             The multiplication is complete.

      NDIG = MWA(1)
      IF (NDIG < 2) NDIG = 2
      IF (NDIG > NDG2MX) NDIG = NDG2MX
      CALL FMMOVE(MWA,MB)
      MB(0) = NINT(NDIGMX*ALOGM2)

      IF (KFLAG < 0) THEN
          NAMEST(NCALL) = 'IMSQR '
          CALL FMWARN
      ENDIF

  120 MB(-1) = 1
      RETURN
      END SUBROUTINE IMSQR2

      SUBROUTINE IMST2M(STRING,MA)

!  MA = STRING

!  Convert a character string to IM format.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(*) :: STRING
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      INTEGER J,LB,KFSAVE

      IF (MBLOGS /= MBASE) CALL FMCONS
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'IMST2M'
      LB = MIN(LEN(STRING),LMBUFF)
      KFSAVE = KFLAG

      DO J = 1, LB
         CMBUFF(J) = STRING(J:J)
      ENDDO

      CALL IMINP(CMBUFF,MA,1,LB)

      IF (MA(1) <= 1) MA(3) = 0
      IF (KFSAVE /= 0) KFLAG = KFSAVE
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE IMST2M

      SUBROUTINE IMSUB(MA,MB,MC)

!  MC = MA - MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)

      REAL (KIND(1.0D0)) :: MDA,MDAB,MDB
      INTEGER NDSAVE

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMSUB ',2,MA,MB)
      KFLAG = 0
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          NAMEST(NCALL) = 'IMSUB '
          CALL IMNTR(2,MA,MB,2)
      ENDIF

      IF (MA(1) <= 2) THEN
          IF (MB(1) > 2 .OR. MA(1) < 0 .OR. MB(1) < 0) GO TO 110
          IF (MA(1) <= 1) THEN
              MDA = MA(-1) * MA(2)
          ELSE
              MDA = MA(-1) * (MA(2)*MBASE + MA(3))
          ENDIF
          IF (MB(1) <= 1) THEN
              MDB = MB(-1) * MB(2)
          ELSE
              MDB = MB(-1) * (MB(2)*MBASE + MB(3))
          ENDIF
          MDAB = MDA - MDB
          IF (ABS(MDAB) < MBASE) THEN
              MC(0) = MIN(MA(0),MB(0))
              MC(1) = 1
              IF (MDAB == 0) MC(1) = 0
              MC(-1) = 1
              IF (MDAB < 0) MC(-1) = -1
              MC(2) = ABS(MDAB)
              MC(3) = 0
              IF (MDA == 0 .OR. MDB == 0) KFLAG = 1
              GO TO 120
          ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
              MC(0) = MIN(MA(0),MB(0))
              MC(1) = 2
              MC(-1) = 1
              IF (MDAB < 0) MC(-1) = -1
              MDAB = ABS(MDAB)
              MC(2) = AINT (MDAB/MBASE)
              MC(3) = MDAB - MBASE*MC(2)
              IF (MDA == 0 .OR. MDB == 0) KFLAG = 1
              GO TO 120
          ENDIF
      ENDIF

!             Check for special cases.

  110 IF (MA(1) > NDG2MX .OR. MB(1) > NDG2MX .OR.  &
          MA(1) < 0 .OR. MB(1) < 0) THEN
          IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
              CALL IMST2M('UNKNOWN',MC)
              KFLAG = -4
              GO TO 130
          ENDIF
          IF (MA(1) == MEXPOV) THEN
              IF (MA(-1) == -MB(-1) .OR. MB(2) == 0) THEN
                  MC(-1) = MA(-1)
                  MC(0) = MA(0)
                  MC(1) = MA(1)
                  MC(2) = MA(2)
                  MC(3) = MA(3)
                  KFLAG = -5
                  GO TO 130
              ELSE
                  KFLAG = -4
                  NAMEST(NCALL) = 'IMSUB '
                  CALL FMWARN
                  CALL IMST2M('UNKNOWN',MC)
                  GO TO 130
              ENDIF
          ENDIF
          IF (MB(1) == MEXPOV) THEN
              IF (-MB(-1) == MA(-1) .OR. MA(2) == 0) THEN
                  MC(-1) = -MB(-1)
                  MC(0) = MB(0)
                  MC(1) = MB(1)
                  MC(2) = MB(2)
                  MC(3) = MB(3)
                  KFLAG = -5
                  GO TO 130
              ELSE
                  KFLAG = -4
                  NAMEST(NCALL) = 'IMSUB '
                  CALL FMWARN
                  CALL IMST2M('UNKNOWN',MC)
                  GO TO 130
              ENDIF
          ENDIF
          KFLAG = -4
          NAMEST(NCALL) = 'IMSUB '
          CALL FMWARN
          CALL IMST2M('UNKNOWN',MC)
          GO TO 130
      ENDIF

!             IMADD2 will negate MB and add.

      KSUB = 1
      CALL IMADD2(MA,MB,MC)
      KSUB = 0

  120 IF (MC(1) > NDIGMX) THEN
          IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN
              IF (MC(-1) > 0) THEN
                  CALL IMST2M('OVERFLOW',MC)
              ELSE
                  CALL IMST2M('-OVERFLOW',MC)
              ENDIF
              KFLAG = -5
              NAMEST(NCALL) = 'IMSUB '
              CALL FMWARN
          ENDIF
      ENDIF

  130 IF (MC(1) <= 1) MC(3) = 0
      IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
      NCALL = NCALL - 1
      NDIG = NDSAVE
      RETURN
      END SUBROUTINE IMSUB

      SUBROUTINE IMUNPK(MP,MA)

!  MP is unpacked and the value returned in MA.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MP(-1:LPACK)

      INTEGER J,KP,KMA1

      KMA1 = INT(MP(1))
      IF (KMA1 <= 2 .OR. KMA1 > NDG2MX) KMA1 = 2
      KP = 2
      MA(0) = MP(0)
      MA(1) = MP(1)
      MA(2) = AINT (ABS(MP(2))/MBASE)
      MA(3) = ABS(MP(2)) - MA(2)*MBASE
      MA(-1) = 1
      IF (MP(-1) < 0) MA(-1) = -1
      IF (KMA1 >= 4) THEN
          DO J = 4, KMA1, 2
             KP = KP + 1
             MA(J) = AINT (MP(KP)/MBASE)
             MA(J+1) = MP(KP) - MA(J)*MBASE
          ENDDO
      ENDIF
      IF (MOD(KMA1,2) == 1) MA(KMA1+1) = AINT (MP(KP+1)/MBASE)
      RETURN
      END SUBROUTINE IMUNPK

      SUBROUTINE IMWRIT(KWRITE,MA)

!  Write MA on unit KWRITE.  Multi-line numbers will have '&' as the
!  last nonblank character on all but the last line.  These numbers can
!  then be read easily using IMREAD.

      USE FMVALS
      IMPLICIT NONE

      INTEGER KWRITE
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      INTEGER J,K,KSAVE,L,LAST,LB,ND,NDSAVE,NEXP

      NCALL = NCALL + 1
      IF (KDEBUG == 1) CALL IMARGS('IMWRIT',1,MA,MA)
      NAMEST(NCALL) = 'IMWRIT'
      NDSAVE = NDIG
      NDIG = MAX(2,INT(MA(1)))
      IF (NDIG > NDG2MX) NDIG = 2

      KSAVE = KFLAG
      ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
      IF (ND < 2) ND = 2
      NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
      LB = MIN(ND+NEXP,LMBUFF)

      CALL IMOUT(MA,CMBUFF,LB)

      KFLAG = KSAVE
      NDIG = NDSAVE
      LAST = LB + 1
      DO J = 1, LB
         IF (CMBUFF(LAST-J) /= ' ' .OR. J == LB) THEN
             L = LAST - J
             IF (MOD(L,73) /= 0) THEN
                 WRITE (KWRITE,"(4X,73A1,' &')") (CMBUFF(K),K=1,L)
             ELSE
                 IF (L > 73) WRITE (KWRITE,"(4X,73A1,' &')")  &
                                    (CMBUFF(K),K=1,L-73)
                 WRITE (KWRITE,"(4X,73A1)") (CMBUFF(K),K=L-72,L)
             ENDIF
             NCALL = NCALL - 1
             RETURN
         ENDIF
      ENDDO
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE IMWRIT

!  These versions of the IM routines use packed IM numbers.


      SUBROUTINE IPABS(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMABS(MPA,MPB)
      CALL IMPACK(MPB,MB)
      RETURN
      END SUBROUTINE IPABS

      SUBROUTINE IPADD(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMUNPK(MB,MPB)
      CALL IMADD(MPA,MPB,MPC)
      CALL IMPACK(MPC,MC)
      RETURN
      END SUBROUTINE IPADD

      SUBROUTINE IPBIG(MA)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL IMBIG(MPB)
      CALL IMPACK(MPB,MA)
      RETURN
      END SUBROUTINE IPBIG

      FUNCTION IPCOMP(MA,LREL,MB)
      USE FMVALS
      IMPLICIT NONE
      LOGICAL IPCOMP,IMCOMP
      CHARACTER(*) :: LREL
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMUNPK(MB,MPB)
      IPCOMP = IMCOMP(MPA,LREL,MPB)
      RETURN
      END FUNCTION IPCOMP

      SUBROUTINE IPDIM(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMUNPK(MB,MPB)
      CALL IMDIM(MPA,MPB,MPC)
      CALL IMPACK(MPC,MC)
      RETURN
      END SUBROUTINE IPDIM

      SUBROUTINE IPDIV(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMUNPK(MB,MPB)
      CALL IMDIV(MPA,MPB,MPC)
      CALL IMPACK(MPC,MC)
      RETURN
      END SUBROUTINE IPDIV

      SUBROUTINE IPDIVI(MA,IVAL,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      INTEGER IVAL
      CALL IMUNPK(MA,MPA)
      CALL IMDIVI(MPA,IVAL,MPB)
      CALL IMPACK(MPB,MB)
      RETURN
      END SUBROUTINE IPDIVI

      SUBROUTINE IPDIVR(MA,MB,MC,MD)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK),  &
                            MD(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMUNPK(MB,MPB)
      CALL IMDIVR(MPA,MPB,MPC,MPD)
      CALL IMPACK(MPC,MC)
      CALL IMPACK(MPD,MD)
      RETURN
      END SUBROUTINE IPDIVR

      SUBROUTINE IPDVIR(MA,IVAL,MB,IREM)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      INTEGER IVAL,IREM
      CALL IMUNPK(MA,MPA)
      CALL IMDVIR(MPA,IVAL,MPB,IREM)
      CALL IMPACK(MPB,MB)
      RETURN
      END SUBROUTINE IPDVIR

      SUBROUTINE IPEQ(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMEQ(MPA,MPB)
      CALL IMPACK(MPB,MB)
      RETURN
      END SUBROUTINE IPEQ

      SUBROUTINE IPFM2I(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL IMFM2I(MPA,MPB)
      CALL IMPACK(MPB,MB)
      RETURN
      END SUBROUTINE IPFM2I

      SUBROUTINE IPFORM(FORM,MA,STRING)
      USE FMVALS
      IMPLICIT NONE
      CHARACTER(*) :: FORM,STRING
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMFORM(FORM,MPA,STRING)
      RETURN
      END SUBROUTINE IPFORM

      SUBROUTINE IPFPRT(FORM,MA)
      USE FMVALS
      IMPLICIT NONE
      CHARACTER(*) :: FORM
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMFPRT(FORM,MPA)
      RETURN
      END SUBROUTINE IPFPRT

      SUBROUTINE IPGCD(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMUNPK(MB,MPB)
      CALL IMGCD(MPA,MPB,MPC)
      CALL IMPACK(MPC,MC)
      RETURN
      END SUBROUTINE IPGCD

      SUBROUTINE IPI2FM(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMI2FM(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE IPI2FM

      SUBROUTINE IPI2M(IVAL,MA)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      INTEGER IVAL
      CALL IMI2M(IVAL,MPA)
      CALL IMPACK(MPA,MA)
      RETURN
      END SUBROUTINE IPI2M

      SUBROUTINE IPINP(LINE,MA,LA,LB)
      USE FMVALS
      IMPLICIT NONE
      INTEGER LA,LB
      CHARACTER LINE(LB)
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL IMINP(LINE,MPA,LA,LB)
      CALL IMPACK(MPA,MA)
      RETURN
      END SUBROUTINE IPINP

      SUBROUTINE IPM2DP(MA,DVAL)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      DOUBLE PRECISION DVAL
      CALL IMUNPK(MA,MPA)
      CALL IMM2DP(MPA,DVAL)
      RETURN
      END SUBROUTINE IPM2DP

      SUBROUTINE IPM2I(MA,IVAL)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      INTEGER IVAL
      CALL IMUNPK(MA,MPA)
      CALL IMM2I(MPA,IVAL)
      RETURN
      END SUBROUTINE IPM2I

      SUBROUTINE IPMAX(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMUNPK(MB,MPB)
      CALL IMMAX(MPA,MPB,MPC)
      CALL IMPACK(MPC,MC)
      RETURN
      END SUBROUTINE IPMAX

      SUBROUTINE IPMIN(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMUNPK(MB,MPB)
      CALL IMMIN(MPA,MPB,MPC)
      CALL IMPACK(MPC,MC)
      RETURN
      END SUBROUTINE IPMIN

      SUBROUTINE IPMOD(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMUNPK(MB,MPB)
      CALL IMMOD(MPA,MPB,MPC)
      CALL IMPACK(MPC,MC)
      RETURN
      END SUBROUTINE IPMOD

      SUBROUTINE IPMPY(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMUNPK(MB,MPB)
      CALL IMMPY(MPA,MPB,MPC)
      CALL IMPACK(MPC,MC)
      RETURN
      END SUBROUTINE IPMPY

      SUBROUTINE IPMPYI(MA,IVAL,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      INTEGER IVAL
      CALL IMUNPK(MA,MPA)
      CALL IMMPYI(MPA,IVAL,MPB)
      CALL IMPACK(MPB,MB)
      RETURN
      END SUBROUTINE IPMPYI

      SUBROUTINE IPMPYM(MA,MB,MC,MD)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK),  &
                            MD(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMUNPK(MB,MPB)
      CALL IMUNPK(MC,MPC)
      CALL IMMPYM(MPA,MPB,MPC,MPD)
      CALL IMPACK(MPD,MD)
      RETURN
      END SUBROUTINE IPMPYM

      SUBROUTINE IPOUT(MA,LINE,LB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      INTEGER LB
      CHARACTER LINE(LB)
      CALL IMUNPK(MA,MPA)
      CALL IMOUT(MPA,LINE,LB)
      RETURN
      END SUBROUTINE IPOUT

      SUBROUTINE IPPMOD(MA,MB,MC,MD)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK),  &
                            MD(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMUNPK(MB,MPB)
      CALL IMUNPK(MC,MPC)
      CALL IMPMOD(MPA,MPB,MPC,MPD)
      CALL IMPACK(MPD,MD)
      RETURN
      END SUBROUTINE IPPMOD

      SUBROUTINE IPPRNT(MA)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMPRNT(MPA)
      RETURN
      END SUBROUTINE IPPRNT

      SUBROUTINE IPPWR(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMUNPK(MB,MPB)
      CALL IMPWR(MPA,MPB,MPC)
      CALL IMPACK(MPC,MC)
      RETURN
      END SUBROUTINE IPPWR

      SUBROUTINE IPREAD(KREAD,MA)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      INTEGER KREAD
      CALL IMREAD(KREAD,MPA)
      CALL IMPACK(MPA,MA)
      RETURN
      END SUBROUTINE IPREAD

      SUBROUTINE IPSIGN(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMUNPK(MB,MPB)
      CALL IMSIGN(MPA,MPB,MPC)
      CALL IMPACK(MPC,MC)
      RETURN
      END SUBROUTINE IPSIGN

      SUBROUTINE IPSQR(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMSQR(MPA,MPB)
      CALL IMPACK(MPB,MB)
      RETURN
      END SUBROUTINE IPSQR

      SUBROUTINE IPST2M(STRING,MA)
      USE FMVALS
      IMPLICIT NONE
      CHARACTER(*) :: STRING
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL IMST2M(STRING,MPA)
      CALL IMPACK(MPA,MA)
      RETURN
      END SUBROUTINE IPST2M

      SUBROUTINE IPSUB(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMUNPK(MB,MPB)
      CALL IMSUB(MPA,MPB,MPC)
      CALL IMPACK(MPC,MC)
      RETURN
      END SUBROUTINE IPSUB

      SUBROUTINE IPWRIT(KWRITE,MA)
      USE FMVALS
      IMPLICIT NONE
      INTEGER KWRITE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL IMUNPK(MA,MPA)
      CALL IMWRIT(KWRITE,MPA)
      RETURN
      END SUBROUTINE IPWRIT

!  The ZM routines perform complex multiple-precision arithmetic.


      SUBROUTINE ZMSET(NPREC)

!  Set precision to at least NPREC significant digits for using
!  ZM arithmetic.

      USE FMVALS
      IMPLICIT NONE

      INTEGER NPREC

!             Set JFORMZ to ' 1.23 + 4.56 i ' format.

      JFORMZ = 1

!             Set JPRNTZ to print real and imaginary parts on one
!             line whenever possible.

      JPRNTZ = 1

!             Use FMSET to initialize the other variables.

      CALL FMSET(NPREC)

      RETURN
      END SUBROUTINE ZMSET

      SUBROUTINE ZMABS(MA,MBFM)

!  MBFM = ABS(MA)

!  Complex absolute value.  The result is a real FM number.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MBFM(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXEXP1,MXSAVE
      INTEGER KASAVE,KOVUN,KRESLT,NDSAVE,NTRSAV

      NTRSAV = NTRACE
      IF (NTRACE /= 0) THEN
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'ZMABS '
          CALL ZMNTR(2,MA,MA,1)
          NCALL = NCALL - 1
      ENDIF
      NTRACE = 0
      CALL ZMENTR('ZMABS ',MA,MA,1,MZ01,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      NTRACE = NTRSAV
      IF (KRESLT /= 0) THEN
          CALL FMEQ(MZ01,MBFM)
          NCALL = NCALL + 1
          IF (NTRACE /= 0) CALL FMNTR(1,MBFM,MBFM,1,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KACCSW = 0
      CALL ZMEQU(MA,MZ05,NDSAVE,NDIG)

!             Check for special cases.

      MXEXP1 = INT(MXEXP2/2.01D0)
      IF (MA(2) == 0) THEN
          CALL FMABS(MZ05(KPTIMU-1),MBFM)
          GO TO 110
      ELSE IF (MA(KPTIMU+2) == 0) THEN
          CALL FMABS(MZ05,MBFM)
          GO TO 110
      ELSE IF (MA(1) == MEXPOV .OR. MA(KPTIMU+1) == MEXPOV) THEN
          CALL FMI2M(1,MBFM)
          MBFM(1) = MAX(MZ05(1),MZ05(KPTIMU+1))
          GO TO 110
      ELSE IF (MA(1) == MEXPUN) THEN
          IF (MA(KPTIMU+1) > -MXEXP1+NDIG+1) THEN
              CALL FMABS(MZ05(KPTIMU-1),MBFM)
          ELSE
              CALL FMST2M('UNKNOWN',MBFM)
              KFLAG = -4
          ENDIF
          GO TO 110
      ELSE IF (MA(KPTIMU+1) == MEXPUN) THEN
          IF (MA(1) > -MXEXP1+NDIG+1) THEN
              CALL FMABS(MZ05,MBFM)
          ELSE
              CALL FMST2M('UNKNOWN',MBFM)
              KFLAG = -4
          ENDIF
          GO TO 110
      ELSE IF (MA(1) /= MUNKNO .AND. MA(KPTIMU+1) /= MUNKNO) THEN
          IF (MA(1) > MA(KPTIMU+1)+NDIG+1) THEN
              CALL FMABS(MZ05,MBFM)
              GO TO 110
          ELSE IF (MA(KPTIMU+1) > MA(1)+NDIG+1) THEN
              CALL FMABS(MZ05(KPTIMU-1),MBFM)
              GO TO 110
          ENDIF
      ENDIF

      CALL FMSQR(MZ05,M01)
      CALL FMSQR(MZ05(KPTIMU-1),M02)
      CALL FMADD(M01,M02,MBFM)
      CALL FMSQRT_R1(MBFM)

  110 MACCMB = MBFM(0)
      MBFM(0) = MIN(MACCMB,MARZ,MAIZ)
      CALL ZMEXI2(MBFM,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE ZMABS

      SUBROUTINE ZMACOS(MA,MB)

!  MB = ACOS(MA).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER J,KASAVE,KOVUN,KRESLT,NDSAVE

      CALL ZMENTR('ZMACOS',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KACCSW = 0

      CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)

!             Check for special cases.

      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          CALL FMPI(MZ01)
          CALL FMDIVI_R1(MZ01,2)
          CALL FMI2M(0,MZ01(KPTIMU-1))
          GO TO 110
      ELSE IF (MA(KPTIMU+2) == 0) THEN
          CALL FMACOS(MZ07,MZ01)
          IF (KFLAG == 0) THEN
              CALL FMI2M(0,MZ01(KPTIMU-1))
              GO TO 110
          ENDIF
      ENDIF
      IF ((MA(2) == 0 .OR. MA(1)*2 <= -NDIG) .AND.  &
          (MA(KPTIMU+2) == 0 .OR. MA(KPTIMU+1)*2 <= -NDIG)) THEN
          CALL FMPI(MZ01)
          CALL FMDIVI_R1(MZ01,2)
          CALL FMI2M(0,MZ01(KPTIMU-1))
          CALL ZMSUB(MZ01,MZ07,MZ08)
          CALL ZMEQ(MZ08,MZ01)
          GO TO 110
      ENDIF

      CALL ZMI2M(1,MZ03)
      CALL ZMSUB(MZ03,MZ07,MZ02)
      CALL ZMADD(MZ03,MZ07,MZ08)
      CALL ZMEQ(MZ08,MZ03)
      CALL ZMMPY(MZ02,MZ03,MZ08)
      CALL ZMEQ(MZ08,MZ02)
      CALL ZMSQRT(MZ02,MZ08)
      CALL ZMEQ(MZ08,MZ02)
      DO J = -1, NDIG+1
         MZ03(J) = MZ02(KPTIMU+J)
         MZ03(KPTIMU+J) = MZ02(J)
      ENDDO
      IF (MZ03(1) /= MUNKNO .AND. MZ03(2) /= 0) MZ03(-1) = -MZ03(-1)

      IF ((MA(2) /= 0 .AND. MZ03(1) == MA(1) .AND.  &
          MZ03(-1)*MZ03(2) == MA(-1)*MA(2)) .OR.  &
          (MA(KPTIMU+2) /= 0 .AND. MZ03(KPTIMU+1) == MA(KPTIMU+1) .AND.   &
          MZ03(KPTIMU-1)*MZ03(KPTIMU+2) == MA(KPTIMU-1)*MA(KPTIMU+2)) ) THEN
          CALL ZMADD(MZ07,MZ03,MZ08)
          CALL ZMEQ(MZ08,MZ03)

          CALL FMSQR(MZ03,M04)
          CALL FMSQR(MZ03(KPTIMU-1),M05)
          CALL FMADD(M04,M05,M06)
          CALL FMI2M(1,M03)
          CALL FMSUB_R2(M06,M03)
          IF (M03(1) < 0) THEN
              NDIG = NDIG - INT(M03(1))
              IF (NDIG > NDG2MX) THEN
                  NAMEST(NCALL) = 'ZMACOS'
                  KFLAG = -9
                  CALL ZMWARN
                  KRESLT = 12
                  NDIG = NDSAVE
                  CALL ZMRSLT(MB,KRESLT)
                  IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
                  NCALL = NCALL - 1
                  MXEXP = MXSAVE
                  KACCSW = KASAVE
                  RETURN
              ENDIF
              CALL ZMEQ2_R1(MZ07,NDSAVE,NDIG)
              CALL ZMI2M(1,MZ03)
              CALL ZMSUB(MZ03,MZ07,MZ02)
              CALL ZMADD(MZ03,MZ07,MZ08)
              CALL ZMEQ(MZ08,MZ03)
              CALL ZMMPY(MZ02,MZ03,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              CALL ZMSQRT(MZ02,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              DO J = -1, NDIG+1
                 MZ03(J) = MZ02(KPTIMU+J)
                 MZ03(KPTIMU+J) = MZ02(J)
              ENDDO
              IF (MZ03(1) /= MUNKNO .AND. MZ03(2) /= 0) MZ03(-1) = -MZ03(-1)
              CALL ZMADD(MZ07,MZ03,MZ08)
              CALL ZMEQ(MZ08,MZ03)
          ENDIF

          CALL ZMLN(MZ03,MZ08)
          CALL ZMEQ(MZ08,MZ03)
          DO J = -1, NDIG+1
             MZ01(J) = MZ03(KPTIMU+J)
             MZ01(KPTIMU+J) = MZ03(J)
          ENDDO
          IF (MZ01(KPTIMU+1) /= MUNKNO .AND. MZ01(KPTIMU+2) /= 0)  &
              MZ01(KPTIMU-1) = -MZ01(KPTIMU-1)
      ELSE
          CALL ZMSUB(MZ07,MZ03,MZ08)
          CALL ZMEQ(MZ08,MZ03)

          CALL FMSQR(MZ03,M04)
          CALL FMSQR(MZ03(KPTIMU-1),M05)
          CALL FMADD(M04,M05,M06)
          CALL FMI2M(1,M03)
          CALL FMSUB_R2(M06,M03)
          IF (M03(1) < 0) THEN
              NDIG = NDIG - INT(M03(1))
              IF (NDIG > NDG2MX) THEN
                  NAMEST(NCALL) = 'ZMACOS'
                  KFLAG = -9
                  CALL ZMWARN
                  KRESLT = 12
                  NDIG = NDSAVE
                  CALL ZMRSLT(MB,KRESLT)
                  IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
                  NCALL = NCALL - 1
                  MXEXP = MXSAVE
                  KACCSW = KASAVE
                  RETURN
              ENDIF
              CALL ZMEQ2_R1(MZ07,NDSAVE,NDIG)
              CALL ZMI2M(1,MZ03)
              CALL ZMSUB(MZ03,MZ07,MZ02)
              CALL ZMADD(MZ03,MZ07,MZ08)
              CALL ZMEQ(MZ08,MZ03)
              CALL ZMMPY(MZ02,MZ03,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              CALL ZMSQRT(MZ02,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              DO J = -1, NDIG+1
                 MZ03(J) = MZ02(KPTIMU+J)
                 MZ03(KPTIMU+J) = MZ02(J)
              ENDDO
              IF (MZ03(1) /= MUNKNO .AND. MZ03(2) /= 0) MZ03(-1) = -MZ03(-1)
              CALL ZMSUB(MZ07,MZ03,MZ08)
              CALL ZMEQ(MZ08,MZ03)
          ENDIF

          CALL ZMLN(MZ03,MZ08)
          CALL ZMEQ(MZ08,MZ03)
          DO J = -1, NDIG+1
             MZ01(J) = MZ03(KPTIMU+J)
             MZ01(KPTIMU+J) = MZ03(J)
          ENDDO
          IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
      ENDIF

  110 MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE ZMACOS

      SUBROUTINE ZMADD(MA,MB,MC)

!  MC = MA + MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ)

      INTEGER KASAVE,KF1,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV
      REAL (KIND(1.0D0)) :: MAR,MAI,MBR,MBI,MXSAVE

      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR.  &
          ABS(MB(1)) > MEXPAB .OR. ABS(MB(KPTIMU+1)) > MEXPAB .OR.  &
          KDEBUG >= 1) THEN
          CALL ZMENTR('ZMADD ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
          NDIG = NDSAVE
          MXEXP = MXSAVE
          KACCSW = KASAVE
          NTRSAV = NTRACE
          NTRACE = 0
      ELSE
          NCALL = NCALL + 1
          NTRSAV = NTRACE
          IF (NTRACE /= 0) THEN
              NAMEST(NCALL) = 'ZMADD '
              CALL ZMNTR(2,MA,MB,2)
              NTRACE = 0
          ENDIF
          KOVUN = 0
      ENDIF

!             Force FMADD to use more guard digits for user calls.

      NCALL = NCALL - 1

      KWRNSV = KWARN
      KWARN = 0
      MAR = MA(1)
      IF (MA(2) == 0) MAR = MEXPUN - 1
      MAI = MA(KPTIMU+1)
      IF (MA(KPTIMU+2) == 0) MAI = MEXPUN - 1
      MBR = MB(1)
      IF (MB(2) == 0) MBR = MEXPUN - 1
      MBI = MB(KPTIMU+1)
      IF (MB(KPTIMU+2) == 0) MBI = MEXPUN - 1

      CALL FMADD(MA,MB,MC)
      KF1 = KFLAG
      CALL FMADD(MA(KPTIMU-1),MB(KPTIMU-1),MC(KPTIMU-1))

      NCALL = NCALL + 1
      IF (NTRSAV /= 0) THEN
          NTRACE = NTRSAV
          NAMEST(NCALL) = 'ZMADD '
      ENDIF
      KWARN = KWRNSV
      IF (KFLAG == 1) KFLAG = KF1
      IF (KFLAG == 1) THEN
          KFLAG = 0
          IF (MAR <= MBR .AND. MAI <= MBI) KFLAG = 1
          IF (MAR >= MBR .AND. MAI >= MBI) KFLAG = 1
      ENDIF

      IF (MC(1) == MUNKNO .OR. MC(KPTIMU+1) == MUNKNO) THEN
          KFLAG = -4
      ELSE IF (MC(1) == MEXPOV .OR. MC(KPTIMU+1) == MEXPOV) THEN
          KFLAG = -5
      ELSE IF (MC(1) == MEXPUN .OR. MC(KPTIMU+1) == MEXPUN) THEN
          KFLAG = -6
      ENDIF
      IF ((MC(1) == MUNKNO)  &
         .OR. (MC(KPTIMU+1) == MUNKNO)  &
         .OR. (MC(1) == MEXPUN .AND. KOVUN == 0)  &
         .OR. (MC(KPTIMU+1) == MEXPUN .AND. KOVUN == 0)  &
         .OR. (MC(1) == MEXPOV .AND. KOVUN == 0)  &
         .OR. (MC(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
          NAMEST(NCALL) = 'ZMADD '
          CALL ZMWARN
      ENDIF
      IF (NTRACE /= 0) THEN
          CALL ZMNTR(1,MC,MC,1)
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMADD

      SUBROUTINE ZMADDI(MA,INTEG)

!  MA = MA + INTEG        Increment by one-word (real) integer.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
      INTEGER INTEG

      INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV
      REAL (KIND(1.0D0)) :: MXSAVE

      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR.  &
          KDEBUG >= 1) THEN
          NTRSAV = NTRACE
          IF (NTRACE /= 0) THEN
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'ZMADDI'
              CALL ZMNTR(2,MA,MA,1)
              CALL FMNTRI(2,INTEG,0)
              NCALL = NCALL - 1
          ENDIF
          NTRACE = 0
          CALL ZMENTR('ZMADDI',MA,MA,1,MZ01,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          NTRACE = NTRSAV
          IF (KRESLT /= 0) THEN
              CALL FMEQ(MZ01,MA)
              NCALL = NCALL + 1
              IF (NTRACE /= 0) CALL ZMNTR(1,MA,MA,1)
              NCALL = NCALL - 1
              RETURN
          ENDIF
          NDIG = NDSAVE
          MXEXP = MXSAVE
          KACCSW = KASAVE
          NTRSAV = NTRACE
      ELSE
          NCALL = NCALL + 1
          IF (NTRACE /= 0) THEN
              NAMEST(NCALL) = 'ZMADDI'
              CALL ZMNTR(2,MA,MA,1)
              CALL FMNTRI(2,INTEG,0)
          ENDIF
          KOVUN = 0
      ENDIF

!             Force FMADDI to use more guard digits for user calls.

      NCALL = NCALL - 1
      NTRSAV = NTRACE
      NTRACE = 0
      KWRNSV = KWARN
      KWARN = 0

      CALL FMADDI(MA,INTEG)

      NTRACE = NTRSAV
      KWARN = KWRNSV
      NCALL = NCALL + 1
      IF (NTRACE /= 0) NAMEST(NCALL) = 'ZMADDI'
      IF (MA(1) == MUNKNO .OR. MA(KPTIMU+1) == MUNKNO) THEN
          KFLAG = -4
      ELSE IF (MA(1) == MEXPOV .OR. MA(KPTIMU+1) == MEXPOV) THEN
          KFLAG = -5
      ELSE IF (MA(1) == MEXPUN .OR. MA(KPTIMU+1) == MEXPUN) THEN
          KFLAG = -6
      ENDIF
      IF ((MA(1) == MUNKNO)  &
         .OR. (MA(KPTIMU+1) == MUNKNO)  &
         .OR. (MA(1) == MEXPUN .AND. KOVUN == 0)  &
         .OR. (MA(KPTIMU+1) == MEXPUN .AND. KOVUN == 0)  &
         .OR. (MA(1) == MEXPOV .AND. KOVUN == 0)  &
         .OR. (MA(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
          NAMEST(NCALL) = 'ZMADDI'
          CALL ZMWARN
      ENDIF
      IF (NTRACE /= 0) CALL ZMNTR(1,MA,MA,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMADDI

      SUBROUTINE ZMARG(MA,MBFM)

!  MBFM = ARG(MA)

!  Complex argument.  The result is a real FM number.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MBFM(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MXSAVE
      INTEGER KASAVE,KOVUN,KRESLT,NDSAVE,NTRSAV

      NTRSAV = NTRACE
      IF (NTRACE /= 0) THEN
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'ZMARG '
          CALL ZMNTR(2,MA,MA,1)
          NCALL = NCALL - 1
      ENDIF
      NTRACE = 0
      CALL ZMENTR('ZMARG ',MA,MA,1,MZ01,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      NTRACE = NTRSAV
      IF (KRESLT /= 0) THEN
          CALL FMEQ(MZ01,MBFM)
          NCALL = NCALL + 1
          IF (NTRACE /= 0) CALL FMNTR(1,MBFM,MBFM,1,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF
      KACCSW = 0
      CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)

      CALL FMATN2(MZ07(KPTIMU-1),MZ07,MBFM)

      CALL ZMEXI2(MBFM,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE ZMARG

      SUBROUTINE ZMASIN(MA,MB)

!  MB = ASIN(MA).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER J,KASAVE,KOVUN,KRESLT,NDSAVE

      CALL ZMENTR('ZMASIN',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KACCSW = 0

      CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)

!             Check for special cases.

      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          CALL ZMI2M(0,MZ01)
          GO TO 110
      ELSE IF ((MA(2) == 0 .OR. MA(1)*2 <= -NDIG) .AND.  &
               (MA(KPTIMU+2) == 0 .OR. MA(KPTIMU+1)*2 <= -NDIG)) THEN
          CALL ZMEQ(MZ07,MZ01)
          GO TO 110
      ELSE IF (MA(KPTIMU+2) == 0) THEN
          CALL FMASIN(MZ07,MZ01)
          IF (KFLAG == 0) THEN
              CALL FMI2M(0,MZ01(KPTIMU-1))
              GO TO 110
          ENDIF
      ENDIF

      CALL ZMI2M(1,MZ03)
      CALL ZMSUB(MZ03,MZ07,MZ02)
      CALL ZMADD(MZ03,MZ07,MZ08)
      CALL ZMEQ(MZ08,MZ03)
      CALL ZMMPY(MZ02,MZ03,MZ08)
      CALL ZMEQ(MZ08,MZ02)
      CALL ZMSQRT(MZ02,MZ08)
      CALL ZMEQ(MZ08,MZ02)
      DO J = -1, NDIG+1
         MZ03(J) = MZ07(KPTIMU+J)
         MZ03(KPTIMU+J) = MZ07(J)
      ENDDO
      IF (MZ03(1) /= MUNKNO .AND. MZ03(2) /= 0) MZ03(-1) = -MZ03(-1)

      IF ((MZ02(2) /= 0 .AND. MZ03(1) == MZ02(1) .AND.  &
          MZ03(-1)*MZ03(2) == MZ02(-1)*MZ02(2)) .OR.  &
          (MZ02(KPTIMU+2) /= 0 .AND. MZ03(KPTIMU+1) == MZ02(KPTIMU+1) .AND.  &
          MZ03(KPTIMU-1)*MZ03(KPTIMU+2) ==  &
          MZ02(KPTIMU-1)*MZ02(KPTIMU+2)) ) THEN
          CALL ZMADD(MZ02,MZ03,MZ08)
          CALL ZMEQ(MZ08,MZ03)
          CALL FMSQR(MZ03,M04)
          CALL FMSQR(MZ03(KPTIMU-1),M05)
          CALL FMADD(M04,M05,M06)
          CALL FMI2M(1,M03)
          CALL FMSUB_R2(M06,M03)
          IF (M03(1) < 0) THEN
              NDIG = NDIG - INT(M03(1))
              IF (NDIG > NDG2MX) THEN
                  NAMEST(NCALL) = 'ZMASIN'
                  KFLAG = -9
                  CALL ZMWARN
                  KRESLT = 12
                  NDIG = NDSAVE
                  CALL ZMRSLT(MB,KRESLT)
                  IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
                  NCALL = NCALL - 1
                  MXEXP = MXSAVE
                  KACCSW = KASAVE
                  RETURN
              ENDIF
              CALL ZMEQ2_R1(MZ07,NDSAVE,NDIG)
              CALL ZMI2M(1,MZ03)
              CALL ZMSUB(MZ03,MZ07,MZ02)
              CALL ZMADD(MZ03,MZ07,MZ08)
              CALL ZMEQ(MZ08,MZ03)
              CALL ZMMPY(MZ02,MZ03,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              CALL ZMSQRT(MZ02,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              DO J = -1, NDIG+1
                 MZ03(J) = MZ07(KPTIMU+J)
                 MZ03(KPTIMU+J) = MZ07(J)
              ENDDO
              IF (MZ03(1) /= MUNKNO .AND. MZ03(2) /= 0) MZ03(-1) = -MZ03(-1)
              CALL ZMADD(MZ02,MZ03,MZ08)
              CALL ZMEQ(MZ08,MZ03)
          ENDIF

          CALL ZMLN(MZ03,MZ08)
          CALL ZMEQ(MZ08,MZ03)
          DO J = -1, NDIG+1
             MZ01(J) = MZ03(KPTIMU+J)
             MZ01(KPTIMU+J) = MZ03(J)
          ENDDO
          IF (MZ01(KPTIMU+1) /= MUNKNO .AND. MZ01(KPTIMU+2) /= 0)  &
              MZ01(KPTIMU-1) = -MZ01(KPTIMU-1)
      ELSE
          CALL ZMSUB(MZ02,MZ03,MZ08)
          CALL ZMEQ(MZ08,MZ03)

          CALL FMSQR(MZ03,M04)
          CALL FMSQR(MZ03(KPTIMU-1),M05)
          CALL FMADD(M04,M05,M06)
          CALL FMI2M(1,M03)
          CALL FMSUB_R2(M06,M03)
          IF (M03(1) < 0) THEN
              NDIG = NDIG - INT(M03(1))
              IF (NDIG > NDG2MX) THEN
                  NAMEST(NCALL) = 'ZMASIN'
                  KFLAG = -9
                  CALL ZMWARN
                  KRESLT = 12
                  NDIG = NDSAVE
                  CALL ZMRSLT(MB,KRESLT)
                  IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
                  NCALL = NCALL - 1
                  MXEXP = MXSAVE
                  KACCSW = KASAVE
                  RETURN
              ENDIF
              CALL ZMEQ2_R1(MZ07,NDSAVE,NDIG)
              CALL ZMI2M(1,MZ03)
              CALL ZMSUB(MZ03,MZ07,MZ02)
              CALL ZMADD(MZ03,MZ07,MZ08)
              CALL ZMEQ(MZ08,MZ03)
              CALL ZMMPY(MZ02,MZ03,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              CALL ZMSQRT(MZ02,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              DO J = -1, NDIG+1
                 MZ03(J) = MZ07(KPTIMU+J)
                 MZ03(KPTIMU+J) = MZ07(J)
              ENDDO
              IF (MZ03(1) /= MUNKNO .AND. MZ03(2) /= 0) MZ03(-1) = -MZ03(-1)
              CALL ZMSUB(MZ02,MZ03,MZ08)
              CALL ZMEQ(MZ08,MZ03)
          ENDIF
          CALL ZMLN(MZ03,MZ08)
          CALL ZMEQ(MZ08,MZ03)
          DO J = -1, NDIG+1
             MZ01(J) = MZ03(KPTIMU+J)
             MZ01(KPTIMU+J) = MZ03(J)
          ENDDO
          IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
      ENDIF

  110 MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE ZMASIN

      SUBROUTINE ZMATAN(MA,MB)

!  MB = ATAN(MA).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER J,JTERM,KASAVE,KOVUN,KRESLT,NDSAVE
      LOGICAL FMCOMP
      REAL X

      CALL ZMENTR('ZMATAN',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KACCSW = 0

      CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)

!             Check for special cases.

      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          CALL ZMI2M(0,MZ04)
          GO TO 120
      ELSE IF ((MA(2) == 0 .OR. MA(1)*2 <= -NDIG) .AND.  &
               (MA(KPTIMU+2) == 0 .OR. MA(KPTIMU+1)*2 <= -NDIG)) THEN
          CALL ZMEQ(MZ07,MZ04)
          GO TO 120
      ELSE IF (MA(KPTIMU+2) == 0) THEN
          CALL FMATAN(MZ07,MZ04)
          IF (KFLAG == 0) THEN
              CALL FMI2M(0,MZ04(KPTIMU-1))
              GO TO 120
          ENDIF
      ENDIF

      X = 1.0E+5
      CALL FMDPM(DBLE(X),M02)
      CALL FMABS(MZ07,M03)
      CALL FMABS(MZ07(KPTIMU-1),M04)
      CALL FMADD_R2(M03,M04)

      IF (FMCOMP(M04,'GE',M02)) THEN
          CALL ZMI2M(0,MZ04)
          CALL FMPI(MZ04)
          CALL FMDIVI_R1(MZ04,2)
          IF (MA(-1) < 0 .AND. MZ04(1) /= MUNKNO .AND. MZ04(2) /= 0)  &
              MZ04(-1) = -MZ04(-1)
          CALL ZMI2M(1,MZ02)
          CALL ZMDIV(MZ02,MZ07,MZ08)
          CALL ZMEQ(MZ08,MZ02)
          CALL ZMEQ(MZ02,MZ03)
          CALL ZMSUB(MZ04,MZ02,MZ08)
          CALL ZMEQ(MZ08,MZ04)
          IF (MA(1) > NDIG .OR. MA(KPTIMU+1) > NDIG) GO TO 120
          CALL ZMSQR(MZ02,MZ08)
          CALL ZMEQ(MZ08,MZ02)
          JTERM = 1
  110     CALL ZMMPY(MZ03,MZ02,MZ08)
          CALL ZMEQ(MZ08,MZ03)
          JTERM = JTERM + 2
          CALL FMEQ(MZ03,M05)
          CALL FMEQ(MZ03(KPTIMU-1),M06)
          CALL ZMDIVI(MZ03,JTERM,MZ08)
          CALL ZMEQ(MZ08,MZ03)
          CALL ZMADD(MZ04,MZ03,MZ08)
          CALL ZMEQ(MZ08,MZ04)
          IF (KFLAG /= 0) GO TO 120
          CALL FMEQ(M05,MZ03)
          CALL FMEQ(M06,MZ03(KPTIMU-1))
          CALL ZMMPY(MZ03,MZ02,MZ08)
          CALL ZMEQ(MZ08,MZ03)
          JTERM = JTERM + 2
          CALL FMEQ(MZ03,M05)
          CALL FMEQ(MZ03(KPTIMU-1),M06)
          CALL ZMDIVI(MZ03,JTERM,MZ08)
          CALL ZMEQ(MZ08,MZ03)
          CALL ZMSUB(MZ04,MZ03,MZ08)
          CALL ZMEQ(MZ08,MZ04)
          IF (KFLAG /= 0) GO TO 120
          CALL FMEQ(M05,MZ03)
          CALL FMEQ(M06,MZ03(KPTIMU-1))
          GO TO 110
      ELSE
          CALL ZM2I2M(0,1,MZ02)
          CALL ZMSUB(MZ02,MZ07,MZ03)
          CALL ZMADD(MZ02,MZ07,MZ08)
          CALL ZMEQ(MZ08,MZ02)
          CALL ZMDIV(MZ02,MZ03,MZ08)
          CALL ZMEQ(MZ08,MZ03)

          CALL FMSQR(MZ03,M04)
          CALL FMSQR(MZ03(KPTIMU-1),M05)
          CALL FMADD(M04,M05,M06)
          CALL FMI2M(1,M03)
          CALL FMSUB_R2(M06,M03)
          IF (M03(1) < 0) THEN
              NDIG = NDIG - INT(M03(1))
              IF (NDIG > NDG2MX) THEN
                  NAMEST(NCALL) = 'ZMATAN'
                  KFLAG = -9
                  CALL ZMWARN
                  KRESLT = 12
                  NDIG = NDSAVE
                  CALL ZMRSLT(MB,KRESLT)
                  IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
                  NCALL = NCALL - 1
                  MXEXP = MXSAVE
                  KACCSW = KASAVE
                  RETURN
              ENDIF
              CALL ZMEQ2_R1(MZ07,NDSAVE,NDIG)
              CALL ZM2I2M(0,1,MZ02)
              CALL ZMSUB(MZ02,MZ07,MZ03)
              CALL ZMADD(MZ02,MZ07,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              CALL ZMDIV(MZ02,MZ03,MZ08)
              CALL ZMEQ(MZ08,MZ03)
          ENDIF

          CALL ZMLN(MZ03,MZ08)
          CALL ZMEQ(MZ08,MZ03)
          CALL ZMDIVI(MZ03,2,MZ08)
          CALL ZMEQ(MZ08,MZ03)
          DO J = -1, NDIG+1
             MZ04(J) = MZ03(KPTIMU+J)
             MZ04(KPTIMU+J) = MZ03(J)
          ENDDO
          IF (MZ04(1) /= MUNKNO .AND. MZ04(2) /= 0) MZ04(-1) = -MZ04(-1)
      ENDIF

  120 MACCMB = MZ04(0)
      MZ04(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ04(KPTIMU)
      MZ04(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      CALL ZMEXIT(MZ04,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE ZMATAN

      SUBROUTINE ZMCHSH(MA,MB,MC)

!  MB = COSH(MA),    MC = SINH(MA).

!  If both the hyperbolic sine and cosine are needed, this routine
!  is faster than calling both ZMCOS and ZMSIN.

!  MB and MC must be distinct arrays.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NCSAVE,NDSAVE

      NCSAVE = NCALL
      CALL ZMENTR('ZMCHSH',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      NCALL = NCSAVE + 1
      IF (KRESLT /= 0) THEN
          CALL ZMEQ(MB,MC)
          IF (NTRACE /= 0) THEN
              CALL ZMNTR(1,MB,MB,1)
              IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN
                  IF (NTRACE < 0) THEN
                      CALL ZMNTRJ(MC,NDIG)
                  ELSE
                      CALL ZMPRNT(MC)
                  ENDIF
              ENDIF
          ENDIF
          NCALL = NCALL - 1
          RETURN
      ENDIF
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KACCSW = 0
      KRSAVE = KRAD
      KRAD = 1

      CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)

!             Check for special cases.

      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          CALL ZMI2M(1,MZ01)
          CALL ZMI2M(0,MC)
          GO TO 110
      ELSE IF (MA(KPTIMU+2) == 0) THEN
          CALL FMCHSH(MZ07,MZ01,MC)
          CALL FMI2M(0,MZ01(KPTIMU-1))
          CALL FMI2M(0,MC(KPTIMU-1))
          GO TO 110
      ELSE IF (MA(2) == 0) THEN
          CALL FMCSSN(MZ07(KPTIMU-1),MZ01,MC(KPTIMU-1))
          CALL FMI2M(0,MZ01(KPTIMU-1))
          CALL FMI2M(0,MC)
          GO TO 110
      ENDIF

!             Find SINH(REAL(MA)) and COSH(REAL(MA)).

      CALL FMCHSH(MZ07,MZ02,MZ02(KPTIMU-1))

!             Find SIN(IMAG(MA)) and COS(IMAG(MA)).

      CALL FMCSSN(MZ07(KPTIMU-1),MZ03,MZ03(KPTIMU-1))

!             COSH(MA) =  COSH(REAL(MA))*COS(IMAG(MA)) +
!                         SINH(REAL(MA))*SIN(IMAG(MA)) i

      CALL FMMPY(MZ02,MZ03,MZ01)
      CALL FMMPY(MZ02(KPTIMU-1),MZ03(KPTIMU-1),MZ01(KPTIMU-1))

!             SINH(MA) =  SINH(REAL(MA))*COS(IMAG(MA)) +
!                         COSH(REAL(MA))*SIN(IMAG(MA)) i

      CALL FMMPY(MZ02(KPTIMU-1),MZ03,MC)
      CALL FMMPY(MZ02,MZ03(KPTIMU-1),MC(KPTIMU-1))

  110 MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      MC(0) = MZ01(0)
      MC(KPTIMU) = MZ01(KPTIMU)
      KACCSW = KASAVE
      CALL ZMEQ2_R1(MC,NDIG,NDSAVE)
      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      IF (NTRACE /= 0) THEN
          IF (ABS(NTRACE) >= 1 .AND. NCALL+1 <= LVLTRC) THEN
              IF (NTRACE < 0) THEN
                  CALL ZMNTRJ(MC,NDIG)
              ELSE
                  CALL ZMPRNT(MC)
              ENDIF
          ENDIF
      ENDIF
      KRAD = KRSAVE
      RETURN
      END SUBROUTINE ZMCHSH

      SUBROUTINE ZMCMPX(MAFM,MBFM,MC)

!  MC = COMPLEX( MAFM , MBFM )

!  MAFM and MBFM are real FM numbers, MC is a complex ZM number.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MAFM(-1:LUNPCK),MBFM(-1:LUNPCK),MC(-1:LUNPKZ)

      KFLAG = 0
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMCMPX'
      IF (NTRACE /= 0) CALL FMNTR(2,MAFM,MBFM,2,1)

      CALL FMEQ(MAFM,MC)
      CALL FMEQ(MBFM,MC(KPTIMU-1))

      IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMCMPX

      SUBROUTINE ZMCONJ(MA,MB)

!  MB = CONJG(MA)

!  Complex conjugate.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)

      KFLAG = 0
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMCONJ'
      IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)

      CALL FMEQ(MA,MB)
      CALL FMEQ(MA(KPTIMU-1),MB(KPTIMU-1))
      IF (MB(KPTIMU+1) /= MUNKNO .AND. MB(KPTIMU+2) /= 0)  &
          MB(KPTIMU-1) = -MB(KPTIMU-1)

      IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMCONJ

      SUBROUTINE ZMCOS(MA,MB)

!  MB = COS(MA).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE

      CALL ZMENTR('ZMCOS ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KACCSW = 0
      KRSAVE = KRAD
      KRAD = 1

      CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)

!             Check for special cases.

      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          CALL ZMI2M(1,MZ01)
          GO TO 110
      ELSE IF (MA(KPTIMU+2) == 0) THEN
          CALL FMCOS(MZ07,MZ01)
          CALL FMI2M(0,MZ01(KPTIMU-1))
          GO TO 110
      ELSE IF (MA(2) == 0) THEN
          CALL FMCOSH(MZ07(KPTIMU-1),MZ01)
          CALL FMI2M(0,MZ01(KPTIMU-1))
          GO TO 110
      ENDIF

!             Find COS(REAL(MA)) and SIN(REAL(MA)).

      CALL FMCSSN(MZ07,MZ01,MZ01(KPTIMU-1))

!             Find COSH(IMAG(MA)) and SINH(IMAG(MA)).

      CALL FMCHSH(MZ07(KPTIMU-1),M05,M06)

!             COS(MA) =  COS(REAL(MA))*COSH(IMAG(MA)) -
!                        SIN(REAL(MA))*SINH(IMAG(MA)) i

      CALL FMMPY_R1(MZ01,M05)
      IF (M06(1) /= MUNKNO .AND. M06(2) /= 0) M06(-1) = -M06(-1)
      CALL FMMPY_R1(MZ01(KPTIMU-1),M06)

  110 MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      KRAD = KRSAVE
      RETURN
      END SUBROUTINE ZMCOS

      SUBROUTINE ZMCOSH(MA,MB)

!  MB = COSH(MA).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE

      CALL ZMENTR('ZMCOSH',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KACCSW = 0
      KRSAVE = KRAD
      KRAD = 1

      CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)

!             Check for special cases.

      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          CALL ZMI2M(1,MZ01)
          GO TO 110
      ELSE IF (MA(2) == 0) THEN
          CALL FMCOS(MZ07(KPTIMU-1),MZ01)
          CALL FMI2M(0,MZ01(KPTIMU-1))
          GO TO 110
      ELSE IF (MA(KPTIMU+2) == 0) THEN
          CALL FMCOSH(MZ07,MZ01)
          CALL FMI2M(0,MZ01(KPTIMU-1))
          GO TO 110
      ENDIF

!             Find COS(IMAG(MA)) and SIN(IMAG(MA)).

      CALL FMCSSN(MZ07(KPTIMU-1),MZ01,MZ01(KPTIMU-1))

!             Find COSH(REAL(MA)) and SINH(REAL(MA)).

      CALL FMCHSH(MZ07,M05,M06)

!             COSH(MA) =  COSH(REAL(MA))*COS(IMAG(MA)) +
!                         SINH(REAL(MA))*SIN(IMAG(MA)) i

      CALL FMMPY_R1(MZ01,M05)
      CALL FMMPY_R1(MZ01(KPTIMU-1),M06)

  110 MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      KRAD = KRSAVE
      RETURN
      END SUBROUTINE ZMCOSH

      SUBROUTINE ZMCSSN(MA,MB,MC)

!  MB = COS(MA),    MC = SIN(MA).

!  If both the sine and cosine are needed, this routine is faster
!  than calling both ZMCOS and ZMSIN.

!  MB and MC must be distinct arrays.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NCSAVE,NDSAVE

      NCSAVE = NCALL
      CALL ZMENTR('ZMCSSN',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      NCALL = NCSAVE + 1
      IF (KRESLT /= 0) THEN
          CALL ZMEQ(MB,MC)
          IF (NTRACE /= 0) THEN
              CALL ZMNTR(1,MB,MB,1)
              IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN
                  IF (NTRACE < 0) THEN
                      CALL ZMNTRJ(MC,NDIG)
                  ELSE
                      CALL ZMPRNT(MC)
                  ENDIF
              ENDIF
          ENDIF
          NCALL = NCALL - 1
          RETURN
      ENDIF
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KACCSW = 0
      KRSAVE = KRAD
      KRAD = 1

      CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)

!             Check for special cases.

      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          CALL ZMI2M(1,MZ01)
          CALL ZMI2M(0,MC)
          GO TO 110
      ELSE IF (MA(KPTIMU+2) == 0) THEN
          CALL FMCSSN(MZ07,MZ01,MC)
          CALL FMI2M(0,MZ01(KPTIMU-1))
          CALL FMI2M(0,MC(KPTIMU-1))
          GO TO 110
      ELSE IF (MA(2) == 0) THEN
          CALL FMCHSH(MZ07(KPTIMU-1),MZ01,MC(KPTIMU-1))
          CALL FMI2M(0,MZ01(KPTIMU-1))
          CALL FMI2M(0,MC)
          GO TO 110
      ENDIF

!             Find SIN(REAL(MA)) and COS(REAL(MA)).

      CALL FMCSSN(MZ07,MZ02,MZ02(KPTIMU-1))

!             Find SINH(IMAG(MA)) and COSH(IMAG(MA)).

      CALL FMCHSH(MZ07(KPTIMU-1),MZ03,MZ03(KPTIMU-1))

!             COS(MA) =  COS(REAL(MA))*COSH(IMAG(MA)) -
!                        SIN(REAL(MA))*SINH(IMAG(MA)) i

      CALL FMMPY(MZ02,MZ03,MZ01)
      CALL FMMPY(MZ02(KPTIMU-1),MZ03(KPTIMU-1),MZ01(KPTIMU-1))
      IF (MZ01(KPTIMU+1) /= MUNKNO .AND. MZ01(KPTIMU+2) /= 0)  &
          MZ01(KPTIMU-1) = -MZ01(KPTIMU-1)

!             SIN(MA) =  SIN(REAL(MA))*COSH(IMAG(MA)) +
!                        COS(REAL(MA))*SINH(IMAG(MA)) i

      CALL FMMPY(MZ02(KPTIMU-1),MZ03,MC)
      CALL FMMPY(MZ02,MZ03(KPTIMU-1),MC(KPTIMU-1))

  110 MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      MC(0) = MZ01(0)
      MC(KPTIMU) = MZ01(KPTIMU)
      KACCSW = KASAVE
      CALL ZMEQ2_R1(MC,NDIG,NDSAVE)
      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      IF (NTRACE /= 0) THEN
          IF (ABS(NTRACE) >= 1 .AND. NCALL+1 <= LVLTRC) THEN
              IF (NTRACE < 0) THEN
                  CALL ZMNTRJ(MC,NDIG)
              ELSE
                  CALL ZMPRNT(MC)
              ENDIF
          ENDIF
      ENDIF
      KRAD = KRSAVE
      RETURN
      END SUBROUTINE ZMCSSN

      SUBROUTINE ZMDIV(MA,MB,MC)

!  MC = MA / MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MBIZ,MBRZ,MXSAVE,MZ11SV,MZ1KSV
      INTEGER IEXTRA,J,KASAVE,KOVUN,KRESLT,KWRNSV,NDGSV2,NDSAVE,NGOAL,  &
              NTRSAV

      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR.  &
          ABS(MB(1)) > MEXPAB .OR. ABS(MB(KPTIMU+1)) > MEXPAB .OR.  &
          KDEBUG >= 1) THEN
          CALL ZMENTR('ZMDIV ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          IF (NTRACE /= 0) THEN
              NAMEST(NCALL) = 'ZMDIV '
              CALL ZMNTR(2,MA,MB,2)
          ENDIF
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              NDIG = MAX(NDIG+NGRD52,2)
              IF (NDIG > NDG2MX) THEN
                  NAMEST(NCALL) = 'ZMDIV '
                  KFLAG = -9
                  CALL ZMWARN
                  KRESLT = 12
                  NDIG = NDSAVE
                  CALL ZMRSLT(MC,KRESLT)
                  IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
              IF (MBASE >= 100*ABS(MA(2)) .OR.  &
                  MBASE >= 100*ABS(MA(KPTIMU+2))) THEN
                  NDIG = MIN(NDIG+1,NDG2MX)
              ELSE IF (MBASE >= 100*ABS(MB(2)) .OR.  &
                  MBASE >= 100*ABS(MB(KPTIMU+2))) THEN
                  NDIG = MIN(NDIG+1,NDG2MX)
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 1
          MXSAVE = MXEXP
          MXEXP = MXEXP2
          KOVUN = 0
      ENDIF
      IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
          IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
      ENDIF

      MARZ = MA(0)
      MBRZ = MB(0)
      MAIZ = MA(KPTIMU)
      MBIZ = MB(KPTIMU)
      NTRSAV = NTRACE
      NTRACE = 0
      KWRNSV = KWARN
      KWARN = 0
      IEXTRA = 0
      MZ11SV = -MUNKNO
      MZ1KSV = -MUNKNO

  110 CALL FMEQU(MA,M17,NDSAVE,NDIG)
      CALL FMEQU(MA(KPTIMU-1),M18,NDSAVE,NDIG)
      CALL FMEQU(MB,M19,NDSAVE,NDIG)
      CALL FMEQU(MB(KPTIMU-1),M20,NDSAVE,NDIG)
      IF (NCALL == 1) THEN
          M17(0) = NINT(NDIG*ALOGM2)
          M19(0) = M17(0)
          M18(0) = M17(0)
          M20(0) = M17(0)
      ENDIF

!             Check for special cases.

      IF (MB(KPTIMU+2) == 0) THEN
          CALL FMDIVD(M17,M18,M19,MZ01,MZ01(KPTIMU-1))
          GO TO 130
      ELSE IF (MB(2) == 0) THEN
          CALL FMDIVD(M18,M17,M20,MZ01,MZ01(KPTIMU-1))
          IF (MZ01(KPTIMU+1) /= MUNKNO .AND. MZ01(KPTIMU+2) /= 0)  &
              MZ01(KPTIMU-1) = -MZ01(KPTIMU-1)
          GO TO 130
      ENDIF
      IF (MA(1) == MB(1) .AND. MA(2) == MB(2) .AND. MA(-1) == MB(-1)) THEN
          IF (MA(KPTIMU+1) == MB(KPTIMU+1) .AND.  &
              MA(KPTIMU+2) == MB(KPTIMU+2) .AND.  &
              MA(KPTIMU-1) == MB(KPTIMU-1)) THEN
              DO J = 3, NDSAVE+1
                 IF (MA(J) /= MB(J)) GO TO 120
                 IF (MA(KPTIMU+J) /= MB(KPTIMU+J)) GO TO 120
              ENDDO
              IF (ABS(MA(1)) < MEXPOV .AND. ABS(MA(KPTIMU+1)) < MEXPOV  &
                  .AND. ABS(MB(1)) < MEXPOV .AND.  &
                  ABS(MB(KPTIMU+1)) < MEXPOV) THEN
                  CALL ZMI2M(1,MZ01)
                  GO TO 130
              ENDIF
          ENDIF
      ENDIF
      IF (MA(1) == MB(1) .AND. MA(2) == MB(2) .AND. (-MA(-1)) == MB(-1)) THEN
          IF (MA(KPTIMU+1) == MB(KPTIMU+1) .AND.  &
              MA(KPTIMU+2) == MB(KPTIMU+2) .AND.  &
              (-MA(KPTIMU-1)) == MB(KPTIMU-1)) THEN
              DO J = 3, NDSAVE+1
                 IF (MA(J) /= MB(J)) GO TO 120
                 IF (MA(KPTIMU+J) /= MB(KPTIMU+J)) GO TO 120
              ENDDO
              IF (ABS(MA(1)) < MEXPOV .AND. ABS(MA(KPTIMU+1)) < MEXPOV  &
                  .AND. ABS(MB(1)) < MEXPOV .AND.  &
                  ABS(MB(KPTIMU+1)) < MEXPOV) THEN
                  CALL ZMI2M(-1,MZ01)
                  GO TO 130
              ENDIF
          ENDIF
      ENDIF
  120 IF (MZ11SV /= -MUNKNO) THEN

!             If a retry is being done due to cancellation, try a slower
!             but more stable form of the division formula.

          CALL FMMPYE(M19,M17,M18,M19,  &
                      MZ01,MZ01(KPTIMU-1),M03)
          CALL FMMPYE(M20,M18,M17,M20,  &
                      M01,M02,M04)
          CALL FMADD_R2(M03,M04)
          CALL FMADD_R1(MZ01,M01)
          CALL FMSUB_R1(MZ01(KPTIMU-1),M02)
          CALL FMDIVD(MZ01,MZ01(KPTIMU-1),M04,MZ08,MZ08(KPTIMU-1))
          CALL ZMEQ(MZ08,MZ01)
          IF (ABS(MZ01(1)) < MEXPOV .AND.  &
              ABS(MZ01(KPTIMU+1)) < MEXPOV) GO TO 130
      ENDIF

!             Normal method for  ( a + b i ) / ( c + d i ):

!             If  abs(c) << abs(d)  Then

!                 P = c / d
!                 result = ( a*P + b )/( c*P + d ) +
!                          ( b*P - a )/( c*P + d ) i

!             Else

!                 P = d / c
!                 result = ( b*P + a )/( d*P + c ) +
!                          ( b - a*P )/( d*P + c ) i

      KACCSW = 0
      IF (MB(1) <= MB(KPTIMU+1)) THEN
          CALL FMDIV(M19,M20,M04)
          CALL FMMPYE(M04,M17,M18,M19,MZ01,MZ01(KPTIMU-1),M03)
          IF (MA(KPTIMU-1)*MZ01(-1) < 0) THEN
              KACCSW = 1
          ELSE
              KACCSW = 0
          ENDIF
          CALL FMADD_R2(M18,MZ01)
          IF (M03(-1)*MB(KPTIMU-1) < 0) THEN
              KACCSW = 1
          ELSE
              KACCSW = 0
          ENDIF
          CALL FMADD_R1(M03,M20)
          IF (MZ01(KPTIMU-1)*MA(-1) < 0) THEN
              KACCSW = 0
          ELSE
              KACCSW = 1
          ENDIF
          CALL FMSUB_R1(MZ01(KPTIMU-1),M17)
          KACCSW = 0
          CALL FMDIVD(MZ01,MZ01(KPTIMU-1),M03,MZ08,MZ08(KPTIMU-1))
          CALL ZMEQ(MZ08,MZ01)
      ELSE
          CALL FMDIV(M20,M19,M04)
          CALL FMMPYE(M04,M18,M17,M20,  &
                      MZ01,MZ01(KPTIMU-1),M03)
          IF (MA(-1)*MZ01(-1) < 0) THEN
              KACCSW = 1
          ELSE
              KACCSW = 0
          ENDIF
          CALL FMADD_R2(M17,MZ01)
          IF (M03(-1)*MB(-1) < 0) THEN
              KACCSW = 1
          ELSE
              KACCSW = 0
          ENDIF
          CALL FMADD_R1(M03,M19)
          IF (MZ01(KPTIMU-1)*MA(KPTIMU-1) < 0) THEN
              KACCSW = 0
          ELSE
              KACCSW = 1
          ENDIF
          CALL FMSUB_R2(M18,MZ01(KPTIMU-1))
          KACCSW = 0
          CALL FMDIVD(MZ01,MZ01(KPTIMU-1),M03,MZ08,MZ08(KPTIMU-1))
          CALL ZMEQ(MZ08,MZ01)
      ENDIF
      KACCSW = 1

!             Check for too much cancellation.

      IF (NCALL <= 1) THEN
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7
      ELSE
          NGOAL = INT(-MXEXP2)
      ENDIF
      IF (MZ01(0) <= NGOAL .OR. MZ01(KPTIMU) <= NGOAL) THEN
          IF (MZ11SV-MZ01(1) >= IEXTRA-1 .AND. MZ01(KPTIMU) > NGOAL)  &
              GO TO 130
          IF (MZ1KSV-MZ01(KPTIMU+1) >= IEXTRA-1 .AND. MZ01(0) > NGOAL)  &
              GO TO 130
          IF (MZ11SV > -MUNKNO .AND. MZ01(0) > NGOAL .AND.  &
              MZ01(KPTIMU+2) == 0) GO TO 130
          IF (MZ11SV > -MUNKNO .AND. MZ01(KPTIMU) > NGOAL .AND.  &
              MZ01(2) == 0) GO TO 130
          IEXTRA = INT(REAL(MAX(NGOAL-MZ01(0),NGOAL-MZ01(KPTIMU)))  &
                   /ALOGM2 + 23.03/ALOGMB) + 1
          MZ11SV = MZ01(1)
          MZ1KSV = MZ01(KPTIMU+1)
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              NAMEST(NCALL) = 'ZMDIV '
              KFLAG = -9
              CALL ZMWARN
              NDIG = NDSAVE
              CALL ZMST2M('UNKNOWN+UNKNOWN*i',MZ01)
              GO TO 130
          ENDIF
          GO TO 110
      ENDIF

  130 MXEXP = MXSAVE
      NTRACE = NTRSAV
      NDGSV2 = NDIG
      NDIG = NDSAVE
      KWARN = KWRNSV
      MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)
      CALL ZMEQ2(MZ01,MC,NDGSV2,NDSAVE)
      IF (MC(1) >= MEXPOV .OR. MC(1) <= -MEXPOV .OR.  &
          MC(KPTIMU+1) >= MEXPOV .OR. MC(KPTIMU+1) <= -MEXPOV) THEN
          IF (MC(1) == MUNKNO .OR. MC(KPTIMU+1) == MUNKNO) THEN
              KFLAG = -4
          ELSE IF (MC(1) == MEXPOV .OR. MC(KPTIMU+1) == MEXPOV) THEN
              KFLAG = -5
          ELSE IF (MC(1) == MEXPUN .OR. MC(KPTIMU+1) == MEXPUN) THEN
              KFLAG = -6
          ENDIF
          IF ((MC(1) == MUNKNO)  &
             .OR. (MC(KPTIMU+1) == MUNKNO)  &
             .OR. (MC(1) == MEXPUN .AND. KOVUN == 0)  &
             .OR. (MC(KPTIMU+1) == MEXPUN .AND. KOVUN == 0)  &
             .OR. (MC(1) == MEXPOV .AND. KOVUN == 0)  &
             .OR. (MC(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
                  NAMEST(NCALL) = 'ZMDIV '
                  CALL ZMWARN
          ENDIF
      ENDIF
      IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
      KACCSW = KASAVE
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMDIV

      SUBROUTINE ZMDIVI(MA,INTEG,MB)

!  MB = MA / INTEG        Divide by one-word (real) integer.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      INTEGER INTEG

      INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV
      REAL (KIND(1.0D0)) :: MXSAVE

      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR.  &
          KDEBUG >= 1) THEN
          NTRSAV = NTRACE
          IF (NTRACE /= 0) THEN
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'ZMDIVI'
              CALL ZMNTR(2,MA,MA,1)
              CALL FMNTRI(2,INTEG,0)
              NCALL = NCALL - 1
          ENDIF
          NTRACE = 0
          CALL ZMENTR('ZMDIVI',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          NTRACE = NTRSAV
          IF (KRESLT /= 0) THEN
              NCALL = NCALL + 1
              IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
              NCALL = NCALL - 1
              RETURN
          ENDIF
          NDIG = NDSAVE
          MXEXP = MXSAVE
          KACCSW = KASAVE
      ELSE
          NCALL = NCALL + 1
          IF (NTRACE /= 0) THEN
              NAMEST(NCALL) = 'ZMDIVI'
              CALL ZMNTR(2,MA,MA,1)
              CALL FMNTRI(2,INTEG,0)
          ENDIF
          KOVUN = 0
      ENDIF

!             Force FMDIVI to use more guard digits for user calls.

      NCALL = NCALL - 1
      NTRSAV = NTRACE
      NTRACE = 0
      KWRNSV = KWARN
      KWARN = 0

      CALL FMDIVI(MA,INTEG,MB)
      CALL FMDIVI(MA(KPTIMU-1),INTEG,MB(KPTIMU-1))

      NTRACE = NTRSAV
      KWARN = KWRNSV
      NCALL = NCALL + 1
      IF (NTRACE /= 0) NAMEST(NCALL) = 'ZMDIVI'
      IF (MB(1) == MUNKNO .OR. MB(KPTIMU+1) == MUNKNO) THEN
          KFLAG = -4
      ELSE IF (MB(1) == MEXPOV .OR. MB(KPTIMU+1) == MEXPOV) THEN
          KFLAG = -5
      ELSE IF (MB(1) == MEXPUN .OR. MB(KPTIMU+1) == MEXPUN) THEN
          KFLAG = -6
      ENDIF
      IF ((MB(1) == MUNKNO)  &
         .OR. (MB(KPTIMU+1) == MUNKNO)  &
         .OR. (MB(1) == MEXPUN .AND. KOVUN == 0)  &
         .OR. (MB(KPTIMU+1) == MEXPUN .AND. KOVUN == 0)  &
         .OR. (MB(1) == MEXPOV .AND. KOVUN == 0)  &
         .OR. (MB(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
          NAMEST(NCALL) = 'ZMDIVI'
          CALL ZMWARN
      ENDIF
      IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMDIVI

      SUBROUTINE ZMENTR(NROUTN,MA,MB,NARGS,MC,KRESLT,NDSAVE,MXSAVE,  &
                        KASAVE,KOVUN)

!  Do the argument checking and increasing of precision, overflow
!  threshold, etc., upon entry to a ZM routine.

!  NROUTN - routine name of calling routine
!  MA     - first input argument
!  MB     - second input argument (optional)
!  NARGS  - number of input arguments
!  MC     - result argument
!  KRESLT - returned nonzero if the input arguments give the result
!           immediately (e.g., MA*0 or OVERFLOW*MB)
!  NDSAVE - saves the value of NDIG after NDIG is increased
!  MXSAVE - saves the value of MXEXP
!  KASAVE - saves the value of KACCSW
!  KOVUN  - returned nonzero if an input argument is (+ or -) overflow
!           or underflow.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(6) :: NROUTN
      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ),MXSAVE
      INTEGER NARGS,KRESLT,NDSAVE,KASAVE,KOVUN

      REAL (KIND(1.0D0)) :: MBS
      INTEGER J,KWRNSV,NDS

      KRESLT = 0
      NCALL = NCALL + 1
      KFLAG = 0
      NAMEST(NCALL) = NROUTN
      IF (NTRACE /= 0) CALL ZMNTR(2,MA,MB,NARGS)

      IF (MBLOGS /= MBASE) CALL FMCONS
      KOVUN = 0
      IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN .OR.  &
          MA(KPTIMU+1) == MEXPOV .OR. MA(KPTIMU+1) == MEXPUN) KOVUN = 1
      IF (NARGS == 2) THEN
          IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN .OR.  &
          MB(KPTIMU+1) == MEXPOV .OR. MB(KPTIMU+1) == MEXPUN) KOVUN = 1
      ENDIF
      KASAVE = KACCSW
      MXSAVE = MXEXP

!             Check the validity of parameters if this is a user call.

      IF (NCALL > 1 .AND. KDEBUG == 0) GO TO 130

!             Check NDIG.

      IF (NDIG < 2 .OR. NDIG > NDIGMX) THEN
          KFLAG = -1
          CALL ZMWARN
          NDS = NDIG
          IF (NDIG < 2) NDIG = 2
          IF (NDIG > NDIGMX) NDIG = NDIGMX
          WRITE (KW,  &
                 "(' NDIG was',I10,'.  It has been changed to',I10,'.')"  &
                ) NDS,NDIG
          KRESLT = 12
          GO TO 130
      ENDIF

!             Check MBASE.

      IF (MBASE < 2 .OR. MBASE > MXBASE) THEN
          KFLAG = -2
          CALL ZMWARN
          MBS = MBASE
          IF (MBASE < 2) MBASE = 2
          IF (MBASE > MXBASE) MBASE = MXBASE
          WRITE (KW,  &
                 "(' MBASE was',I10,'.  It has been changed to',I10,'.')"  &
                ) INT(MBS),INT(MBASE)
          CALL FMCONS
          KRESLT = 12
          GO TO 130
      ENDIF

!             Check exponent range.

      IF (MA(1) > MXEXP+1 .OR. MA(1) < -MXEXP) THEN
          IF ((ABS(MA(1)) /= MEXPOV .AND. ABS(MA(1)) /= MUNKNO) .OR.  &
              ABS(MA(2)) /= 1) THEN
              KFLAG = -3
              CALL ZMWARN
              KRESLT = 12
              GO TO 130
          ENDIF
      ENDIF
      IF (MA(KPTIMU+1) > MXEXP+1 .OR. MA(KPTIMU+1) < -MXEXP) THEN
          IF ((ABS(MA(KPTIMU+1)) /= MEXPOV .AND.  &
               ABS(MA(KPTIMU+1)) /= MUNKNO)       .OR.  &
              ABS(MA(KPTIMU+2)) /= 1) THEN
              KFLAG = -3
              CALL ZMWARN
              KRESLT = 12
              GO TO 130
          ENDIF
      ENDIF
      IF (NARGS == 2) THEN
          IF (MB(1) > MXEXP+1 .OR. MB(1) < -MXEXP) THEN
              IF ((ABS(MB(1)) /= MEXPOV .AND. ABS(MB(1)) /= MUNKNO) .OR.  &
                  ABS(MB(2)) /= 1) THEN
                  KFLAG = -3
                  CALL ZMWARN
                  KRESLT = 12
                  GO TO 130
              ENDIF
          ENDIF
          IF (MB(KPTIMU+1) > MXEXP+1 .OR. MB(KPTIMU+1) < -MXEXP) THEN
              IF ((ABS(MB(KPTIMU+1)) /= MEXPOV .AND.  &
                   ABS(MB(KPTIMU+1)) /= MUNKNO)      .OR.  &
                  ABS(MB(KPTIMU+2)) /= 1) THEN
                  KFLAG = -3
                  CALL ZMWARN
                  KRESLT = 12
                  GO TO 130
              ENDIF
          ENDIF
      ENDIF

!             Check for properly normalized digits in the
!             input arguments.

      IF (ABS(MA(1)-INT(MA(1))) /= 0) KFLAG = 1
      IF (ABS(MA(KPTIMU+1)-INT(MA(KPTIMU+1))) /= 0) KFLAG = KPTIMU + 1
      IF (MA(2) <= (-1) .OR. MA(2) >= MBASE .OR.  &
          ABS(MA(2)-INT(MA(2))) /= 0) KFLAG = 2
      IF (MA(KPTIMU+2) <= (-1) .OR. MA(KPTIMU+2) >= MBASE .OR.  &
          ABS(MA(KPTIMU+2)-INT(MA(KPTIMU+2))) /= 0) KFLAG = KPTIMU + 2
      IF (KDEBUG == 0) GO TO 110
      DO J = 3, NDIG+1
         IF (MA(J) < 0 .OR. MA(J) >= MBASE .OR.  &
             ABS(MA(J)-INT(MA(J))) /= 0) THEN
             KFLAG = J
             GO TO 110
         ENDIF
      ENDDO
      DO J = KPTIMU+3, KPTIMU+NDIG+1
         IF (MA(J) < 0 .OR. MA(J) >= MBASE .OR.  &
             ABS(MA(J)-INT(MA(J))) /= 0) THEN
             KFLAG = J
             GO TO 110
         ENDIF
      ENDDO
  110 IF (KFLAG /= 0) THEN
          J = KFLAG
          KFLAG = -4
          KWRNSV = KWARN
          IF (KWARN >= 2) KWARN = 1
          CALL ZMWARN
          KWARN = KWRNSV
          IF (KWARN >= 1) THEN
              IF (J < KPTIMU) THEN
                  WRITE (KW,*) ' First invalid array element:  MA(',  &
                               J,') = ',MA(J)
              ELSE
                  WRITE (KW,*) ' First invalid array element:  MA(',  &
                               KPTIMU,'+',J-KPTIMU,') = ',MA(J)
              ENDIF
          ENDIF
          IF (KWARN >= 2) THEN
              STOP
          ENDIF
          KRESLT = 12
          GO TO 130
      ENDIF
      IF (NARGS == 2) THEN
          IF (ABS(MB(1)-INT(MB(1))) /= 0) KFLAG = 1
          IF (ABS(MB(KPTIMU+1)-INT(MB(KPTIMU+1))) /= 0)  &
              KFLAG = KPTIMU + 1
          IF (MB(2) <= (-1) .OR. MB(2) >= MBASE .OR.  &
              ABS(MB(2)-INT(MB(2))) /= 0) KFLAG = 2
          IF (MB(KPTIMU+2) <= (-1) .OR. MB(KPTIMU+2) >= MBASE .OR.  &
              ABS(MB(KPTIMU+2)-INT(MB(KPTIMU+2))) /= 0)  &
              KFLAG = KPTIMU + 2
          IF (KDEBUG == 0) GO TO 120
          DO J = 3, NDIG+1
             IF (MB(J) < 0 .OR. MB(J) >= MBASE .OR.  &
                 ABS(MB(J)-INT(MB(J))) /= 0) THEN
                 KFLAG = J
                 GO TO 120
             ENDIF
          ENDDO
          DO J = KPTIMU+3, KPTIMU+NDIG+1
             IF (MB(J) < 0 .OR. MB(J) >= MBASE .OR.  &
                 ABS(MB(J)-INT(MB(J))) /= 0) THEN
                 KFLAG = J
                 GO TO 120
             ENDIF
          ENDDO
  120     IF (KFLAG /= 0) THEN
              J = KFLAG
              MBS = MB(J)
              KFLAG = -4
              KWRNSV = KWARN
              IF (KWARN >= 2) KWARN = 1
              CALL ZMWARN
              KWARN = KWRNSV
              IF (KWARN >= 1) THEN
                  IF (J < KPTIMU) THEN
                      WRITE (KW,*) ' First invalid array element:  MB(',  &
                                   J,') = ',MB(J)
                  ELSE
                      WRITE (KW,*) ' First invalid array element:  MB(',  &
                                   KPTIMU,'+',J-KPTIMU,') = ',MB(J)
                  ENDIF
              ENDIF
              IF (KWARN >= 2) THEN
                  STOP
              ENDIF
              KRESLT = 12
              GO TO 130
          ENDIF
      ENDIF

!             Increase the working precision.

  130 NDSAVE = NDIG
      IF (NCALL == 1) THEN
          NDIG = MAX(NDIG+NGRD52,2)
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL ZMWARN
              KRESLT = 12
              NDIG = NDSAVE
          ENDIF
          IF (MBASE >= 100*ABS(MA(2)) .OR.  &
              MBASE >= 100*ABS(MA(KPTIMU+2))) THEN
              NDIG = MIN(NDIG+1,NDG2MX)
          ELSE IF (NARGS == 2 .AND. (MBASE >= 100*ABS(MB(2)) .OR.  &
              MBASE >= 100*ABS(MB(KPTIMU+2)))) THEN
              NDIG = MIN(NDIG+1,NDG2MX)
          ENDIF
      ENDIF
      IF ((MA(1) == MUNKNO .AND. MA(KPTIMU+1) == MUNKNO) .OR.  &
          (MB(1) == MUNKNO .AND. MB(KPTIMU+1) == MUNKNO)) THEN
          KFLAG = -4
          KRESLT = 12
      ENDIF
      IF (KRESLT /= 0) THEN
          NDIG = NDSAVE
          CALL ZMRSLT(MC,KRESLT)
          IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF

      KACCSW = 1

!             Extend the overflow/underflow threshold.

      MXEXP = MXEXP2
      RETURN
      END SUBROUTINE ZMENTR

      SUBROUTINE ZMEQ(MA,MB)

!  MB = MA

!  This is the standard form of equality, where MA and MB both
!  have precision NDIG.  Use ZMEQU for assignments that also
!  change precision.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)

      CALL FMEQ(MA,MB)
      CALL FMEQ(MA(KPTIMU-1),MB(KPTIMU-1))
      RETURN
      END SUBROUTINE ZMEQ

      SUBROUTINE ZMEQ2(MA,MB,NDA,NDB)

!  Set MB (having NDB digits) equal to MA (having NDA digits).

!  If MB has less precision than MA, the result is rounded to
!  NDB digits.

!  If MB has more precision, the result has zero digits padded on the
!  right.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      INTEGER NDA,NDB

      CALL FMEQ2(MA,MB,NDA,NDB)
      CALL FMEQ2(MA(KPTIMU-1),MB(KPTIMU-1),NDA,NDB)
      RETURN
      END SUBROUTINE ZMEQ2

      SUBROUTINE ZMEQ2_R1(MA,NDA,NDB)

!  Change precision of MA from NDA digits on input to NDB digits on output.

!  If NDB is less than NDA the result is rounded to NDB digits.

!  If NDB is greater than NDA the result has zero digits padded on the
!  right.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
      INTEGER NDA,NDB

      CALL FMEQ2_R1(MA,NDA,NDB)
      CALL FMEQ2_R1(MA(KPTIMU-1),NDA,NDB)
      RETURN
      END SUBROUTINE ZMEQ2_R1

      SUBROUTINE ZMEQU(MA,MB,NDA,NDB)

!  Set MB (having NDB digits) equal to MA (having NDA digits).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      INTEGER NDA,NDB

      CALL FMEQ2(MA,MB,NDA,NDB)
      CALL FMEQ2(MA(KPTIMU-1),MB(KPTIMU-1),NDA,NDB)
      RETURN
      END SUBROUTINE ZMEQU

      SUBROUTINE ZMEXIT(MT,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)

!  Upon exit from an ZM routine the result MT (having precision NDIG)
!  is rounded and returned in MC (having precision NDSAVE).
!  The values of NDIG, MXEXP, and KACCSW are restored to the values
!  NDSAVE,MXSAVE,KASAVE.
!  KOVUN is nonzero if one of the routine's input arguments was overflow
!  or underflow.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MT(-1:LUNPKZ),MC(-1:LUNPKZ),MXSAVE
      INTEGER NDSAVE,KASAVE,KOVUN

      INTEGER KFSAVE,KWRNSV

      KWRNSV = KWARN
      KWARN = 0
      MXEXP = MXSAVE
      KFSAVE = KFLAG
      KACCSW = KASAVE
      CALL ZMEQ2(MT,MC,NDIG,NDSAVE)
      IF (KFLAG /= -5 .AND. KFLAG /= -6) KFLAG = KFSAVE
      NDIG = NDSAVE
      KWARN = KWRNSV
      IF (KFLAG == 1) KFLAG = 0
      IF (MC(1) == MEXPUN .OR. MC(KPTIMU+1) == MEXPUN) KFLAG = -6
      IF (MC(1) == MEXPOV .OR. MC(KPTIMU+1) == MEXPOV) KFLAG = -5
      IF (MC(1) == MUNKNO .OR. MC(KPTIMU+1) == MUNKNO) THEN
          IF (KFLAG /= -9) KFLAG = -4
      ENDIF
      IF ((MC(1) == MUNKNO .AND. KFLAG /= -9) .OR.  &
          (MC(KPTIMU+1) == MUNKNO .AND. KFLAG /= -9) .OR.  &
          (MC(1) == MEXPUN .AND. KOVUN == 0) .OR.  &
          (MC(KPTIMU+1) == MEXPUN .AND. KOVUN == 0) .OR.  &
          (MC(1) == MEXPOV .AND. KOVUN == 0) .OR.  &
          (MC(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) CALL ZMWARN
      IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMEXIT

      SUBROUTINE ZMEXI2(MXFM,NDSAVE,MXSAVE,KASAVE,KOVUN)

!  This routine is used upon exit for complex functions that
!  return real FM results.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MXFM(-1:LUNPCK),MXSAVE
      INTEGER NDSAVE,KASAVE,KOVUN

      INTEGER KFSAVE,KWRNSV

      KWRNSV = KWARN
      KWARN = 0
      MXEXP = MXSAVE
      KFSAVE = KFLAG
      KACCSW = KASAVE
      CALL FMEQ2_R1(MXFM,NDIG,NDSAVE)
      IF (KFLAG /= -5 .AND. KFLAG /= -6) KFLAG = KFSAVE
      NDIG = NDSAVE
      KWARN = KWRNSV
      IF (KFLAG == 1) KFLAG = 0
      IF (MXFM(1) == MUNKNO) THEN
          IF (KFLAG >= 0) KFLAG = -4
      ELSE IF (MXFM(1) == MEXPOV) THEN
          KFLAG = -5
      ELSE IF (MXFM(1) == MEXPUN) THEN
          KFLAG = -6
      ENDIF
      IF ((MXFM(1) == MUNKNO .AND. KFLAG /= -9)  &
         .OR. (MXFM(1) == MEXPUN .AND. KOVUN == 0)  &
         .OR. (MXFM(1) == MEXPOV .AND. KOVUN == 0)) CALL ZMWARN
      IF (NTRACE /= 0) CALL ZMNTR2(1,MXFM,MXFM,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMEXI2

      SUBROUTINE ZMEXP(MA,MB)

!  MB = EXP(MA).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,KWRNSV,NDSAVE

      CALL ZMENTR('ZMEXP ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KACCSW = 0
      KRSAVE = KRAD
      KRAD = 1

      CALL ZMEQU(MA,MZ05,NDSAVE,NDIG)

!             Check for special cases.

      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          CALL ZMI2M(1,MZ01)
          GO TO 110
      ELSE IF (MA(2) == 0) THEN
          CALL FMI2M(1,M06)
      ELSE
          CALL FMEXP(MZ05,M06)
      ENDIF

      CALL FMCSSN(MZ05(KPTIMU-1),MZ01,MZ01(KPTIMU-1))

      KWRNSV = KWARN
      KWARN = 0
      CALL FMMPYD(M06,MZ01,MZ01(KPTIMU-1),MZ05,MZ05(KPTIMU-1))
      CALL ZMEQ(MZ05,MZ01)
      KWARN = KWRNSV

  110 MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      KRAD = KRSAVE
      RETURN
      END SUBROUTINE ZMEXP

      SUBROUTINE ZMFORM(FORM1,FORM2,MA,STRING)

!  Convert MA to STRING using FORM1 format for the real part and
!  FORM2 format for the imaginary part.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(*) :: FORM1,FORM2,STRING
      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)

      INTEGER J,KWIDIM,KWIDRE,LAST,LSIGN

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMFORM'
      STRING = ' '
      CALL ZMFPCM(FORM1,MA,KWIDRE,CMBUFZ)
      CALL FMEQ(MA(KPTIMU-1),M02)
      IF (M02(-1) > 0) THEN
          LSIGN = 1
      ELSE
          LSIGN = -1
          IF (M02(1) /= MUNKNO .AND. M02(2) /= 0) M02(-1) = -M02(-1)
      ENDIF
      CALL ZMFPCM(FORM2,M02,KWIDIM,CMBUFF)

      CMBUFZ(KWIDRE+1) = ' '
      IF (LSIGN == 1) THEN
          CMBUFZ(KWIDRE+2) = '+'
      ELSE
          CMBUFZ(KWIDRE+2) = '-'
      ENDIF
      CMBUFZ(KWIDRE+3) = ' '
      DO J = 1, KWIDIM
         CMBUFZ(KWIDRE+3+J) = CMBUFF(J)
      ENDDO
      CMBUFZ(KWIDRE+4+KWIDIM) = ' '
      CMBUFZ(KWIDRE+5+KWIDIM) = 'i'
      IF (JFORMZ == 2) CMBUFZ(KWIDRE+5+KWIDIM) = 'I'
      LAST = KWIDRE + KWIDIM + 5

      IF (M02(1) == MEXPOV .OR. M02(1) == MEXPUN) THEN
          DO J = KWIDRE+3, LAST
             IF (CMBUFZ(J) == 'O' .OR. CMBUFZ(J) == 'U') THEN
                 CMBUFZ(J-2) = ' '
                 EXIT
             ENDIF
          ENDDO
      ENDIF

      IF (LAST <= LEN(STRING)) THEN
          DO J = 1, LAST
             STRING(J:J) = CMBUFZ(J)
          ENDDO
      ELSE
          DO J = 1, LAST
             STRING(J:J) = '*'
          ENDDO
      ENDIF
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMFORM

      SUBROUTINE ZMFPCM(FORM,MA,KWI,CMB)

!  Internal routine to convert MA to base 10 using FORM format.
!  The result is returned in CMB and the field width is KWI.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(*) :: FORM
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      INTEGER KWI
      CHARACTER CMB(LMBUFF)
      CHARACTER(20) :: FORMB
      INTEGER J,JF1SAV,JF2SAV,JPT,K1,K2,K3,KD,KWD,KSAVE,LAST,LB,  &
              LENGFM,LFIRST,ND,NEXP

      KSAVE = KFLAG
      JF1SAV = JFORM1
      JF2SAV = JFORM2
      LENGFM = LEN(FORM)
      KWI = 75
      KWD = 40
      IF (INDEX(FORM,'I') > 0 .OR. INDEX(FORM,'i') > 0) THEN
          K1 = MAX(INDEX(FORM,'I'),INDEX(FORM,'i')) + 1
          K2 = LENGFM
          WRITE (FORMB,"('(I',I5,')')") K2-K1+1
          IF (K2 >= K1) THEN
              READ (FORM(K1:K2),FORMB) KWI
          ELSE
              KWI = 50
          ENDIF
          KWI = MAX(1,MIN(KWI,LMBUFF-11))
          JFORM1 = 2
          JFORM2 = 0
          KWD = KWI + 11
          CALL FMNINT(MA,M03)
          IF (M03(2) /= 0) THEN
              CALL FMOUT(M03,CMB,KWD)
          ELSE
              DO J = 1, KWD
                 CMB(J) = ' '
              ENDDO
              CMB(2) = '0'
          ENDIF
          LFIRST = 1
          LAST = 1
          DO J = 1, KWD
             IF (CMB(KWD+1-J) /= ' ') LFIRST = KWD+1-J
             IF (CMB(J) /= ' ') LAST = J
          ENDDO
          JPT = 1
          IF (LAST-LFIRST+1 > KWI) GO TO 110
          IF (LAST <= KWI) THEN
              DO J = LAST, LFIRST, -1
                 JPT = KWI - LAST + J
                 CMB(JPT) = CMB(J)
              ENDDO
              DO J = 1, JPT-1
                 CMB(J) = ' '
              ENDDO
          ELSE
              DO J = LFIRST, LAST
                 JPT = KWI - LAST + J
                 CMB(JPT) = CMB(J)
              ENDDO
          ENDIF
      ELSE IF (INDEX(FORM,'F') > 0 .OR. INDEX(FORM,'f') > 0) THEN
          K1 = MAX(INDEX(FORM,'F'),INDEX(FORM,'f')) + 1
          K2 = INDEX(FORM(1:LENGFM),'.')
          K3 = LENGFM
          IF (K2 > K1) THEN
              WRITE (FORMB,"('(I',I5,')')") K2-K1
              READ (FORM(K1:K2-1),FORMB) KWI
          ELSE
              KWI = 50
          ENDIF
          IF (K3 > K2) THEN
              WRITE (FORMB,"('(I',I5,')')") K3-K2
              READ (FORM(K2+1:K3),FORMB) KD
          ELSE
              KD = 0
          ENDIF
          KWI = MAX(1,MIN(KWI,LMBUFF))
          KD = MAX(0,MIN(KD,KWI-2))
          JFORM1 = 2
          JFORM2 = KD
          ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
          IF (ND < 2) ND = 2
          NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
          LB = MAX(JFORM2+NEXP,ND+NEXP)
          LB = MIN(LB,LMBUFF)
          KWD = LB
          CALL FMOUT(MA,CMB,KWD)
          LFIRST = 1
          LAST = 1
          DO J = 1, KWD
             IF (CMB(KWD+1-J) /= ' ') LFIRST = KWD+1-J
             IF (CMB(J) /= ' ') LAST = J
          ENDDO
          IF (LAST-LFIRST+1 > KWI) THEN

!             Not enough room for this F format, or FMOUT converted
!             it to E format to avoid showing no significant digits.
!             See if a shortened form will fit in E format.

              NEXP = INT(LOG10((ABS(MA(1))+1)*LOG10(DBLE(MBASE))+1)+1)
              ND = KWI - NEXP - 5
              IF (ND < 1) THEN
                  GO TO 110
              ELSE
                  JFORM1 = 0
                  JFORM2 = ND
                  CALL FMOUT(MA,CMB,KWI)
                  LFIRST = 1
                  LAST = 1
                  DO J = 1, KWI
                     IF (CMB(KWI+1-J) /= ' ') LFIRST = KWI+1-J
                     IF (CMB(J) /= ' ') LAST = J
                  ENDDO
              ENDIF
          ENDIF
          JPT = 1
          IF (LAST <= KWI) THEN
              DO J = LAST, LFIRST, -1
                 JPT = KWI - LAST + J
                 CMB(JPT) = CMB(J)
              ENDDO
              DO J = 1, JPT-1
                 CMB(J) = ' '
              ENDDO
          ELSE
              DO J = LFIRST, LAST
                 JPT = KWI - LAST + J
                 CMB(JPT) = CMB(J)
              ENDDO
          ENDIF
      ELSE IF (INDEX(FORM,'1PE') > 0 .OR. INDEX(FORM,'1pe') > 0) THEN
          K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1
          K2 = INDEX(FORM(1:LENGFM),'.')
          K3 = LENGFM
          IF (K2 > K1) THEN
              WRITE (FORMB,"('(I',I5,')')") K2-K1
              READ (FORM(K1:K2-1),FORMB) KWI
          ELSE
              KWI = 50
          ENDIF
          IF (K3 > K2) THEN
              WRITE (FORMB,"('(I',I5,')')") K3-K2
              READ (FORM(K2+1:K3),FORMB) KD
          ELSE
              KD = 0
          ENDIF
          KWI = MAX(1,MIN(KWI,LMBUFF))
          KD = MAX(0,MIN(KD,KWI-2))
          JFORM1 = 1
          JFORM2 = KD
          CALL FMOUT(MA,CMB,KWI)
      ELSE IF (INDEX(FORM,'E') > 0 .OR. INDEX(FORM,'e') > 0) THEN
          K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1
          K2 = INDEX(FORM(1:LENGFM),'.')
          K3 = LENGFM
          IF (K2 > K1) THEN
              WRITE (FORMB,"('(I',I5,')')") K2-K1
              READ (FORM(K1:K2-1),FORMB) KWI
          ELSE
              KWI = 50
          ENDIF
          IF (K3 > K2) THEN
              WRITE (FORMB,"('(I',I5,')')") K3-K2
              READ (FORM(K2+1:K3),FORMB) KD
          ELSE
              KD = 0
          ENDIF
          KWI = MAX(1,MIN(KWI,LMBUFF))
          KD = MAX(0,MIN(KD,KWI-2))
          JFORM1 = 0
          JFORM2 = KD
          CALL FMOUT(MA,CMB,KWI)
      ELSE
          GO TO 110
      ENDIF

      JFORM1 = JF1SAV
      JFORM2 = JF2SAV
      KFLAG = KSAVE
      RETURN

!             Error condition.

  110 KFLAG = -8
      DO J = 1, KWI
         CMB(J) = '*'
      ENDDO
      JFORM1 = JF1SAV
      JFORM2 = JF2SAV
      KFLAG = KSAVE
      RETURN
      END SUBROUTINE ZMFPCM

      SUBROUTINE ZMFPRT(FORM1,FORM2,MA)

!  Print MA in base 10 using FORM1 format for the real part and
!  FORM2 format for the imaginary part.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(*) :: FORM1,FORM2
      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)

      CHARACTER(20) :: FORM
      INTEGER J,K,KWIDIM,KWIDRE,LAST,LSIGN

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMFPRT'

      CALL ZMFPCM(FORM1,MA,KWIDRE,CMBUFZ)
      CALL FMEQ(MA(KPTIMU-1),M02)
      IF (M02(-1) >= 0) THEN
          LSIGN = 1
      ELSE
          LSIGN = -1
          IF (M02(1) /= MUNKNO .AND. M02(2) /= 0) M02(-1) = -M02(-1)
      ENDIF
      CALL ZMFPCM(FORM2,M02,KWIDIM,CMBUFF)

      CMBUFZ(KWIDRE+1) = ' '
      IF (LSIGN == 1) THEN
          CMBUFZ(KWIDRE+2) = '+'
      ELSE
          CMBUFZ(KWIDRE+2) = '-'
      ENDIF
      CMBUFZ(KWIDRE+3) = ' '
      DO J = 1, KWIDIM
         CMBUFZ(KWIDRE+3+J) = CMBUFF(J)
      ENDDO
      CMBUFZ(KWIDRE+4+KWIDIM) = ' '
      CMBUFZ(KWIDRE+5+KWIDIM) = 'i'
      IF (JFORMZ == 2) CMBUFZ(KWIDRE+5+KWIDIM) = 'I'
      LAST = KWIDRE + KWIDIM + 5

      IF (M02(1) == MEXPOV .OR. M02(1) == MEXPUN) THEN
          DO J = KWIDRE+3, LAST
             IF (CMBUFZ(J) == 'O' .OR. CMBUFZ(J) == 'U') THEN
                 CMBUFZ(J-2) = ' '
                 EXIT
             ENDIF
          ENDDO
      ENDIF

      WRITE (FORM,"(' (6X,',I3,'A1) ')") KSWIDE-7
      WRITE (KW,FORM) (CMBUFZ(K),K=1,LAST)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMFPRT

      SUBROUTINE ZMI2M(INTEG,MA)

!  MA = INTEG

!  The real part of MA is set to the one word integer value INTEG.
!  The imaginary part is set to zero.

      USE FMVALS
      IMPLICIT NONE

      INTEGER INTEG
      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMI2M '
      IF (NTRACE /= 0) CALL ZMNTRI(2,INTEG,1)

      CALL FMI2M(INTEG,MA)
      CALL FMI2M(0,MA(KPTIMU-1))

      IF (NTRACE /= 0) CALL ZMNTR(1,MA,MA,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMI2M

      SUBROUTINE ZM2I2M(INTEG1,INTEG2,MA)

!  MA = INTEG1 + INTEG2 i

      USE FMVALS
      IMPLICIT NONE

      INTEGER INTEG1,INTEG2
      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZM2I2M'
      IF (NTRACE /= 0) THEN
          CALL ZMNTRI(2,INTEG1,1)
          CALL ZMNTRI(2,INTEG2,0)
      ENDIF

      CALL FMI2M(INTEG1,MA)
      CALL FMI2M(INTEG2,MA(KPTIMU-1))

      IF (NTRACE /= 0) CALL ZMNTR(1,MA,MA,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZM2I2M

      SUBROUTINE ZMIMAG(MA,MBFM)

!  MBFM = IMAG(MA)        imaginary part of MA

!  MA is a complex ZM number, MBFM is a real FM number.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MBFM(-1:LUNPCK)

      KFLAG = 0
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMIMAG'
      IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)

      CALL FMEQ(MA(KPTIMU-1),MBFM)

      IF (NTRACE /= 0) CALL FMNTR(1,MBFM,MBFM,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMIMAG

      SUBROUTINE ZMINP(LINE,MA,LA,LB)

!  Convert an A1 character string to floating point multiple precision
!  complex format.

!  LINE is an A1 character array of length LB to be converted
!       to ZM format and returned in MA.
!  LA is a pointer telling the routine where in the array to begin
!     the conversion.  This allows more than one number to be stored
!     in an array and converted in place.
!  LB is a pointer to the last character of the field for that number.

!  The input numbers may be in integer or any real format.
!  In exponential format the 'E' may also be 'D', 'Q', or 'M'.

!  The following are all valid input strings:

!  1.23 + 4.56 I
!  1.23 + 4.56*I
!  2 + i
!  -i
!  1.23
!  4.56i
!  ( 1.23 , 4.56 )

!  So that ZMINP will convert any output from ZMOUT, LINE is tested
!  to see if the input contains any of the special symbols +OVERFLOW,
!  -OVERFLOW, +UNDERFLOW, -UNDERFLOW, or UNKNOWN.
!  For user input the abbreviations OVFL, UNFL, UNKN may be used.

      USE FMVALS
      IMPLICIT NONE

      INTEGER LA,LB
      CHARACTER LINE(LB)
      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
      INTEGER J,JSTATE,K,KASAVE,KDIGFL,KFLAG1,KIFLAG,KPT,  &
              KRSAVE,KSIGN,KSTART,KSTOP,KSTOPI,KSTOPR,KSTRTI,KSTRTR,  &
              KTYPE,KVAL,NDSAVE,NTRSAV

!  Simulate a finite-state automaton to scan the input line
!  and build the number.  States 2-8 refer to the real part,
!  states 10-16 refer to the imaginary part.
!  States of the machine:

!   1.  Initial entry to the subroutine
!   2.  Sign of the number
!   3.  Scanning digits before a decimal point
!   4.  Decimal point
!   5.  Scanning digits after a decimal point
!   6.  E, D, Q, or M - precision indicator before the exponent
!   7.  Sign of the exponent
!   8.  Scanning exponent
!   9.  Comma between the real and imaginary part
!  10.  Sign of the number
!  11.  Scanning digits before a decimal point
!  12.  Decimal point
!  13.  Scanning digits after a decimal point
!  14.  E, D, Q, or M - precision indicator before the exponent
!  15.  Sign of the exponent
!  16.  Scanning exponent
!  17.  Syntax error

!  Character types recognized by the machine:

!  1.  Sign (+,-)
!  2.  Numeral (0,1,...,9)
!  3.  Decimal point (.)
!  4.  Precision indicator (E,D,Q,M)
!  5.  Illegal character for number
!  6.  Comma (,)
!  7.  Character to be ignored   ' '    '('    ')'    '*'

!  All blanks are ignored.  The analysis of the number proceeds as
!  follows:  If the simulated machine is in state JSTATE and a character
!  of type JTYPE is encountered the new state of the machine is given by
!  JTRANS(JSTATE,JTYPE).

!  State  1   2   3   4   5   6   7   8   9  10  11  12  13  14  15  16

      INTEGER :: JTRANS(16,4) = RESHAPE(  (/    &
          2, 17, 10, 10, 10,  7, 17, 10, 10, 17, 17, 17, 17, 15, 17, 17,  &
          3,  3,  3,  5,  5,  8,  8,  8, 11, 11, 11, 13, 13, 16, 16, 16,  &
          4,  4,  4, 17, 17, 17, 17, 17, 12, 12, 12, 17, 17, 17, 17, 17,  &
          6,  6,  6,  6,  6,  8, 17, 17, 14, 14, 14, 14, 14, 16, 17, 17   /)  &
        , (/ 16,4 /) )

      IF (MBLOGS /= MBASE) CALL FMCONS
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMINP '
      NDSAVE = NDIG
      KASAVE = KACCSW
      KRSAVE = KROUND
      KROUND = 1
      KFLAG = 0

!             Initialize two hash tables that are used for character
!             look-up during input conversion.

      IF (LHASH == 0) CALL FMHTBL

!             Since arithmetic tracing is not usually desired during
!             I/O conversion, disable tracing during this routine.

      NTRSAV = NTRACE
      NTRACE = 0

!             Increase the working precision.

      IF (NCALL <= 2) THEN
          K = NGRD52
          NDIG = MAX(NDIG+K,2)
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL ZMWARN
              MA(-1) = 1
              MA(0) = NINT(NDSAVE*ALOGM2)
              MA(1) = MUNKNO
              MA(2) = 1
              MA(KPTIMU-1) = 1
              MA(KPTIMU) = NINT(NDSAVE*ALOGM2)
              MA(KPTIMU+1) = MUNKNO
              MA(KPTIMU+2) = 1
              DO J = 2, NDSAVE
                 MA(J+1) = 0
                 MA(KPTIMU+J+1) = 0
              ENDDO
              GO TO 110
          ENDIF
      ENDIF
      KSTART = LA
      KSTOP = LB
      JSTATE = 1
      KSTRTR = 0
      KSTOPR = 0
      KSTRTI = 0
      KSTOPI = 0
      KDIGFL = 0
      KIFLAG = 0
      KSIGN = 1

!             Scan the number.

      DO J = KSTART, KSTOP
         IF (LINE(J) == ' ' .OR. LINE(J) == '(' .OR. LINE(J) == ')'  &
             .OR. LINE(J) == '*') CYCLE
         IF (LINE(J) == 'I' .OR. LINE(J) == 'i') THEN
             KIFLAG = 1
             IF (KSTRTI == 0) THEN
                 KSTRTI = KSTRTR
                 KSTOPI = KSTOPR
                 KSTRTR = 0
                 KSTOPR = 0
             ENDIF
             CYCLE
         ENDIF

         KPT = ICHAR(LINE(J))
         IF (KPT < LHASH1 .OR. KPT > LHASH2) THEN
             WRITE (KW,  &
                "(/' Error in input conversion.'/"                        //  &
                "' ICHAR function was out of range for the current',"     //  &
                "' dimensions.'/' ICHAR(''',A,''') gave the value ',"     //  &
                "I12,', which is outside the currently'/' dimensioned',"  //  &
                "' bounds of (',I5,':',I5,') for variables KHASHT ',"     //  &
                "'and KHASHV.'/' Re-define the two parameters ',"         //  &
                "'LHASH1 and LHASH2 so the dimensions will'/' contain',"  //  &
                "' all possible output values from ICHAR.'//)"                &
                   ) LINE(J),KPT,LHASH1,LHASH2
             KTYPE = 5
             KVAL  = 0
         ELSE
             KTYPE = KHASHT(KPT)
             KVAL  = KHASHV(KPT)
         ENDIF
         IF (KTYPE == 2 .OR. KTYPE == 5) KDIGFL = 1
         IF (LINE(J) == ',') THEN
             IF (JSTATE < 9) THEN
                 JSTATE = 9
             ELSE
                 GO TO 120
             ENDIF
         ELSE
             IF (KTYPE >= 5) KTYPE = 2
             IF (JSTATE < 17) JSTATE = JTRANS(JSTATE,KTYPE)
         ENDIF
         IF (JSTATE == 9 .OR. JSTATE == 10) KDIGFL = 0
         IF (JSTATE == 2 .OR. JSTATE == 10) KSIGN = KVAL

         IF (JSTATE >= 2 .AND. JSTATE <= 8) THEN
             IF (KSTRTR == 0) KSTRTR = J
             KSTOPR = J
         ENDIF
         IF (JSTATE >= 10 .AND. JSTATE <= 16) THEN
             IF (KSTRTI == 0) KSTRTI = J
             KSTOPI = J
         ENDIF

      ENDDO

!             Form the number and return.

      IF (KSTRTR > 0) THEN
          CALL FMINP(LINE,MA,KSTRTR,KSTOPR)
      ELSE
          CALL FMIM(0,MA)
      ENDIF
      KFLAG1 = KFLAG

      IF (KSTRTI > 0) THEN
          IF (KIFLAG == 1 .AND. KDIGFL == 0) THEN
              CALL FMIM(KSIGN,MA(KPTIMU-1))
          ELSE
              CALL FMINP(LINE,MA(KPTIMU-1),KSTRTI,KSTOPI)
          ENDIF
      ELSE IF (KIFLAG == 1) THEN
          CALL FMIM(1,MA(KPTIMU-1))
      ELSE
          CALL FMIM(0,MA(KPTIMU-1))
      ENDIF

      IF (KFLAG1 /= 0 .OR. KFLAG /= 0 .OR. JSTATE == 17) GO TO 120

  110 NDIG = NDSAVE
      KACCSW = KASAVE
      NTRACE = NTRSAV
      KROUND = KRSAVE
      IF (KFLAG == 1) KFLAG = 0
      MA(0) = NINT(NDIG*ALOGM2)
      MA(KPTIMU) = MA(0)
      NCALL = NCALL - 1
      RETURN

!             Error in converting the number.

  120 KFLAG = -7
      CALL ZMWARN
      MA(-1) = 1
      MA(0) = NINT(NDIG*ALOGM2)
      MA(1) = MUNKNO
      MA(2) = 1
      MA(KPTIMU-1) = 1
      MA(KPTIMU) = NINT(NDIG*ALOGM2)
      MA(KPTIMU+1) = MUNKNO
      MA(KPTIMU+2) = 1
      DO J = 2, NDSAVE
         MA(J+1) = 0
         MA(KPTIMU+J+1) = 0
      ENDDO
      GO TO 110
      END SUBROUTINE ZMINP

      SUBROUTINE ZMINT(MA,MB)

!  MB = INT(MA)

!  The integer parts of both real and imaginary values are returned.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMINT '
      IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)

      CALL FMINT(MA,MB)
      CALL FMINT(MA(KPTIMU-1),MB(KPTIMU-1))

      IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMINT

      SUBROUTINE ZMIPWR(MA,IVAL,MB)

!  MB = MA ** IVAL

!  Raise a ZM number to an integer power.
!  The binary multiplication method used requires an average of
!  1.5 * LOG2(IVAL) multiplications.

      USE FMVALS
      IMPLICIT NONE

      INTEGER IVAL
      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MA2,MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER I2N,K,KASAVE,KOVUN,KWRNSV,LVLSAV,NDSAVE
      REAL XVAL

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMIPWR'
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          CALL ZMNTR(2,MA,MA,1)
          CALL FMNTRI(2,IVAL,0)
      ENDIF
      KOVUN = 0
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN .OR.  &
          MA(KPTIMU+1) == MEXPOV .OR. MA(KPTIMU+1) == MEXPUN) KOVUN = 1

      IF (MBLOGS /= MBASE) CALL FMCONS
      KFLAG = 0
      KASAVE = KACCSW
      MXSAVE = MXEXP
      MXEXP = MXEXP2

!             Check for special cases.

      IF (MA(1) == MUNKNO .OR. MA(KPTIMU+1) == MUNKNO .OR.  &
          (IVAL <= 0 .AND. MA(2) == 0 .AND. MA(KPTIMU+2) == 0)) THEN
          MA2 = MA(2)
          KFLAG = -4
          IF (IVAL <= 0 .AND. MA2 == 0) CALL ZMWARN
          CALL ZMST2M('UNKNOWN+UNKNOWN*i',MB)
          IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
          NCALL = NCALL - 1
          MXEXP = MXSAVE
          RETURN
      ENDIF

      IF (IVAL == 0) THEN
          CALL ZMI2M(1,MB)
          IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
          NCALL = NCALL - 1
          MXEXP = MXSAVE
          RETURN
      ENDIF

      IF (ABS(IVAL) == 1) THEN
          KWRNSV = KWARN
          KWARN = 0
          IF (IVAL == 1) THEN
              CALL ZMEQ(MA,MB)
          ELSE
              K = INT((5.0D0*DLOGTN)/DLOGMB + 2.0D0)
              NDIG = MIN(MAX(NDIG+K,2),NDG2MX)
              IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
                  IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
              ENDIF
              CALL ZMI2M(1,MZ02)
              CALL ZMEQU(MA,MZ05,NDSAVE,NDIG)
              CALL ZMDIV(MZ02,MZ05,MB)
              CALL ZMEQ2_R1(MB,NDIG,NDSAVE)
              NDIG = NDSAVE
          ENDIF
          IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
          NCALL = NCALL - 1
          KWARN = KWRNSV
          MXEXP = MXSAVE
          RETURN
      ENDIF

      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          CALL ZMI2M(0,MB)
          IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
          NCALL = NCALL - 1
          MXEXP = MXSAVE
          RETURN
      ENDIF

      IF (MA(KPTIMU+2) == 0) THEN
          NCALL = NCALL - 1
          LVLSAV = LVLTRC
          LVLTRC = LVLTRC - 1
          CALL FMIPWR(MA,IVAL,MB)
          CALL FMIM(0,MB(KPTIMU-1))
          NCALL = NCALL + 1
          LVLTRC = LVLSAV
          IF (NTRACE /= 0) THEN
              NAMEST(NCALL) = 'ZMIPWR'
              CALL ZMNTR(1,MB,MB,1)
          ENDIF
          NCALL = NCALL - 1
          MXEXP = MXSAVE
          RETURN
      ENDIF

      IF (MA(2) == 0) THEN
          NCALL = NCALL - 1
          LVLSAV = LVLTRC
          LVLTRC = LVLTRC - 1
          IF (IVAL >= 0) THEN
              I2N = MOD(IVAL,4)
          ELSE
              I2N = MOD(4 - MOD(ABS(IVAL),4),4)
          ENDIF
          IF (I2N == 0) THEN
              CALL FMIPWR(MA(KPTIMU-1),IVAL,MB)
              CALL FMIM(0,MB(KPTIMU-1))
          ELSE IF (I2N == 1) THEN
              CALL FMIPWR(MA(KPTIMU-1),IVAL,MB(KPTIMU-1))
              CALL FMIM(0,MB)
          ELSE IF (I2N == 2) THEN
              CALL FMIPWR(MA(KPTIMU-1),IVAL,MB)
              CALL FMIM(0,MB(KPTIMU-1))
              IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
          ELSE IF (I2N == 3) THEN
              CALL FMIPWR(MA(KPTIMU-1),IVAL,MB(KPTIMU-1))
              CALL FMIM(0,MB)
              IF (MB(KPTIMU+1) /= MUNKNO .AND. MB(KPTIMU+2) /= 0)  &
                  MB(KPTIMU-1) = -MB(KPTIMU-1)
          ENDIF
          NCALL = NCALL + 1
          LVLTRC = LVLSAV
          IF (NTRACE /= 0) THEN
              NAMEST(NCALL) = 'ZMIPWR'
              CALL ZMNTR(1,MB,MB,1)
          ENDIF
          NCALL = NCALL - 1
          MXEXP = MXSAVE
          RETURN
      ENDIF

!             Increase the working precision.

      IF (NCALL == 1) THEN
          XVAL = ABS(IVAL) + 1
          K = INT((5.0*REAL(DLOGTN) + 1.5*LOG(XVAL))/ALOGMB + 2.0)
          NDIG = MAX(NDIG+K,2)
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
          ENDIF
      ELSE
          XVAL = ABS(IVAL) + 1
          K = INT(LOG(XVAL)/ALOGMB + 1.0)
          NDIG = NDIG + K
      ENDIF
      IF (NDIG > NDG2MX) THEN
          KFLAG = -9
          CALL ZMWARN
          NDIG = NDSAVE
          CALL ZMST2M('UNKNOWN+UNKNOWN*i',MB)
          IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
          MXEXP = MXSAVE
          KACCSW = KASAVE
          NCALL = NCALL - 1
          RETURN
      ENDIF

!             Initialize.

      KWRNSV = KWARN
      KWARN = 0
      K = ABS(IVAL)

      CALL ZMEQ2(MA,MZ02,NDSAVE,NDIG)

      IF (MOD(K,2) == 0) THEN
          CALL ZMI2M(1,MB)
      ELSE
          CALL ZMEQ(MZ02,MB)
      ENDIF

!             This is the multiplication loop.

  110 K = K/2
      CALL ZMSQR(MZ02,MZ08)
      CALL ZMEQ(MZ08,MZ02)
      IF (MOD(K,2) == 1) THEN
          CALL ZMMPY(MZ02,MB,MZ08)
          CALL ZMEQ(MZ08,MB)
      ENDIF
      IF (K > 1) GO TO 110

!             Invert if the exponent is negative.

      IF (IVAL < 0) THEN
          CALL ZMI2M(1,MZ02)
          CALL ZMDIV(MZ02,MB,MZ08)
          CALL ZMEQ(MZ08,MB)
      ENDIF
      KWARN = KWRNSV

!             Round the result and return.

      MACCMB = MB(0)
      MB(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MB(KPTIMU)
      MB(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      CALL ZMEQ(MB,MZ01)
      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE ZMIPWR

      SUBROUTINE ZMLG10(MA,MB)

!  MB = LOG10(MA).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE

      CALL ZMENTR('ZMLG10',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KACCSW = 0
      KRSAVE = KRAD
      KRAD = 1

      CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
      CALL ZMLN(MZ07,MZ02)
      CALL FMLNI(10,M03)
      CALL FMDIVD(MZ02,MZ02(KPTIMU-1),M03,MZ01,MZ01(KPTIMU-1))

      MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      KRAD = KRSAVE
      RETURN
      END SUBROUTINE ZMLG10

      SUBROUTINE ZMLN(MA,MB)

!  MB = LN(MA).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER KASAVE,KF1,KOVUN,KRESLT,KRSAVE,NDSAVE
      LOGICAL FMCOMP

      CALL ZMENTR('ZMLN  ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KACCSW = 0
      KRSAVE = KRAD
      KRAD = 1

      CALL ZMEQU(MA,MZ06,NDSAVE,NDIG)

!             Check for special cases.

      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          KFLAG = -4
          CALL ZMST2M('UNKNOWN+UNKNOWN*i',MZ01)
          GO TO 110
      ELSE IF (MA(KPTIMU+2) == 0) THEN
          IF (MA(-1) < 0) THEN
              CALL FMEQ(MZ06,MZ01)
              IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
              CALL FMLN(MZ01,M13)
              CALL FMEQ(M13,MZ01)
              CALL FMPI(MZ01(KPTIMU-1))
          ELSE
              CALL FMLN(MZ06,MZ01)
              CALL FMI2M(0,MZ01(KPTIMU-1))
          ENDIF
          GO TO 110
      ELSE IF (MA(2) == 0) THEN
          IF (MA(KPTIMU-1) < 0) THEN
              CALL FMEQ(MZ06(KPTIMU-1),MZ01)
              IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
              CALL FMLN(MZ01,M13)
              CALL FMEQ(M13,MZ01)
              CALL FMPI(MZ01(KPTIMU-1))
              CALL FMDIVI_R1(MZ01(KPTIMU-1),-2)
          ELSE
              CALL FMLN(MZ06(KPTIMU-1),MZ01)
              CALL FMPI(MZ01(KPTIMU-1))
              CALL FMDIVI_R1(MZ01(KPTIMU-1),2)
          ENDIF
          GO TO 110
      ENDIF

!             Ln(a + b i) = Ln(Abs(a + b i)) + Arg(a + b i) i.

      CALL FMABS(MZ06,M03)
      CALL FMABS(MZ06(KPTIMU-1),M04)

!             Check for cancellation in Ln(x).

      CALL FMI2M(1,M05)
      KF1 = 0
      IF (FMCOMP(M03,'EQ',M05) .AND. M04(1) <= (-NDIG)) KF1 = 1
      IF (FMCOMP(M04,'EQ',M05) .AND. M03(1) <= (-NDIG)) KF1 = 1

      IF (FMCOMP(M03,'GE',M04)) THEN
          CALL FMSUB(MZ06,M05,M03)
          CALL FMADD(MZ06,M05,M04)
          CALL FMMPY_R1(M03,M04)
          CALL FMSQR(MZ06(KPTIMU-1),M04)
          CALL FMADD_R2(M03,M04)
      ELSE
          CALL FMSUB(MZ06(KPTIMU-1),M05,M03)
          CALL FMADD(MZ06(KPTIMU-1),M05,M04)
          CALL FMMPY_R1(M03,M04)
          CALL FMSQR(MZ06,M04)
          CALL FMADD_R2(M03,M04)
      ENDIF
      CALL ZMABS(MZ06,MZ01)
      CALL FMADD(MZ01,M05,M03)
      CALL FMDIV_R2(M04,M03)
      IF (KF1 == 1) THEN
          CALL FMEQ(M03,MZ01)
          CALL FMATN2(MZ06(KPTIMU-1),MZ06,MZ01(KPTIMU-1))
          GO TO 110
      ELSE IF (M03(1) < 0) THEN
          NDIG = NDIG - INT(M03(1))
          IF (NDIG > NDG2MX) THEN
              NAMEST(NCALL) = 'ZMLN  '
              KFLAG = -9
              CALL ZMWARN
              KRESLT = 12
              NDIG = NDSAVE
              CALL ZMRSLT(MB,KRESLT)
              IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
              NCALL = NCALL - 1
              MXEXP = MXSAVE
              KACCSW = KASAVE
              RETURN
          ENDIF
          CALL ZMEQ2_R1(MZ06,NDSAVE,NDIG)
          CALL ZMABS(MZ06,MZ01)
      ENDIF

      CALL FMLN(MZ01,M13)
      CALL FMEQ(M13,MZ01)
      CALL FMATN2(MZ06(KPTIMU-1),MZ06,MZ01(KPTIMU-1))

  110 MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      KRAD = KRSAVE
      RETURN
      END SUBROUTINE ZMLN

      SUBROUTINE ZMM2I(MA,INTEG)

!  INTEG = MA

!  INTEG is set to the integer value of the real part of MA

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
      INTEGER INTEG

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMM2I '
      IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)

      CALL FMM2I(MA,INTEG)

      IF (NTRACE /= 0) CALL ZMNTRI(1,INTEG,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMM2I

      SUBROUTINE ZMM2Z(MA,ZVAL)

!  ZVAL = MA

!  Complex variable ZVAL is set to MA.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
      COMPLEX ZVAL

      REAL DI,DR

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMM2Z '
      IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)

      CALL FMM2SP(MA,DR)
      CALL FMM2SP(MA(KPTIMU-1),DI)
      ZVAL = CMPLX(DR,DI)

      IF (NTRACE /= 0) CALL ZMNTRZ(1,ZVAL,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMM2Z

      SUBROUTINE ZMMPY(MA,MB,MC)

!  MC = MA * MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MBIZ,MBRZ,MXSAVE,MZ11SV
      INTEGER IEXTRA,KASAVE,KMETHD,KOVUN,KRESLT,KWRNSV,NDGSV2,NDSAVE,  &
              NGOAL,NTRSAV

      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR.  &
          ABS(MB(1)) > MEXPAB .OR. ABS(MB(KPTIMU+1)) > MEXPAB .OR.  &
          KDEBUG >= 1) THEN
          CALL ZMENTR('ZMMPY ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          IF (NTRACE /= 0) THEN
              NAMEST(NCALL) = 'ZMMPY '
              CALL ZMNTR(2,MA,MB,2)
          ENDIF
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              NDIG = MAX(NDIG+NGRD52,2)
              IF (NDIG > NDG2MX) THEN
                  NAMEST(NCALL) = 'ZMMPY '
                  KFLAG = -9
                  CALL ZMWARN
                  KRESLT = 12
                  NDIG = NDSAVE
                  CALL ZMRSLT(MC,KRESLT)
                  IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
              IF (MBASE >= 100*ABS(MA(2)) .OR.  &
                  MBASE >= 100*ABS(MA(KPTIMU+2))) THEN
                  NDIG = MIN(NDIG+1,NDG2MX)
              ELSE IF (MBASE >= 100*ABS(MB(2)) .OR.  &
                  MBASE >= 100*ABS(MB(KPTIMU+2))) THEN
                  NDIG = MIN(NDIG+1,NDG2MX)
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 1
          MXSAVE = MXEXP
          MXEXP = MXEXP2
          KOVUN = 0
      ENDIF
      IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
          IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
      ENDIF

      MARZ = MA(0)
      MBRZ = MB(0)
      MAIZ = MA(KPTIMU)
      MBIZ = MB(KPTIMU)
      MZ11SV = -MUNKNO
      NTRSAV = NTRACE
      NTRACE = 0
      KWRNSV = KWARN
      KWARN = 0

  110 CALL FMEQU(MA,M17,NDSAVE,NDIG)
      CALL FMEQU(MA(KPTIMU-1),M18,NDSAVE,NDIG)
      CALL FMEQU(MB,M19,NDSAVE,NDIG)
      CALL FMEQU(MB(KPTIMU-1),M20,NDSAVE,NDIG)
      IF (NCALL == 1) THEN
          M17(0) = NINT(NDIG*ALOGM2)
          M19(0) = M17(0)
          M18(00) = M17(0)
          M20(00) = M17(0)
      ENDIF

!             Check for special cases.

      KMETHD = 1
      IF (NDIG >= 35) KMETHD = 2

      IF (MB(KPTIMU+2) == 0) THEN
          CALL FMMPYD(M19,M17,M18,MZ01,MZ01(KPTIMU-1))
      ELSE IF (MB(2) == 0) THEN
          CALL FMMPYD(M20,M18,M17,MZ01,MZ01(KPTIMU-1))
          IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
      ELSE IF (MA(KPTIMU+2) == 0) THEN
          CALL FMMPYD(M17,M19,M20,MZ01,MZ01(KPTIMU-1))
      ELSE IF (MA(2) == 0) THEN
          CALL FMMPYD(M18,M20,M19,MZ01,MZ01(KPTIMU-1))
          IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
      ELSE IF (KMETHD == 1) THEN

!             Method 1 for  ( a + b i ) * ( c + d i )

!             result = a*c - b*d + ( a*d + b*c ) i

          KACCSW = 0
          CALL FMMPYD(M17,M19,M20,MZ01,MZ01(KPTIMU-1))
          CALL FMMPYD(M18,M20,M19,M01,M02)
          IF (MZ01(-1)*M01(-1) < 0) THEN
              KACCSW = 0
          ELSE
              KACCSW = 1
          ENDIF
          CALL FMSUB_R1(MZ01,M01)
          IF (MZ01(KPTIMU-1)*M02(-1) < 0) THEN
              KACCSW = 1
          ELSE
              KACCSW = 0
          ENDIF
          CALL FMADD_R1(MZ01(KPTIMU-1),M02)
          KACCSW = 1
      ELSE

!             Method 2 for  ( a + b i ) * ( c + d i )

!             P = ( a + b )*( c + d )
!             result = a*c - b*d + ( P - a*c - b*d ) i

          CALL FMADD(M17,M18,M01)
          CALL FMADD(M19,M20,M02)
          CALL FMMPY_R1(M01,M02)

          CALL FMMPY(M17,M19,M02)
          CALL FMMPY(M18,M20,M03)

          CALL FMSUB(M02,M03,MZ01)
          CALL FMSUB(M01,M02,MZ01(KPTIMU-1))
          CALL FMSUB_R1(MZ01(KPTIMU-1),M03)
      ENDIF

!             Check for too much cancellation.

      IF (NCALL <= 1) THEN
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7
      ELSE
          NGOAL = INT(-MXEXP2)
      ENDIF
      IF (MZ01(0) <= NGOAL .OR. MZ01(KPTIMU) <= NGOAL) THEN
          IF (MZ11SV > -MUNKNO .AND. MZ01(0) > NGOAL .AND.  &
              MZ01(KPTIMU+2) == 0) GO TO 120
          IF (MZ11SV > -MUNKNO .AND. MZ01(KPTIMU) > NGOAL .AND.  &
              MZ01(2) == 0) GO TO 120
          IEXTRA = INT(REAL(MAX(NGOAL-MZ01(0),NGOAL-MZ01(KPTIMU)))  &
                   /ALOGM2 + 23.03/ALOGMB) + 1
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              NAMEST(NCALL) = 'ZMMPY '
              KFLAG = -9
              CALL ZMWARN
              NDIG = NDSAVE
              CALL ZMST2M('UNKNOWN+UNKNOWN*i',MZ01)
              GO TO 120
          ENDIF
          MZ11SV = MZ01(1)
          GO TO 110
      ENDIF

  120 MXEXP = MXSAVE
      NTRACE = NTRSAV
      NDGSV2 = NDIG
      NDIG = NDSAVE
      KWARN = KWRNSV
      MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)
      CALL ZMEQ2(MZ01,MC,NDGSV2,NDSAVE)
      IF (MC(1) >= MEXPOV .OR. MC(1) <= -MEXPOV .OR.  &
          MC(KPTIMU+1) >= MEXPOV .OR. MC(KPTIMU+1) <= -MEXPOV) THEN
          IF (MC(1) == MUNKNO .OR. MC(KPTIMU+1) == MUNKNO) THEN
              KFLAG = -4
          ELSE IF (MC(1) == MEXPOV .OR. MC(KPTIMU+1) == MEXPOV) THEN
              KFLAG = -5
          ELSE IF (MC(1) == MEXPUN .OR. MC(KPTIMU+1) == MEXPUN) THEN
              KFLAG = -6
          ENDIF
          IF ((MC(1) == MUNKNO)  &
             .OR. (MC(KPTIMU+1) == MUNKNO)  &
             .OR. (MC(1) == MEXPUN .AND. KOVUN == 0)  &
             .OR. (MC(KPTIMU+1) == MEXPUN .AND. KOVUN == 0)  &
             .OR. (MC(1) == MEXPOV .AND. KOVUN == 0)  &
             .OR. (MC(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
              NAMEST(NCALL) = 'ZMMPY '
              CALL ZMWARN
          ENDIF
      ENDIF
      IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
      KACCSW = KASAVE
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMMPY

      SUBROUTINE ZMMPYI(MA,INTEG,MB)

!  MB = MA * INTEG        Multiply by one-word (real) integer.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      INTEGER INTEG

      INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV
      REAL (KIND(1.0D0)) :: MXSAVE

      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR.  &
          KDEBUG >= 1) THEN
          NTRSAV = NTRACE
          IF (NTRACE /= 0) THEN
              NCALL = NCALL + 1
              NAMEST(NCALL) = 'ZMMPYI'
              CALL ZMNTR(2,MA,MA,1)
              CALL FMNTRI(2,INTEG,0)
              NCALL = NCALL - 1
          ENDIF
          NTRACE = 0
          CALL ZMENTR('ZMMPYI',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          NTRACE = NTRSAV
          IF (KRESLT /= 0) THEN
              NCALL = NCALL + 1
              IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
              NCALL = NCALL - 1
              RETURN
          ENDIF
          NDIG = NDSAVE
          MXEXP = MXSAVE
          KACCSW = KASAVE
          NTRSAV = NTRACE
      ELSE
          NCALL = NCALL + 1
          IF (NTRACE /= 0) THEN
              NAMEST(NCALL) = 'ZMMPYI'
              CALL ZMNTR(2,MA,MA,1)
              CALL FMNTRI(2,INTEG,0)
          ENDIF
          KOVUN = 0
      ENDIF

!             Force FMMPYI to use more guard digits for user calls.

      NCALL = NCALL - 1
      NTRSAV = NTRACE
      NTRACE = 0
      KWRNSV = KWARN
      KWARN = 0

      CALL FMMPYI(MA,INTEG,MB)
      CALL FMMPYI(MA(KPTIMU-1),INTEG,MB(KPTIMU-1))

      NTRACE = NTRSAV
      KWARN = KWRNSV
      NCALL = NCALL + 1
      IF (NTRACE /= 0) NAMEST(NCALL) = 'ZMMPYI'
      IF (MB(1) == MUNKNO .OR. MB(KPTIMU+1) == MUNKNO) THEN
          KFLAG = -4
      ELSE IF (MB(1) == MEXPOV .OR. MB(KPTIMU+1) == MEXPOV) THEN
          KFLAG = -5
      ELSE IF (MB(1) == MEXPUN .OR. MB(KPTIMU+1) == MEXPUN) THEN
          KFLAG = -6
      ENDIF
      IF ((MB(1) == MUNKNO)  &
         .OR. (MB(KPTIMU+1) == MUNKNO)  &
         .OR. (MB(1) == MEXPUN .AND. KOVUN == 0)  &
         .OR. (MB(KPTIMU+1) == MEXPUN .AND. KOVUN == 0)  &
         .OR. (MB(1) == MEXPOV .AND. KOVUN == 0)  &
         .OR. (MB(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
          NAMEST(NCALL) = 'ZMMPYI'
          CALL ZMWARN
      ENDIF
      IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMMPYI

      SUBROUTINE ZMNINT(MA,MB)

!  MB = NINT(MA)

!  The nearest integers to both real and imaginary parts are returned.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMNINT'
      IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)

      CALL FMNINT(MA,MB)
      CALL FMNINT(MA(KPTIMU-1),MB(KPTIMU-1))

      IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMNINT

      SUBROUTINE ZMNTR(NTR,MA,MB,NARG)

!  Print ZM numbers in base 10 format using ZMOUT for conversion.
!  This is used for trace output from the ZM routines.

!  NTR =  1 if a result of an ZM call is to be printed.
!      =  2 to print input argument(s) to an ZM call.

!  MA  -  the ZM number to be printed.

!  MB  -  an optional second ZM number to be printed.

!  NARG - the number of arguments.  NARG = 1 if only MA is to be
!         printed, and NARG = 2 if both MA and MB are to be printed.


!  NTRACE and LVLTRC (in module FMVALS) control trace printout.

!  NTRACE = 0        No printout except warnings and errors.

!  NTRACE = 1        The result of each call to one of the routines
!                    is printed in base 10, using ZMOUT.

!  NTRACE = -1       The result of each call to one of the routines
!                    is printed in internal base MBASE format.

!  NTRACE = 2        The input arguments and result of each call to one
!                    of the routines is printed in base 10, using ZMOUT.

!  NTRACE = -2       The input arguments and result of each call to one
!                    of the routines is printed in base MBASE format.

!  LVLTRC defines the call level to which the trace is done.  LVLTRC = 1
!         means only FM routines called directly by the user are traced,
!         LVLTRC = K prints traces for ZM or FM routines with call
!         levels up to and including level K.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      INTEGER NTR,NARG

      CHARACTER(6) :: NAME

      IF (NTRACE == 0) RETURN
      IF (NCALL > LVLTRC) RETURN
      IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN

      IF (NTR == 2) THEN
          NAME = NAMEST(NCALL)
          WRITE (KW,"(' Input to ',A6)") NAME
      ELSE
          NAME = NAMEST(NCALL)
          IF (KFLAG == 0) THEN
              WRITE (KW,  &
                     "(' ',A6,15X,'Call level =',I2,5X,'MBASE =',"  //  &
                     "I10,5X,'NDIG =',I6)"                              &
                    ) NAME,NCALL,INT(MBASE),NDIG
          ELSE
              WRITE (KW,  &
                     "(' ',A6,6X,'Call level =',I2,4X,'MBASE =',"  //  &
                     "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)"             &
                    ) NAME,NCALL,INT(MBASE),NDIG,KFLAG
          ENDIF
      ENDIF

!             Check for base MBASE internal format trace.

      IF (NTRACE < 0) THEN
          CALL ZMNTRJ(MA,NDIG)
          IF (NARG == 2) CALL ZMNTRJ(MB,NDIG)
      ENDIF

!             Check for base 10 trace using ZMOUT.

      IF (NTRACE > 0) THEN
          CALL ZMPRNT(MA)

          IF (NARG == 2) THEN
              CALL ZMPRNT(MB)
          ENDIF
      ENDIF

      RETURN
      END SUBROUTINE ZMNTR

      SUBROUTINE ZMNTR2(NTR,MAFM,MBFM,NARG)

!  Print real FM numbers in base 10 format using FMOUT for conversion.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MAFM(-1:LUNPCK),MBFM(-1:LUNPCK)
      INTEGER NTR,NARG

      CHARACTER(6) :: NAME

      IF (NTRACE == 0) RETURN
      IF (NCALL > LVLTRC) RETURN
      IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN

      IF (NTR == 2) THEN
          NAME = NAMEST(NCALL)
          WRITE (KW,"(' Input to ',A6)") NAME
      ELSE
          NAME = NAMEST(NCALL)
          IF (KFLAG == 0) THEN
              WRITE (KW,  &
                     "(' ',A6,15X,'Call level =',I2,5X,'MBASE =',"  //  &
                     "I10,5X,'NDIG =',I6)"                              &
                    ) NAME,NCALL,INT(MBASE),NDIG
          ELSE
              WRITE (KW,  &
                     "(' ',A6,6X,'Call level =',I2,4X,'MBASE =',"  //  &
                     "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)"             &
                    ) NAME,NCALL,INT(MBASE),NDIG,KFLAG
          ENDIF
      ENDIF

!             Check for base MBASE internal format trace.

      IF (NTRACE < 0) THEN
          CALL FMNTRJ(MAFM,NDIG)
          IF (NARG == 2) CALL FMNTRJ(MBFM,NDIG)
      ENDIF

!             Check for base 10 trace using FMOUT.

      IF (NTRACE > 0) THEN
          CALL FMPRNT(MAFM)

          IF (NARG == 2) THEN
              CALL FMPRNT(MBFM)
          ENDIF
      ENDIF

      RETURN
      END SUBROUTINE ZMNTR2

      SUBROUTINE ZMNTRI(NTR,N,KNAM)

!  Internal routine for trace output of integer variables.

!  NTR = 1 for output values
!        2 for input values

!  N     Integer to be printed.

!  KNAM  is positive if the routine name is to be printed.

      USE FMVALS
      IMPLICIT NONE

      INTEGER NTR,N,KNAM

      CHARACTER(6) :: NAME

      IF (NTRACE == 0) RETURN
      IF (NCALL > LVLTRC) RETURN
      IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN

      IF (NTR == 2 .AND. KNAM > 0) THEN
          NAME = NAMEST(NCALL)
          WRITE (KW,"(' Input to ',A6)") NAME
      ENDIF
      IF (NTR == 1 .AND. KNAM > 0) THEN
          NAME = NAMEST(NCALL)
          IF (KFLAG == 0) THEN
              WRITE (KW,  &
                     "(' ',A6,15X,'Call level =',I2,5X,'MBASE =',"  //  &
                     "I10,5X,'NDIG =',I6)"                              &
                    ) NAME,NCALL,INT(MBASE),NDIG
          ELSE
              WRITE (KW,  &
                     "(' ',A6,6X,'Call level =',I2,4X,'MBASE =',"  //  &
                     "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)"             &
                    ) NAME,NCALL,INT(MBASE),NDIG,KFLAG
          ENDIF
      ENDIF

      WRITE (KW,"(1X,I18)") N

      RETURN
      END SUBROUTINE ZMNTRI

      SUBROUTINE ZMNTRJ(MA,ND)

!  Print trace output in internal base MBASE format.  The number to
!  be printed is in MA.

!  ND is the number of base MBASE digits to be printed.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
      INTEGER ND

      CHARACTER(50) :: FORM
      INTEGER J,L,N,N1

      N1 = ND + 1

      L = INT(LOG10(DBLE(MBASE-1))) + 2
      N = (KSWIDE-23)/L
      IF (N > 10) N = 5*(N/5)
      IF (ND <= N) THEN
          WRITE (FORM,"(' (1X,I19,I',I2,',',I3,'I',I2,') ')") L+2, N-1, L
      ELSE
          WRITE (FORM,  &
                 "(' (1X,I19,I',I2,',',I3,'I',I2,"  //  &
                 "'/(22X,',I3,'I',I2,')) ')"            &
                ) L+2, N-1, L, N, L
      ENDIF
      WRITE (KW,FORM) INT(MA(1)),INT(MA(-1)*MA(2)),(INT(MA(J)),J=3,N1)
      WRITE (KW,FORM) INT(MA(KPTIMU+1)),INT(MA(KPTIMU-1)*MA(KPTIMU+2)),  &
                      (INT(MA(KPTIMU+J)),J=3,N1)

      RETURN
      END SUBROUTINE ZMNTRJ

      SUBROUTINE ZMNTRZ(NTR,X,KNAM)

!  Internal routine for trace output of complex variables.

!  NTR - 1 for output values
!        2 for input values

!  X   - Complex value to be printed if NX == 1

!  KNAM - Positive if the routine name is to be printed.

      USE FMVALS
      IMPLICIT NONE

      INTEGER NTR,KNAM
      COMPLEX X

      CHARACTER(6) :: NAME
      DOUBLE PRECISION XREAL,XIMAG

      IF (NTRACE == 0) RETURN
      IF (NCALL > LVLTRC) RETURN
      IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN

      IF (NTR == 2 .AND. KNAM > 0) THEN
          NAME = NAMEST(NCALL)
          WRITE (KW,"(' Input to ',A6)") NAME
      ENDIF
      IF (NTR == 1 .AND. KNAM > 0) THEN
          NAME = NAMEST(NCALL)
          IF (KFLAG == 0) THEN
              WRITE (KW,  &
                     "(' ',A6,15X,'Call level =',I2,5X,'MBASE =',"  //  &
                     "I10,5X,'NDIG =',I6)"                              &
                    ) NAME,NCALL,INT(MBASE),NDIG
          ELSE
              WRITE (KW,  &
                     "(' ',A6,6X,'Call level =',I2,4X,'MBASE =',"  //  &
                     "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)"             &
                    ) NAME,NCALL,INT(MBASE),NDIG,KFLAG
          ENDIF
      ENDIF

      XREAL = DBLE(X)
      XIMAG = DBLE(AIMAG(X))
      IF (XIMAG >= 0.0D0) THEN
          WRITE (KW,"(1X,D30.20,' +',D30.20,' i')") XREAL,XIMAG
      ELSE
          WRITE (KW,"(1X,D30.20,' -',D30.20,' i')") XREAL,ABS(XIMAG)
      ENDIF

      RETURN
      END SUBROUTINE ZMNTRZ

      SUBROUTINE ZMOUT(MA,LINE,LB,LAST1,LAST2)

!  Convert a floating multiple precision number to a character array
!  for output.

!  MA    is an ZM number to be converted to an A1 character
!        array in base 10 format
!  LINE  is the CHARACTER*1 array in which the result is returned.
!  LB    is the length of LINE.
!  LAST1 is the position of the last nonblank character of the
!        real part of the number in LINE.
!  LAST2 is the position of the last nonblank character of the
!        imaginary part of the number in LINE.

!  JFORM1 and JFORM2 determine the format of the two FM numbers
!  making up the complex value MA.  See FMOUT for details.

!  JFORMZ determines the format of the real and imaginary parts.

!  JFORMZ = 1  normal setting :       1.23 - 4.56 i
!         = 2  use capital I  :       1.23 - 4.56 I
!         = 3  parenthesis format   ( 1.23 , -4.56 )

!  LINE should be dimensioned at least 4*(LOG10(MBASE)*NDIG + 15) on a
!  32-bit machine to allow for up to 10 digit exponents.  Replace
!  15 by 20 if 48-bit integers are used, 25 for 64-bit integers, etc.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MI(-1:LUNPCK)
      INTEGER LB,LAST1,LAST2
      CHARACTER LINE(LB)

      REAL (KIND(1.0D0)) :: MAIMS
      INTEGER J,KPT,LB2,ND,NEXP

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMOUT '
      DO J = 1, LB
         LINE(J) = ' '
      ENDDO
      ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
      IF (ND < 2) ND = 2
      NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
      KPT = 1
      IF (JFORMZ == 3) KPT = 3
      LB2 = MAX(JFORM2+NEXP,ND+NEXP)
      LB2 = MIN(LB+1-KPT,LB2)
      CALL FMOUT(MA,LINE(KPT),LB2)

      IF (JFORMZ == 3) LINE(1) = '('
      LAST1 = 1
      DO J = LB2, 1, -1
         IF (LINE(J) /= ' ') THEN
             LAST1 = J
             GO TO 110
         ENDIF
      ENDDO

  110 MAIMS = MA(KPTIMU-1)
      DO J = -1, NDIG+1
         MI(J) = MA(KPTIMU+J)
      ENDDO
      LINE(LAST1+1) = ' '
      IF (JFORMZ == 3) THEN
          LINE(LAST1+2) = ','
      ELSE
          IF (MAIMS < 0) THEN
              MI(-1) = 1
              LINE(LAST1+2) = '-'
          ELSE
              LINE(LAST1+2) = '+'
          ENDIF
      ENDIF

      KPT = LAST1 + 3
      LB2 = MAX(JFORM2+NEXP,ND+NEXP)
      LB2 = MIN(LB+1-KPT,LB2+2)
      CALL FMOUT(MI,LINE(KPT),LB2)
      LAST1 = KPT
      DO J = LB2+KPT-1, KPT, -1
         IF (LINE(J) /= ' ') THEN
             LAST2 = J
             GO TO 120
         ENDIF
      ENDDO

  120 LAST2 = LAST2 + 2
      LINE(LAST2) = 'i'
      IF (JFORMZ == 2) LINE(LAST2) = 'I'
      IF (JFORMZ == 3) LINE(LAST2) = ')'

      IF (LINE(KPT) == ' ' .AND. LINE(KPT+1) == '+') THEN
          DO J = KPT+2, LAST2
             LINE(J-2) = LINE(J)
          ENDDO
          LINE(LAST2-1) = ' '
          LINE(LAST2) = ' '
          LAST2 = LAST2 - 2
      ENDIF

      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMOUT

      SUBROUTINE ZMPACK(MA,MP)

!  MA is packed two base NDIG digits per word and returned in MP.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MP(-1:LPACKZ)
      CALL FMPACK(MA,MP)
      CALL FMPACK(MA(KPTIMU-1),MP(KPTIMP))
      RETURN
      END SUBROUTINE ZMPACK

      SUBROUTINE ZMPRNT(MA)

!  Print MA in base 10 format.

!  ZMPRNT can be called directly by the user for easy output
!  in M format.  MA is converted using ZMOUT and printed.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)

      CHARACTER(20) :: FORM
      INTEGER K,KSAVE,LAST1,LAST2,LB,LBZ,ND,NEXP

      KSAVE = KFLAG
      ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
      IF (ND < 2) ND = 2
      NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
      LB = MAX(JFORM2+NEXP,ND+NEXP)

      IF (2*LB+7 <= LMBUFZ .AND. JPRNTZ == 1) THEN
          LBZ = 2*LB + 7
          CALL ZMOUT(MA,CMBUFZ,LBZ,LAST1,LAST2)
          WRITE (FORM,"(' (6X,',I3,'A1) ')") KSWIDE-7
          WRITE (KW,FORM) (CMBUFZ(K),K=1,LAST2)
      ELSE
          CALL FMPRNT(MA)
          CALL FMPRNT(MA(KPTIMU-1))
      ENDIF
      KFLAG = KSAVE
      RETURN
      END SUBROUTINE ZMPRNT

      SUBROUTINE ZMPWR(MA,MB,MC)

!  MC = MA ** MB.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ)
!                                                 MZ06, MZ07

      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MBIZ,MBRZ,MXSAVE,MTEMP
      INTEGER IEXTRA,INTMB,J,JSIN,JCOS,JSWAP,K,KASAVE,KOVUN,  &
              KRADSV,KRESLT,KWRNSV,NDSAVE
      LOGICAL FMCOMP
      REAL XVAL

      CALL ZMENTR('ZMPWR ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      MARZ = MA(0)
      MBRZ = MB(0)
      MAIZ = MA(KPTIMU)
      MBIZ = MB(KPTIMU)
      KACCSW = 0
      NDIG = MIN(NDIG+1,NDG2MX)
      IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
          IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
      ENDIF

      CALL ZMEQU(MA,MZ06,NDSAVE,NDIG)
      CALL ZMEQU(MB,MZ07,NDSAVE,NDIG)

!             Check for special cases.

      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          IF (MB(-1) > 0 .AND. MB(KPTIMU+2) == 0) THEN
              CALL ZMI2M(0,MZ02)
              GO TO 110
          ELSE
              KFLAG = -4
              CALL ZMST2M('UNKNOWN+UNKNOWN*i',MZ02)
              GO TO 110
          ENDIF
      ENDIF
      IF (MB(KPTIMU+2) == 0) THEN
          KWRNSV = KWARN
          KWARN = 0
          CALL FMMI(MZ07,INTMB)
          KWARN = KWRNSV
          IF (KFLAG == 0) THEN
              IF (NCALL == 1) THEN
                  XVAL = ABS(INTMB) + 1
                  K = INT((1.5*LOG(XVAL))/ALOGMB + 2.0)
                  NDIG = MAX(NDIG+K,2)
                  IF (NDIG > NDG2MX) THEN
                      KFLAG = -9
                      CALL ZMWARN
                      NDIG = NDSAVE
                      CALL ZMST2M('UNKNOWN+UNKNOWN*i',MC)
                      IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
                      NCALL = NCALL - 1
                      RETURN
                  ENDIF
                  IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
                      NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
                  ENDIF
                  IF (MBASE >= 100*ABS(MA(2)) .OR.  &
                      MBASE >= 100*ABS(MA(KPTIMU+2))) THEN
                      NDIG = MIN(NDIG+1,NDG2MX)
                  ENDIF
              ENDIF
              CALL ZMEQ2_R1(MZ06,NDSAVE,NDIG)
              CALL ZMIPWR(MZ06,INTMB,MZ03)
              CALL ZMEQ(MZ03,MZ02)
              GO TO 110
          ENDIF
      ENDIF

!             Check for cases where ABS(MA) is very close to 1, and
!             avoid cancellation.

      CALL FMABS(MZ06,M03)
      CALL FMABS(MZ06(KPTIMU-1),M04)
      CALL FMI2M(1,M05)
      IF (FMCOMP(M03,'EQ',M05) .AND.  &
          (M04(1) <= (-NDIG).OR.M04(2) == 0)) THEN
          IF (MA(-1) > 0) THEN

!                 (1+c)**b = 1 + b*c + ...

              CALL ZMI2M(1,MZ02)
              CALL ZMSUB(MZ06,MZ02,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              CALL ZMMPY(MZ07,MZ02,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              CALL FMADD_R1(MZ02,M05)
          ELSE

!                 (-1+c)**b = (-1)**b * (1 - b*c + ... )

              CALL ZMI2M(-1,MZ02)
              CALL ZMSUB(MZ06,MZ02,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              CALL ZMMPY(MZ07,MZ02,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              CALL ZMMPYI(MZ02,-1,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              CALL FMADD_R1(MZ02,M05)
              KRADSV = KRAD
              KRAD = 0
              IF (MA(KPTIMU-1) >= 0) THEN
                  CALL FMMPYI(MZ07,180,M06)
              ELSE
                  CALL FMMPYI(MZ07,-180,M06)
              ENDIF
              CALL FMCSSN(M06,MZ03,MZ03(KPTIMU-1))
              KRAD = KRADSV
              CALL FMPI(M05)
              CALL FMMPY_R1(M05,MZ07(KPTIMU-1))
              IF (MA(KPTIMU-1) >= 0) CALL FMMPYI_R1(M05,-1)
              CALL FMEXP(M05,M12)
              CALL FMEQ(M12,M05)
              CALL FMMPYD(M05,MZ03,MZ03(KPTIMU-1),MZ08,MZ08(KPTIMU-1))
              CALL ZMEQ(MZ08,MZ03)
              CALL ZMMPY(MZ02,MZ03,MZ08)
              CALL ZMEQ(MZ08,MZ02)
          ENDIF
          GO TO 110
      ENDIF
      IF (FMCOMP(M04,'EQ',M05) .AND.  &
          (M03(1) <= (-NDIG).OR.M03(2) == 0)) THEN
          IF (MA(KPTIMU-1) > 0) THEN

!                 (i+c)**b = i**b * (1 - b*c*i - ... )

              CALL ZM2I2M(0,1,MZ02)
              CALL ZMSUB(MZ06,MZ02,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              CALL ZMMPY(MZ07,MZ02,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              DO J = -1, NDIG+1
                 MTEMP = MZ02(J)
                 MZ02(J) = MZ02(KPTIMU+J)
                 MZ02(KPTIMU+J) = MTEMP
              ENDDO
              IF (MZ02(KPTIMU+1) /= MUNKNO .AND. MZ02(KPTIMU+2) /= 0)  &
                  MZ02(KPTIMU-1) = -MZ02(KPTIMU-1)
              CALL FMADD_R1(MZ02,M05)
              KRADSV = KRAD
              KRAD = 0
              CALL FMMPYI(MZ07,90,M06)
              CALL FMCSSN(M06,MZ03,MZ03(KPTIMU-1))
              KRAD = KRADSV
              CALL FMPI(M05)
              CALL FMMPY_R1(M05,MZ07(KPTIMU-1))
              CALL FMDIVI_R1(M05,-2)
              CALL FMEXP(M05,M12)
              CALL FMEQ(M12,M05)
              CALL FMMPYD(M05,MZ03,MZ03(KPTIMU-1),MZ08,MZ08(KPTIMU-1))
              CALL ZMEQ(MZ08,MZ03)
              CALL ZMMPY(MZ02,MZ03,MZ08)
              CALL ZMEQ(MZ08,MZ02)
          ELSE

!                 (-i+c)**b = (-i)**b * (1 + b*c*i - ... )

              CALL ZM2I2M(0,-1,MZ02)
              CALL ZMSUB(MZ06,MZ02,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              CALL ZMMPY(MZ07,MZ02,MZ08)
              CALL ZMEQ(MZ08,MZ02)
              DO J = -1, NDIG+1
                 MTEMP = MZ02(J)
                 MZ02(J) = MZ02(KPTIMU+J)
                 MZ02(KPTIMU+J) = MTEMP
              ENDDO
              IF (MZ02(1) /= MUNKNO .AND. MZ02(2) /= 0) MZ02(-1) = -MZ02(-1)
              CALL FMADD_R1(MZ02,M05)
              KRADSV = KRAD
              KRAD = 0
              CALL FMMPYI(MZ07,-90,M06)
              CALL FMCSSN(M06,MZ03,MZ03(KPTIMU-1))
              KRAD = KRADSV
              CALL FMPI(M05)
              CALL FMMPY_R1(M05,MZ07(KPTIMU-1))
              CALL FMDIVI_R1(M05,2)
              CALL FMEXP(M05,M12)
              CALL FMEQ(M12,M05)
              CALL FMMPYD(M05,MZ03,MZ03(KPTIMU-1),MZ08,MZ08(KPTIMU-1))
              CALL ZMEQ(MZ08,MZ03)
              CALL ZMMPY(MZ02,MZ03,MZ08)
              CALL ZMEQ(MZ08,MZ02)
          ENDIF
          GO TO 110
      ENDIF

      CALL ZMLN(MZ06,MZ02)
      CALL ZMMPY(MZ07,MZ02,MZ08)
      CALL ZMEQ(MZ08,MZ02)
      KWRNSV = KWARN
      KWARN = 0
      CALL FMEQ(MZ02(KPTIMU-1),MZ01)
      CALL FMRDC(MZ01,JSIN,JCOS,JSWAP)
      KWARN = KWRNSV
      IF (KFLAG == -9) THEN
          IEXTRA = INT(MZ01(1))
      ELSE
          IEXTRA = INT(MZ02(KPTIMU+1) - MZ01(1))
      ENDIF
      IF (IEXTRA > 1) THEN
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL ZMWARN
              NDIG = NDIG - IEXTRA
              CALL ZMST2M('UNKNOWN+UNKNOWN*i',MZ02)
              GO TO 110
          ENDIF
          CALL ZMEQ2_R1(MZ06,NDSAVE,NDIG)
          CALL ZMEQ2_R1(MZ07,NDSAVE,NDIG)
          CALL ZMLN(MZ06,MZ02)
          CALL ZMMPY(MZ07,MZ02,MZ08)
          CALL ZMEQ(MZ08,MZ02)
      ENDIF

      CALL ZMEXP(MZ02,MZ06)
      CALL ZMEQ(MZ06,MZ02)

  110 MACCMB = MZ02(0)
      MZ02(0) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)
      MACCMB = MZ02(KPTIMU)
      MZ02(KPTIMU) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)
      CALL ZMEXIT(MZ02,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE ZMPWR

      SUBROUTINE ZMREAD(KREAD,MA)

!  Read MA on unit KREAD.  Multi-line numbers will have '&' as the
!  last nonblank character on all but the last line.  Only one
!  number is allowed on the line(s).

      USE FMVALS
      IMPLICIT NONE

      INTEGER KREAD
      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)

      CHARACTER LINE(80)
      INTEGER J,LB

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMREAD'
      LB = 0

  110 READ (KREAD,"(80A1)",ERR=120,END=120) LINE

!             Scan the line and look for '&'

      DO J = 1, 80
         IF (LINE(J) == '&') GO TO 110
         IF (LINE(J) /= ' ') THEN
             LB = LB + 1
             IF (LB > LMBUFZ) THEN
                 KFLAG = -8
                 GO TO 130
             ENDIF
             CMBUFZ(LB) = LINE(J)
          ENDIF
      ENDDO

      CALL ZMINP(CMBUFZ,MA,1,LB)

      NCALL = NCALL - 1
      RETURN

!             If there is an error, return UNKNOWN.

  120 KFLAG = -4
  130 CALL ZMWARN
      CALL ZMST2M('UNKNOWN+UNKNOWN*i',MA)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMREAD

      SUBROUTINE ZMREAL(MA,MBFM)

!  MBFM = REAL(MA)

!  MA is a complex ZM number, MBFM is a real FM number.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MBFM(-1:LUNPCK)

      KFLAG = 0
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMREAL'
      IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)

      CALL FMEQ(MA,MBFM)

      IF (NTRACE /= 0) CALL FMNTR(1,MBFM,MBFM,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMREAL

      SUBROUTINE ZMRPWR(MA,IVAL,JVAL,MB)

!  MB = MA ** (IVAL/JVAL)

!  Raise a ZM number to a rational power.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      INTEGER IVAL,JVAL
      REAL (KIND(1.0D0)) :: MA2,MACCMB,MAIZ,MARZ,MR1,MXSAVE
      INTEGER IJSIGN,INVERT,IVAL2,J,JVAL2,K,KASAVE,KOVUN,KST,L,LVAL,  &
              NDSAVE
      REAL XVAL

      DOUBLE PRECISION AR,BR,F,THETA,X
      INTEGER NSTACK(19)

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMRPWR'
      NDSAVE = NDIG
      IF (NTRACE /= 0) THEN
          CALL ZMNTR(2,MA,MA,1)
          CALL FMNTRI(2,IVAL,0)
          CALL FMNTRI(2,JVAL,0)
      ENDIF
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KOVUN = 0
      IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN .OR.  &
          MA(KPTIMU+1) == MEXPOV .OR. MA(KPTIMU+1) == MEXPUN) KOVUN = 1

      IF (MBLOGS /= MBASE) CALL FMCONS
      KFLAG = 0
      IJSIGN = 1
      IVAL2 = ABS(IVAL)
      JVAL2 = ABS(JVAL)
      IF (IVAL > 0 .AND. JVAL < 0) IJSIGN = -1
      IF (IVAL < 0 .AND. JVAL > 0) IJSIGN = -1
      IF (IVAL2 > 0 .AND. JVAL2 > 0) CALL FMGCDI(IVAL2,JVAL2)

!             Check for special cases.

      IF (MA(1) == MUNKNO .OR. MA(KPTIMU+1) == MUNKNO .OR.  &
          (IJSIGN <= 0 .AND. MA(2) == 0 .AND. MA(KPTIMU+2) == 0) .OR.  &
          JVAL == 0) THEN
          MA2 = MA(2)
          KFLAG = -4
          IF (IVAL <= 0 .AND. MA2 == 0) CALL ZMWARN
          CALL ZMST2M('UNKNOWN+UNKNOWN*i',MB)
          IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF

      IF (IVAL == 0) THEN
          CALL ZMI2M(1,MB)
          IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF

!             Increase the working precision.

      IF (NCALL == 1) THEN
          XVAL = MAX(ABS(IVAL),ABS(JVAL)) + 1
          K = INT((5.0*REAL(DLOGTN) + LOG(XVAL))/ALOGMB + 2.0)
          NDIG = MAX(NDIG+K,2)
          IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
              NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
          ENDIF
      ELSE
          XVAL = MAX(ABS(IVAL),ABS(JVAL)) + 1
          K = INT(LOG(XVAL)/ALOGMB + 1.0)
          NDIG = NDIG + K
      ENDIF
      IF (NDIG > NDG2MX) THEN
          KFLAG = -9
          CALL ZMWARN
          NDIG = NDSAVE
          CALL ZMST2M('UNKNOWN+UNKNOWN*i',MB)
          IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF
      IF (MBASE >= 100*ABS(MA(2)) .OR.  &
          MBASE >= 100*ABS(MA(KPTIMU+2))) THEN
          NDIG = MIN(NDIG+1,NDG2MX)
      ENDIF
      KASAVE = KACCSW
      MXSAVE = MXEXP
      MXEXP = MXEXP2

      CALL ZMEQ2(MA,MZ04,NDSAVE,NDIG)
      IF (IVAL2 == 1 .AND. JVAL2 == 2) THEN
          CALL ZMSQRT(MZ04,MB)
          GO TO 110
      ENDIF

!             Generate the first approximation to MA**(1/JVAL2).

      CALL ZMI2M(0,MB)
      CALL FMDIG(NSTACK,KST)
      NDIG = NSTACK(1)
      CALL FMSQR(MZ04,MZ03)
      CALL FMSQR(MZ04(KPTIMU-1),M03)
      CALL FMADD_R1(MZ03,M03)
      CALL FMSQRT_R1(MZ03)
      IF (MZ03(1) >= MEXPOV) THEN
          KFLAG = -4
          CALL ZMWARN
          MXEXP = MXSAVE
          KACCSW = KASAVE
          NDIG = NDSAVE
          CALL ZMST2M('UNKNOWN+UNKNOWN*i',MB)
          IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
          NCALL = NCALL - 1
          RETURN
      ENDIF

!             Invert MA if ABS(MA) > 1 and IVAL or JVAL is large.

      INVERT = 0
      IF (IVAL > 5 .OR. JVAL > 5) THEN
          IF (MZ03(1) > 0) THEN
              INVERT = 1
              NDIG = NSTACK(KST)
              CALL ZMI2M(1,MB)
              CALL ZMDIV(MB,MZ04,MZ08)
              CALL ZMEQ(MZ08,MZ04)
              NDIG = NSTACK(1)
              CALL FMDIV_R2(MB,MZ03)
          ENDIF
      ENDIF

      CALL FMDIV(MZ04,MZ03,M03)
      CALL FMM2DP(M03,AR)
      CALL FMDIV(MZ04(KPTIMU-1),MZ03,M03)
      CALL FMM2DP(M03,BR)
      MR1 = MZ03(1)
      MZ03(1) = 0
      CALL FMM2DP(MZ03,X)
      L = INT(MR1/JVAL2)
      F = MR1/DBLE(JVAL2) - L
      X = X**(1.0D0/JVAL2) * DBLE(MBASE)**F
      CALL FMDPM(X,M03)
      M03(1) = M03(1) + L

      THETA = ATAN2(BR,AR)
      X = COS(THETA/JVAL2)
      CALL FMDPM(X,MB)
      X = SIN(THETA/JVAL2)
      CALL FMDPM(X,MB(KPTIMU-1))
      CALL FMMPY_R2(M03,MB)
      CALL FMMPY_R2(M03,MB(KPTIMU-1))

!             Newton iteration.

      DO J = 1, KST
         NDIG = NSTACK(J)
         IF (J < KST) NDIG = NDIG + 1
         LVAL = JVAL2 - 1
         CALL ZMIPWR(MB,LVAL,MZ03)
         CALL ZMDIV(MZ04,MZ03,MZ08)
         CALL ZMEQ(MZ08,MZ03)
         CALL ZMMPYI(MB,LVAL,MZ08)
         CALL ZMEQ(MZ08,MB)
         CALL ZMADD(MB,MZ03,MZ08)
         CALL ZMEQ(MZ08,MB)
         CALL ZMDIVI(MB,JVAL2,MZ08)
         CALL ZMEQ(MZ08,MB)
      ENDDO

      CALL ZMIPWR(MB,IJSIGN*IVAL2,MZ03)
      CALL ZMEQ(MZ03,MB)
      IF (INVERT == 1) THEN
          CALL ZMI2M(1,MZ03)
          CALL ZMDIV(MZ03,MB,MZ08)
          CALL ZMEQ(MZ08,MB)
      ENDIF

!             Round the result and return.

  110 MACCMB = MB(0)
      MB(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MB(KPTIMU)
      MB(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      CALL ZMEQ(MB,MZ01)
      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE ZMRPWR

      SUBROUTINE ZMRSLT(MC,KRESLT)

!  Handle results that are special cases, such as overflow,
!  underflow, and unknown.

!  MC is the result that is returned

!  KRESLT is the result code.  Result codes handled here:

!   0 - Perform the normal operation
!  12 - The result is 'UNKNOWN'

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MC(-1:LUNPKZ)
      INTEGER KRESLT

      INTEGER KFSAVE

      KFSAVE = KFLAG

      IF (KRESLT == 12 .OR. KRESLT < 0 .OR. KRESLT > 15) THEN
          CALL ZMST2M('UNKNOWN+UNKNOWN*i',MC)
          KFLAG = KFSAVE
          RETURN
      ENDIF

      RETURN
      END SUBROUTINE ZMRSLT

      SUBROUTINE ZMSIN(MA,MB)

!  MB = SIN(MA).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE

      CALL ZMENTR('ZMSIN ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KACCSW = 0
      KRSAVE = KRAD
      KRAD = 1

      CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)

!             Check for special cases.

      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          CALL ZMI2M(0,MZ01)
          GO TO 110
      ELSE IF (MA(1) < (-NDIG) .AND. MA(KPTIMU+1) < (-NDIG)) THEN
          CALL ZMEQ(MZ07,MZ01)
          GO TO 110
      ELSE IF (MA(KPTIMU+2) == 0) THEN
          CALL FMSIN(MZ07,MZ01)
          CALL FMI2M(0,MZ01(KPTIMU-1))
          GO TO 110
      ELSE IF (MA(2) == 0) THEN
          CALL FMSINH(MZ07(KPTIMU-1),MZ01(KPTIMU-1))
          CALL FMI2M(0,MZ01)
          GO TO 110
      ENDIF

!             Find COS(REAL(MA)) and SIN(REAL(MA)).

      CALL FMCSSN(MZ07,MZ01(KPTIMU-1),MZ01)

!             Find COSH(IMAG(MA)) and SINH(IMAG(MA)).

      CALL FMCHSH(MZ07(KPTIMU-1),M05,M06)

!             SIN(MA) =  SIN(REAL(MA))*COSH(IMAG(MA)) +
!                        COS(REAL(MA))*SINH(IMAG(MA)) i

      CALL FMMPY_R1(MZ01,M05)
      CALL FMMPY_R1(MZ01(KPTIMU-1),M06)

  110 MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      KRAD = KRSAVE
      RETURN
      END SUBROUTINE ZMSIN

      SUBROUTINE ZMSINH(MA,MB)

!  MB = SINH(MA).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE

      CALL ZMENTR('ZMSINH',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KACCSW = 0
      KRSAVE = KRAD
      KRAD = 1

      CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)

!             Check for special cases.

      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          CALL ZMI2M(0,MZ01)
          GO TO 110
      ELSE IF (MA(1) < (-NDIG) .AND. MA(KPTIMU+1) < (-NDIG)) THEN
          CALL ZMEQ(MZ07,MZ01)
          GO TO 110
      ELSE IF (MA(2) == 0) THEN
          CALL FMSIN(MZ07(KPTIMU-1),MZ01(KPTIMU-1))
          CALL FMI2M(0,MZ01)
          GO TO 110
      ELSE IF (MA(KPTIMU+2) == 0) THEN
          CALL FMSINH(MZ07,MZ01)
          CALL FMI2M(0,MZ01(KPTIMU-1))
          GO TO 110
      ENDIF

!             Find SIN(IMAG(MA)) and COS(IMAG(MA)).

      CALL FMCSSN(MZ07(KPTIMU-1),MZ01,MZ01(KPTIMU-1))

!             Find SINH(REAL(MA)) and COSH(REAL(MA)).

      CALL FMCHSH(MZ07,M05,M06)

!             SINH(MA) =  SINH(REAL(MA))*COS(IMAG(MA)) +
!                         COSH(REAL(MA))*SIN(IMAG(MA)) i

      CALL FMMPY_R1(MZ01,M06)
      CALL FMMPY_R1(MZ01(KPTIMU-1),M05)

  110 MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      KRAD = KRSAVE
      RETURN
      END SUBROUTINE ZMSINH

      SUBROUTINE ZMSQR(MA,MB)

!  MB = MA * MA

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDGSV2,NDSAVE,NTRSAV

      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR.  &
          KDEBUG >= 1) THEN
          CALL ZMENTR('ZMSQR ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          IF (NTRACE /= 0) THEN
              NAMEST(NCALL) = 'ZMSQR '
              CALL ZMNTR(2,MA,MA,1)
          ENDIF
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              NDIG = MAX(NDIG+NGRD52,2)
              IF (NDIG > NDG2MX) THEN
                  NAMEST(NCALL) = 'ZMSQR '
                  KFLAG = -9
                  CALL ZMWARN
                  KRESLT = 12
                  NDIG = NDSAVE
                  CALL ZMRSLT(MB,KRESLT)
                  IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
              IF (MBASE >= 100*ABS(MA(2)) .OR.  &
                  MBASE >= 100*ABS(MA(KPTIMU+2))) THEN
                  NDIG = MIN(NDIG+1,NDG2MX)
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
          KOVUN = 0
      ENDIF
      IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
          IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
      ENDIF

      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      NTRSAV = NTRACE
      NTRACE = 0
      KWRNSV = KWARN
      KWARN = 0

      CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
      IF (NCALL == 1) THEN
          MZ07(0) = NINT(NDIG*ALOGM2)
          MZ07(KPTIMU) = MZ07(0)
      ENDIF

!             Check for special cases.

      IF (MA(KPTIMU+2) == 0) THEN
          CALL FMSQR(MZ07,MZ01)
          CALL FMI2M(0,MZ01(KPTIMU-1))
      ELSE IF (MA(2) == 0) THEN
          CALL FMSQR(MZ07(KPTIMU-1),MZ01)
          IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
          CALL FMI2M(0,MZ01(KPTIMU-1))
      ELSE
          CALL FMADD(MZ07,MZ07(KPTIMU-1),M02)
          CALL FMSUB(MZ07,MZ07(KPTIMU-1),M03)
          CALL FMMPY(M02,M03,MZ01)
          CALL FMMPY(MZ07,MZ07(KPTIMU-1),M03)
          CALL FMADD(M03,M03,MZ01(KPTIMU-1))
      ENDIF

      MXEXP = MXSAVE
      NTRACE = NTRSAV
      NDGSV2 = NDIG
      NDIG = NDSAVE
      KWARN = KWRNSV
      MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      KACCSW = KASAVE
      CALL ZMEQ2(MZ01,MB,NDGSV2,NDSAVE)
      IF (MB(1) >= MEXPOV .OR. MB(1) <= -MEXPOV .OR.  &
          MB(KPTIMU+1) >= MEXPOV .OR. MB(KPTIMU+1) <= -MEXPOV) THEN
          IF (MB(1) == MUNKNO .OR. MB(KPTIMU+1) == MUNKNO) THEN
              KFLAG = -4
          ELSE IF (MB(1) == MEXPOV .OR. MB(KPTIMU+1) == MEXPOV) THEN
              KFLAG = -5
          ELSE IF (MB(1) == MEXPUN .OR. MB(KPTIMU+1) == MEXPUN) THEN
              KFLAG = -6
          ENDIF
          IF ((MB(1) == MUNKNO)  &
             .OR. (MB(KPTIMU+1) == MUNKNO)  &
             .OR. (MB(1) == MEXPUN .AND. KOVUN == 0)  &
             .OR. (MB(KPTIMU+1) == MEXPUN .AND. KOVUN == 0)  &
             .OR. (MB(1) == MEXPOV .AND. KOVUN == 0)  &
             .OR. (MB(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
              NAMEST(NCALL) = 'ZMSQR '
              CALL ZMWARN
          ENDIF
      ENDIF
      IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMSQR

      SUBROUTINE ZMSQRT(MA,MB)

!  MB = SQRT(MA).  Principal Square Root.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXEXP1,MXSAVE
      INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV

      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR.  &
          KDEBUG >= 1) THEN
          CALL ZMENTR('ZMSQRT',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          IF (NTRACE /= 0) THEN
              NAMEST(NCALL) = 'ZMSQRT'
              CALL ZMNTR(2,MA,MA,1)
          ENDIF
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              NDIG = MAX(NDIG+NGRD52,2)
              IF (NDIG > NDG2MX) THEN
                  NAMEST(NCALL) = 'ZMSQRT'
                  KFLAG = -9
                  CALL ZMWARN
                  KRESLT = 12
                  NDIG = NDSAVE
                  CALL ZMRSLT(MB,KRESLT)
                  IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
              IF (MBASE >= 100*ABS(MA(2)) .OR.  &
                  MBASE >= 100*ABS(MA(KPTIMU+2))) THEN
                  NDIG = MIN(NDIG+1,NDG2MX)
              ENDIF
          ENDIF
          KASAVE = KACCSW
          KACCSW = 0
          MXSAVE = MXEXP
          MXEXP = MXEXP2
          KOVUN = 0
      ENDIF
      IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
          IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
      ENDIF

      NTRSAV = NTRACE
      NTRACE = 0
      KWRNSV = KWARN
      KWARN = 0
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)

      CALL ZMEQU(MA,MZ05,NDSAVE,NDIG)

!             Check for special cases.

      MXEXP1 = INT(MXEXP2/2.01D0)
      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          CALL ZMI2M(0,MZ01)
          GO TO 110
      ELSE IF (MA(2) == 0) THEN
          CALL FMABS(MZ05(KPTIMU-1),M01)
          CALL FMDIVI(M01,2,M03)
          CALL FMSQRT_R1(M03)
      ELSE IF (MA(KPTIMU+2) == 0) THEN
          CALL FMABS(MZ05,M03)
          CALL FMSQRT_R1(M03)
      ELSE IF (MA(1) == MEXPUN) THEN
          IF (MA(KPTIMU+1) <= -MXEXP1+NDIG+1) THEN
              CALL ZMST2M('UNKNOWN + UNKNOWN i',MZ01)
              GO TO 110
          ENDIF
      ELSE IF (MA(KPTIMU+1) == MEXPUN) THEN
          IF (MA(1) <= -MXEXP1+NDIG+1) THEN
              CALL ZMST2M('UNKNOWN + UNKNOWN i',MZ01)
              GO TO 110
          ENDIF
      ELSE
          CALL FMSQR(MZ05,M01)
          CALL FMSQR(MZ05(KPTIMU-1),M02)
          CALL FMADD(M01,M02,M03)
          CALL FMSQRT_R1(M03)
          CALL FMABS(MZ05,M02)
          CALL FMADD_R2(M02,M03)
          CALL FMDIVI_R1(M03,2)
          CALL FMSQRT_R1(M03)
      ENDIF

      CALL FMADD(M03,M03,M02)
      IF (MA(-1) >= 0) THEN
          CALL FMDIV(MZ05(KPTIMU-1),M02,MZ01(KPTIMU-1))
          CALL FMEQ(M03,MZ01)
      ELSE
          IF (MA(KPTIMU-1) >= 0) THEN
              CALL FMDIV(MZ05(KPTIMU-1),M02,MZ01)
              CALL FMEQ(M03,MZ01(KPTIMU-1))
          ELSE
              CALL FMDIV(MZ05(KPTIMU-1),M02,MZ01)
              CALL FMEQ(M03,MZ01(KPTIMU-1))
              IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
              IF (MZ01(KPTIMU+1) /= MUNKNO .AND. MZ01(KPTIMU+2) /= 0)  &
                  MZ01(KPTIMU-1) = -MZ01(KPTIMU-1)
          ENDIF
      ENDIF

  110 MXEXP = MXSAVE
      MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      KACCSW = KASAVE
      CALL ZMEQ2(MZ01,MB,NDIG,NDSAVE)

      IF (MB(1) == MUNKNO .OR. MB(KPTIMU+1) == MUNKNO) THEN
          KFLAG = -4
      ELSE IF (MB(1) == MEXPOV .OR. MB(KPTIMU+1) == MEXPOV) THEN
          KFLAG = -5
      ELSE IF (MB(1) == MEXPUN .OR. MB(KPTIMU+1) == MEXPUN) THEN
          KFLAG = -6
      ENDIF
      NTRACE = NTRSAV
      NDIG = NDSAVE
      KWARN = KWRNSV
      IF ((MB(1) == MUNKNO)  &
         .OR. (MB(KPTIMU+1) == MUNKNO)  &
         .OR. (MB(1) == MEXPUN .AND. KOVUN == 0)  &
         .OR. (MB(KPTIMU+1) == MEXPUN .AND. KOVUN == 0)  &
         .OR. (MB(1) == MEXPOV .AND. KOVUN == 0)  &
         .OR. (MB(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
          NAMEST(NCALL) = 'ZMSQRT'
          CALL ZMWARN
      ENDIF
      IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMSQRT

      SUBROUTINE ZMST2M(STRING,MA)

!  MA = STRING

!  Convert a character string to FM format.
!  This is often more convenient than using ZMINP, which converts an
!  array of CHARACTER*1 values.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(*) :: STRING
      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)

      INTEGER J,LB,KFSAVE

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMST2M'
      LB = LEN(STRING)
      KFSAVE = KFLAG

      DO J = 1, LB
         CMBUFZ(J) = STRING(J:J)
      ENDDO

      CALL ZMINP(CMBUFZ,MA,1,LB)

      IF (KFSAVE /= 0) KFLAG = KFSAVE
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMST2M

      SUBROUTINE ZMSUB(MA,MB,MC)

!  MC = MA - MB

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ)

      INTEGER KASAVE,KF1,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV
      REAL (KIND(1.0D0)) :: MXSAVE

      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR.  &
          ABS(MB(1)) > MEXPAB .OR. ABS(MB(KPTIMU+1)) > MEXPAB .OR.  &
          KDEBUG >= 1) THEN
          CALL ZMENTR('ZMSUB ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
          NDIG = NDSAVE
          MXEXP = MXSAVE
          KACCSW = KASAVE
      ELSE
          NCALL = NCALL + 1
          IF (NTRACE /= 0) THEN
              NAMEST(NCALL) = 'ZMSUB '
              CALL ZMNTR(2,MA,MB,2)
          ENDIF
          KOVUN = 0
      ENDIF

!             Force FMSUB to use more guard digits for user calls.

      NCALL = NCALL - 1
      NTRSAV = NTRACE
      NTRACE = 0
      KWRNSV = KWARN
      KWARN = 0

      CALL FMSUB(MA,MB,MC)
      KF1 = KFLAG
      CALL FMSUB(MA(KPTIMU-1),MB(KPTIMU-1),MC(KPTIMU-1))

      NTRACE = NTRSAV
      KWARN = KWRNSV
      NCALL = NCALL + 1
      IF (NTRACE /= 0) NAMEST(NCALL) = 'ZMSUB '
      IF (KFLAG == 1) KFLAG = KF1

      IF (MC(1) == MUNKNO .OR. MC(KPTIMU+1) == MUNKNO) THEN
          KFLAG = -4
      ELSE IF (MC(1) == MEXPOV .OR. MC(KPTIMU+1) == MEXPOV) THEN
          KFLAG = -5
      ELSE IF (MC(1) == MEXPUN .OR. MC(KPTIMU+1) == MEXPUN) THEN
          KFLAG = -6
      ENDIF
      IF ((MC(1) == MUNKNO)  &
         .OR. (MC(KPTIMU+1) == MUNKNO)  &
         .OR. (MC(1) == MEXPUN .AND. KOVUN == 0)  &
         .OR. (MC(KPTIMU+1) == MEXPUN .AND. KOVUN == 0)  &
         .OR. (MC(1) == MEXPOV .AND. KOVUN == 0)  &
         .OR. (MC(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
          NAMEST(NCALL) = 'ZMSUB '
          CALL ZMWARN
      ENDIF
      IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMSUB

      SUBROUTINE ZMTAN(MA,MB)

!  MB = TAN(MA).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER IEXTRA,KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE,NGOAL

      CALL ZMENTR('ZMTAN ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KRSAVE = KRAD
      KRAD = 1

  110 CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)

!             Check for special cases.

      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          CALL ZMI2M(0,MZ01)
          GO TO 120
      ELSE IF (MA(1) < (-NDIG) .AND. MA(KPTIMU+1) < (-NDIG)) THEN
          CALL ZMEQ(MZ07,MZ01)
          GO TO 120
      ELSE IF (MA(KPTIMU+2) == 0) THEN
          CALL FMTAN(MZ07,MZ01)
          CALL FMI2M(0,MZ01(KPTIMU-1))
          GO TO 120
      ELSE IF (MA(2) == 0) THEN
          CALL FMTANH(MZ07(KPTIMU-1),MZ01(KPTIMU-1))
          CALL FMI2M(0,MZ01)
          GO TO 120
      ENDIF

!             Find SIN(2*REAL(MA)) and COS(2*REAL(MA)).

      CALL FMADD(MZ07,MZ07,MZ01)
      CALL FMCSSN(MZ01,MZ01(KPTIMU-1),M06)
      CALL FMEQ(M06,MZ01)

!             Find SINH(2*IMAG(MA)) and COSH(2*IMAG(MA)).

      CALL FMADD(MZ07(KPTIMU-1),MZ07(KPTIMU-1),M06)
      CALL FMCHSH(M06,M05,M14)
      CALL FMEQ(M14,M06)

!             TAN(MA) =  SIN(2*REAL(MA)) /
!                        (COS(2*REAL(MA))+COSH(2*IMAG(MA)) +
!                        SINH(2*IMAG(MA)) /
!                        (COS(2*REAL(MA))+COSH(2*IMAG(MA)) i

      CALL FMADD_R2(MZ01(KPTIMU-1),M05)
      IF (M05(2) == 0) THEN
          MZ01(0) = 0
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7
          GO TO 130
      ELSE IF (M05(1) == MEXPOV) THEN
          CALL FMDIV_R1(MZ01,M05)
          CALL FMIM(1,MZ01(KPTIMU-1))
          IF (M06(-1) < 0 .AND. MZ01(KPTIMU+1) /= MUNKNO .AND.  &
              MZ01(KPTIMU+2) /= 0) MZ01(KPTIMU-1) = -MZ01(KPTIMU-1)
      ELSE
          CALL FMDIVD(MZ01,M06,M05,MZ08,MZ08(KPTIMU-1))
          CALL ZMEQ(MZ08,MZ01)
      ENDIF

!             Check for too much cancellation.

  120 IF (NCALL <= 1) THEN
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7
      ELSE
          NGOAL = INT(-MXEXP2)
      ENDIF
  130 IF (MZ01(0) <= NGOAL .OR. MZ01(KPTIMU) <= NGOAL) THEN
          IEXTRA = INT(REAL(MAX(NGOAL-MZ01(0),NGOAL-MZ01(KPTIMU)))  &
                   /ALOGM2 + 23.03/ALOGMB) + 1
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL ZMWARN
              NDIG = NDIG - IEXTRA
              CALL ZMST2M('UNKNOWN+UNKNOWN*i',MZ01)
              GO TO 140
          ENDIF
          GO TO 110
      ENDIF

  140 MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      KRAD = KRSAVE
      RETURN
      END SUBROUTINE ZMTAN

      SUBROUTINE ZMTANH(MA,MB)

!  MB = TANH(MA).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
      REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
      INTEGER IEXTRA,KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE,NGOAL

      CALL ZMENTR('ZMTANH',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      MARZ = MA(0)
      MAIZ = MA(KPTIMU)
      KRSAVE = KRAD
      KRAD = 1

  110 CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)

!             Check for special cases.

      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
          CALL ZMI2M(0,MZ01)
          GO TO 120
      ELSE IF (MA(1) < (-NDIG) .AND. MA(KPTIMU+1) < (-NDIG)) THEN
          CALL ZMEQ(MZ07,MZ01)
          GO TO 120
      ELSE IF (MA(2) == 0) THEN
          CALL FMTAN(MZ07(KPTIMU-1),MZ01(KPTIMU-1))
          CALL FMI2M(0,MZ01)
          GO TO 120
      ELSE IF (MA(KPTIMU+2) == 0) THEN
          CALL FMTANH(MZ07,MZ01)
          CALL FMI2M(0,MZ01(KPTIMU-1))
          GO TO 120
      ENDIF

!             Find SIN(2*IMAG(MA)) and COS(2*IMAG(MA)).

      CALL FMADD(MZ07(KPTIMU-1),MZ07(KPTIMU-1),MZ01)
      CALL FMCSSN(MZ01,MZ01(KPTIMU-1),M06)
      CALL FMEQ(M06,MZ01)

!             Find SINH(2*REAL(MA)) and COSH(2*REAL(MA)).

      CALL FMADD(MZ07,MZ07,M06)
      CALL FMCHSH(M06,M05,M14)
      CALL FMEQ(M14,M06)

!             TANH(MA) =  SINH(2*REAL(MA)) /
!                         (COS(2*IMAG(MA))+COSH(2*REAL(MA)) +
!                         SIN(2*IMAG(MA)) /
!                         (COS(2*IMAG(MA))+COSH(2*REAL(MA)) i

      CALL FMADD_R2(MZ01(KPTIMU-1),M05)
      IF (M05(2) == 0) THEN
          MZ01(0) = 0
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7
          GO TO 130
      ELSE IF (M05(1) == MEXPOV) THEN
          CALL FMDIV(MZ01,M05,MZ01(KPTIMU-1))
          CALL FMIM(1,MZ01)
          IF (M06(-1) < 0) MZ01(-1) = -1
      ELSE
          CALL FMDIVD(MZ01,M06,M05,MZ08(KPTIMU-1),MZ08)
          CALL ZMEQ(MZ08,MZ01)
      ENDIF

!             Check for too much cancellation.

  120 IF (NCALL <= 1) THEN
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7
      ELSE
          NGOAL = INT(-MXEXP2)
      ENDIF
  130 IF (MZ01(0) <= NGOAL .OR. MZ01(KPTIMU) <= NGOAL) THEN
          IEXTRA = INT(REAL(MAX(NGOAL-MZ01(0),NGOAL-MZ01(KPTIMU)))  &
                   /ALOGM2 + 23.03/ALOGMB) + 1
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL ZMWARN
              NDIG = NDIG - IEXTRA
              CALL ZMST2M('UNKNOWN+UNKNOWN*i',MZ01)
              GO TO 140
          ENDIF
          GO TO 110
      ENDIF

  140 MACCMB = MZ01(0)
      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
      MACCMB = MZ01(KPTIMU)
      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      KRAD = KRSAVE
      RETURN
      END SUBROUTINE ZMTANH

      SUBROUTINE ZMUNPK(MP,MA)

!  MP is unpacked and the value returned in MA.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MP(-1:LPACKZ)

      CALL FMUNPK(MP,MA)
      CALL FMUNPK(MP(KPTIMP),MA(KPTIMU-1))
      RETURN
      END SUBROUTINE ZMUNPK

      SUBROUTINE ZMWARN

!  Called by one of the ZM routines to print a warning message
!  if any error condition arises in that routine.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(6) :: NAME

      INTEGER NCS

      IF (KFLAG >= 0 .OR. NCALL /= 1 .OR. KWARN <= 0) RETURN
      NCS = NCALL
      NAME = NAMEST(NCALL)
      WRITE (KW,"(/' Error of type KFLAG =',I3,"    //  &
                "' in FM package in routine ',A6/)"     &
            ) KFLAG,NAME

  110 NCALL = NCALL - 1
      IF (NCALL > 0) THEN
          NAME = NAMEST(NCALL)
          WRITE (KW,"( ' called from ',A6)") NAME
          GO TO 110
      ENDIF

      IF (KFLAG == -1) THEN
          WRITE (KW,"(' NDIG must be between 2 and',I10/)") NDIGMX
      ELSE IF (KFLAG == -2) THEN
          WRITE (KW,"(' MBASE must be between 2 and',I10/)") INT(MXBASE)
      ELSE IF (KFLAG == -3) THEN
          WRITE (KW,  &
                 "(' An input argument is not a valid FM number.',"  //  &
                 "'  Its exponent is out of range.'/)"                   &
                )
          WRITE (KW,"(' UNKNOWN has been returned.'/)")
      ELSE IF (KFLAG == -4 .OR. KFLAG == -7) THEN
          WRITE (KW,"(' Invalid input argument for this routine.'/)")
          WRITE (KW,"(' UNKNOWN has been returned.'/)")
      ELSE IF (KFLAG == -5) THEN
          WRITE (KW,"(' The result has overflowed.'/)")
      ELSE IF (KFLAG == -6) THEN
          WRITE (KW,"(' The result has underflowed.'/)")
      ELSE IF (KFLAG == -8 .AND. NAME == 'ZMOUT ') THEN
          WRITE (KW,  &
                 "(' The result array is not big enough to hold the',"    //  &
                 "' output character string'/' in the current format.'/"  //  &
                 "' The result ''***...***'' has been returned.'/)"           &
                )
      ELSE IF (KFLAG == -8 .AND. NAME == 'ZMREAD') THEN
          WRITE (KW,  &
                 "(' The CMBUFF array is not big enough to hold the',"  //  &
                 "' input character string'/"                           //  &
                 "' UNKNOWN has been returned.'/)"                          &
                )
      ELSE IF (KFLAG == -9) THEN
          WRITE (KW,  &
                 "(' Precision could not be raised enough to'"  //  &
                 ",' provide all requested guard digits.'/)"        &
                )
          WRITE (KW,  &
                 "(I23,' digits were requested (NDIG).'/"            //  &
                 "' Maximum number of digits currently available',"  //  &
                 "' (NDG2MX) is',I7,'.'/)"                               &
                ) NDIG,NDG2MX
          WRITE (KW,"(' UNKNOWN has been returned.'/)")
      ENDIF

      NCALL = NCS
      IF (KWARN >= 2) THEN
          STOP
      ENDIF
      RETURN
      END SUBROUTINE ZMWARN

      SUBROUTINE ZMWRIT(KWRITE,MA)

!  Write MA on unit KWRITE under the current format.  Multi-line numbers
!  will have '&' as the last nonblank character on all but the last
!  line of the real part and the imaginary part.
!  These numbers can then be read easily using ZMREAD.

      USE FMVALS
      IMPLICIT NONE

      INTEGER KWRITE
      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)

      INTEGER J,K,KSAVE,L,LAST,LAST1,LAST2,LB,ND,NEXP

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMWRIT'
      KSAVE = KFLAG
      ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
      IF (ND < 2) ND = 2
      NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
      LB = 2*MAX(JFORM2+NEXP,ND+NEXP) + 3
      LB = MIN(LB,LMBUFZ)
      CALL ZMOUT(MA,CMBUFZ,LB,LAST1,LAST2)
      KFLAG = KSAVE
      LAST = LAST2 + 1
      DO J = 1, LAST2
         IF (CMBUFZ(LAST-J) /= ' ' .OR. J == LAST2) THEN
             L = LAST - J
             IF (MOD(L,73) /= 0) THEN
                 WRITE (KWRITE,"(4X,73A1,' &')") (CMBUFZ(K),K=1,L)
             ELSE
                 WRITE (KWRITE,"(4X,73A1,' &')") (CMBUFZ(K),K=1,L-73)
                 WRITE (KWRITE,"(4X,73A1)") (CMBUFZ(K),K=L-72,L)
             ENDIF
             NCALL = NCALL - 1
             RETURN
         ENDIF
      ENDDO
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMWRIT

      SUBROUTINE ZMZ2M(ZVAL,MA)

!  MA = ZVAL

!  ZVAL is complex and is converted to ZM form.

      USE FMVALS
      IMPLICIT NONE

      COMPLEX ZVAL
      REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)

      NCALL = NCALL + 1
      NAMEST(NCALL) = 'ZMZ2M '
      IF (NTRACE /= 0) CALL ZMNTRZ(2,ZVAL,1)

      CALL FMSP2M(REAL(ZVAL),MA)
      CALL FMSP2M(AIMAG(ZVAL),MA(KPTIMU-1))

      IF (NTRACE /= 0) CALL ZMNTR(1,MA,MA,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE ZMZ2M

!  Here are the routines which work with packed ZM numbers.  All names
!  are the same as unpacked versions with 'ZM' replaced by 'ZP'.

!  To convert a program using the ZM package from unpacked calls to
!  packed calls make these changes to the program:
!  '(-1:LUNPKZ)' to '(-1:LUNPKZ)' in dimensions.
!  'CALL ZM' to 'CALL ZP'

!  This packed format is not available when using the FM, IM, or ZM
!  derived types.


      SUBROUTINE ZPABS(MA,MBFM)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MBFM(-1:LPACK)
      CALL ZMUNPK(MA,MPX)
      CALL ZMABS(MPX,MPA)
      CALL FMPACK(MPA,MBFM)
      RETURN
      END SUBROUTINE ZPABS

      SUBROUTINE ZPACOS(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMACOS(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPACOS

      SUBROUTINE ZPADD(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ),MC(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMUNPK(MB,MPY)
      CALL ZMADD(MPX,MPY,MPZ)
      CALL ZMPACK(MPZ,MC)
      RETURN
      END SUBROUTINE ZPADD

      SUBROUTINE ZPADDI(MA,INTEG)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
      INTEGER INTEG
      CALL ZMUNPK(MA,MPX)
      CALL ZMADDI(MPX,INTEG)
      CALL ZMPACK(MPX,MA)
      RETURN
      END SUBROUTINE ZPADDI

      SUBROUTINE ZPARG(MA,MBFM)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MBFM(-1:LPACK)
      CALL ZMUNPK(MA,MPX)
      CALL ZMARG(MPX,MPA)
      CALL FMPACK(MPA,MBFM)
      RETURN
      END SUBROUTINE ZPARG

      SUBROUTINE ZPASIN(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMASIN(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPASIN

      SUBROUTINE ZPATAN(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMATAN(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPATAN

      SUBROUTINE ZPCHSH(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ),MC(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMCHSH(MPX,MPY,MPZ)
      CALL ZMPACK(MPY,MB)
      CALL ZMPACK(MPZ,MC)
      RETURN
      END SUBROUTINE ZPCHSH

      SUBROUTINE ZPCMPX(MAFM,MBFM,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MAFM(-1:LPACK),MBFM(-1:LPACK),MC(-1:LPACKZ)
      CALL FMUNPK(MAFM,MPA)
      CALL FMUNPK(MBFM,MPB)
      CALL ZMCMPX(MPA,MPB,MPX)
      CALL ZMPACK(MPX,MC)
      RETURN
      END SUBROUTINE ZPCMPX

      SUBROUTINE ZPCONJ(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMCONJ(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPCONJ

      SUBROUTINE ZPCOS(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMCOS(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPCOS

      SUBROUTINE ZPCOSH(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMCOSH(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPCOSH

      SUBROUTINE ZPCSSN(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ),MC(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMCSSN(MPX,MPY,MPZ)
      CALL ZMPACK(MPY,MB)
      CALL ZMPACK(MPZ,MC)
      RETURN
      END SUBROUTINE ZPCSSN

      SUBROUTINE ZPDIV(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ),MC(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMUNPK(MB,MPY)
      CALL ZMDIV(MPX,MPY,MPZ)
      CALL ZMPACK(MPZ,MC)
      RETURN
      END SUBROUTINE ZPDIV

      SUBROUTINE ZPDIVI(MA,INTEG,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      INTEGER INTEG
      CALL ZMUNPK(MA,MPX)
      CALL ZMDIVI(MPX,INTEG,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPDIVI

      SUBROUTINE ZPEQ(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL FPEQ(MA,MB)
      CALL FPEQ(MA(KPTIMP),MB(KPTIMP))
      RETURN
      END SUBROUTINE ZPEQ

      SUBROUTINE ZPEQU(MA,MB,NDA,NDB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      INTEGER NDA,NDB
      CALL FPEQU(MA,MB,NDA,NDB)
      CALL FPEQU(MA(KPTIMP),MB(KPTIMP),NDA,NDB)
      RETURN
      END SUBROUTINE ZPEQU

      SUBROUTINE ZPEXP(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMEXP(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPEXP

      SUBROUTINE ZPFORM(FORM1,FORM2,MA,STRING)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
      CHARACTER(*) :: FORM1,FORM2,STRING
      CALL ZMUNPK(MA,MPX)
      CALL ZMFORM(FORM1,FORM2,MPX,STRING)
      RETURN
      END SUBROUTINE ZPFORM

      SUBROUTINE ZPFPRT(FORM1,FORM2,MA)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
      CHARACTER(*) :: FORM1,FORM2
      CALL ZMUNPK(MA,MPX)
      CALL ZMFPRT(FORM1,FORM2,MPX)
      RETURN
      END SUBROUTINE ZPFPRT

      SUBROUTINE ZP2I2M(INTEG1,INTEG2,MA)
      USE FMVALS
      IMPLICIT NONE
      INTEGER INTEG1,INTEG2
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
      CALL ZM2I2M(INTEG1,INTEG2,MPX)
      CALL ZMPACK(MPX,MA)
      RETURN
      END SUBROUTINE ZP2I2M

      SUBROUTINE ZPI2M(INTEG,MA)
      USE FMVALS
      IMPLICIT NONE
      INTEGER INTEG
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
      CALL ZMI2M(INTEG,MPX)
      CALL ZMPACK(MPX,MA)
      RETURN
      END SUBROUTINE ZPI2M

      SUBROUTINE ZPIMAG(MA,MBFM)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MBFM(-1:LPACK)
      CALL ZMUNPK(MA,MPX)
      CALL ZMIMAG(MPX,MPA)
      CALL FMPACK(MPA,MBFM)
      RETURN
      END SUBROUTINE ZPIMAG

      SUBROUTINE ZPINT(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMINT(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPINT

      SUBROUTINE ZPINP(LINE,MA,LA,LB)
      USE FMVALS
      IMPLICIT NONE
      INTEGER LA,LB
      CHARACTER LINE(LB)
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
      CALL ZMINP(LINE,MPX,LA,LB)
      CALL ZMPACK(MPX,MA)
      RETURN
      END SUBROUTINE ZPINP

      SUBROUTINE ZPIPWR(MA,INTEG,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      INTEGER INTEG
      CALL ZMUNPK(MA,MPX)
      CALL ZMIPWR(MPX,INTEG,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPIPWR

      SUBROUTINE ZPLG10(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMLG10(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPLG10

      SUBROUTINE ZPLN(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMLN(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPLN

      SUBROUTINE ZPM2I(MA,INTEG)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
      INTEGER INTEG
      CALL ZMUNPK(MA,MPX)
      CALL ZMM2I(MPX,INTEG)
      RETURN
      END SUBROUTINE ZPM2I

      SUBROUTINE ZPM2Z(MA,ZVAL)
      USE FMVALS
      IMPLICIT NONE
      COMPLEX ZVAL
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMM2Z(MPX,ZVAL)
      RETURN
      END SUBROUTINE ZPM2Z

      SUBROUTINE ZPMPY(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ),MC(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMUNPK(MB,MPY)
      CALL ZMMPY(MPX,MPY,MPZ)
      CALL ZMPACK(MPZ,MC)
      RETURN
      END SUBROUTINE ZPMPY

      SUBROUTINE ZPMPYI(MA,INTEG,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      INTEGER INTEG
      CALL ZMUNPK(MA,MPX)
      CALL ZMMPYI(MPX,INTEG,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPMPYI

      SUBROUTINE ZPNINT(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMNINT(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPNINT

      SUBROUTINE ZPOUT(MA,LINE,LB,LAST1,LAST2)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
      INTEGER LB,LAST1,LAST2
      CHARACTER LINE(LB)
      CALL ZMUNPK(MA,MPX)
      CALL ZMOUT(MPX,LINE,LB,LAST1,LAST2)
      RETURN
      END SUBROUTINE ZPOUT

      SUBROUTINE ZPPRNT(MA)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMPRNT(MPX)
      RETURN
      END SUBROUTINE ZPPRNT

      SUBROUTINE ZPPWR(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ),MC(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMUNPK(MB,MPY)
      CALL ZMPWR(MPX,MPY,MPZ)
      CALL ZMPACK(MPZ,MC)
      RETURN
      END SUBROUTINE ZPPWR

      SUBROUTINE ZPREAD(KREAD,MA)
      USE FMVALS
      IMPLICIT NONE
      INTEGER KREAD
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
      CALL ZMREAD(KREAD,MPX)
      CALL ZMPACK(MPX,MA)
      RETURN
      END SUBROUTINE ZPREAD

      SUBROUTINE ZPREAL(MA,MBFM)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MBFM(-1:LPACK)
      CALL ZMUNPK(MA,MPX)
      CALL ZMREAL(MPX,MPA)
      CALL FMPACK(MPA,MBFM)
      RETURN
      END SUBROUTINE ZPREAL

      SUBROUTINE ZPRPWR(MA,IVAL,JVAL,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      INTEGER IVAL,JVAL
      CALL ZMUNPK(MA,MPX)
      CALL ZMRPWR(MPX,IVAL,JVAL,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPRPWR

      SUBROUTINE ZPSET(NPREC)
      USE FMVALS
      IMPLICIT NONE
      INTEGER NPREC
      CALL ZMSET(NPREC)
      RETURN
      END SUBROUTINE ZPSET

      SUBROUTINE ZPSIN(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMSIN(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPSIN

      SUBROUTINE ZPSINH(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMSINH(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPSINH

      SUBROUTINE ZPSQR(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMSQR(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPSQR

      SUBROUTINE ZPSQRT(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMSQRT(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPSQRT

      SUBROUTINE ZPST2M(STRING,MA)
      USE FMVALS
      IMPLICIT NONE
      CHARACTER(*) :: STRING
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
      CALL ZMST2M(STRING,MPX)
      CALL ZMPACK(MPX,MA)
      RETURN
      END SUBROUTINE ZPST2M

      SUBROUTINE ZPSUB(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ),MC(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMUNPK(MB,MPY)
      CALL ZMSUB(MPX,MPY,MPZ)
      CALL ZMPACK(MPZ,MC)
      RETURN
      END SUBROUTINE ZPSUB

      SUBROUTINE ZPTAN(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMTAN(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPTAN

      SUBROUTINE ZPTANH(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMTANH(MPX,MPY)
      CALL ZMPACK(MPY,MB)
      RETURN
      END SUBROUTINE ZPTANH

      SUBROUTINE ZPWRIT(KWRITE,MA)
      USE FMVALS
      IMPLICIT NONE
      INTEGER KWRITE
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
      CALL ZMUNPK(MA,MPX)
      CALL ZMWRIT(KWRITE,MPX)
      RETURN
      END SUBROUTINE ZPWRIT

      SUBROUTINE ZPZ2M(ZVAL,MA)
      USE FMVALS
      IMPLICIT NONE
      COMPLEX ZVAL
      REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
      CALL ZMZ2M(ZVAL,MPX)
      CALL ZMPACK(MPX,MA)
      RETURN
      END SUBROUTINE ZPZ2M

!  These FM routines perform the Gamma and Related Functions.


      SUBROUTINE FMARG2(KROUTN,NARGS,MA,MB,KRESLT)

!  Check the input arguments to a routine for special cases.

!  KROUTN - Name of the subroutine that was called
!  NARGS  - The number of input arguments (1 or 2)
!  MA     - First input argument
!  MB     - Second input argument (if NARGS is 2)
!  KRESLT - Result code returned to the calling routine.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(6) :: KROUTN
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER NARGS,KRESLT

      INTEGER NCATMA,NCATMB

      INTEGER, PARAMETER ::  &
               KFACT(15) = (/ 12,12, 0,12, 0, 0, 8, 8, 8, 0, 0, 8, 0, 4, 4 /), &
               KGAM(15)  = (/ 12,12, 0,12, 0, 0, 3,12, 4, 0, 0, 8, 0, 4, 4 /), &
               KLNGM(15) = (/ 12,12, 0,12,12,12,12,12,12, 0, 0,11, 0, 0, 4 /), &
               KPSI(15)  = (/ 12,12, 0,12, 0, 0, 4,12, 3, 0, 0, 0, 0, 0,12 /)

      CALL FMARGS(KROUTN,NARGS,MA,MB,KRESLT)
      IF (KFLAG /= 0) RETURN

!             Check for special cases.

      CALL FMCAT(MA,NCATMA)
      NCATMB = 0
      IF (NARGS == 2) CALL FMCAT(MB,NCATMB)

      IF (KROUTN == 'FMFACT') THEN
          KRESLT = KFACT(NCATMA)
          GO TO 110
      ENDIF

      IF (KROUTN == 'FMGAM ') THEN
          KRESLT = KGAM(NCATMA)
          GO TO 110
      ENDIF

      IF (KROUTN == 'FMLNGM') THEN
          KRESLT = KLNGM(NCATMA)
          GO TO 110
      ENDIF

      IF (KROUTN == 'FMPSI ') THEN
          KRESLT = KPSI(NCATMA)
          GO TO 110
      ENDIF

      KRESLT = 0
      RETURN

  110 IF (KRESLT == 12) THEN
          KFLAG = -4
          CALL FMWRN2
      ENDIF
      IF (KRESLT == 3 .OR. KRESLT == 4) THEN
          IF (NCATMA == 1 .OR. NCATMA == 7 .OR. NCATMA == 9 .OR.  &
              NCATMA == 15 .OR. NCATMB == 1 .OR. NCATMB == 7 .OR.  &
              NCATMB == 9 .OR. NCATMB == 15) THEN
              KFLAG = -5
          ELSE
              KFLAG = -5
              CALL FMWRN2
          ENDIF
      ENDIF
      IF (KRESLT == 5 .OR. KRESLT == 6) THEN
          IF (NCATMA == 1 .OR. NCATMA == 7 .OR. NCATMA == 9 .OR.  &
              NCATMA == 15 .OR. NCATMB == 1 .OR. NCATMB == 7 .OR.  &
              NCATMB == 9 .OR. NCATMB == 15) THEN
              KFLAG = -6
          ELSE
              KFLAG = -6
              CALL FMWRN2
          ENDIF
      ENDIF
      RETURN
      END SUBROUTINE FMARG2

      SUBROUTINE FMBERN(N,MA,MB)

!  MB = MA*B(N)  where B(N) is the Nth Bernoulli number.

      USE FMVALS
      IMPLICIT NONE

      INTEGER N
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
!             MBERN is the array used to save Bernoulli numbers so they
!                   do not have to be re-computed on subsequent calls.

!             Only the even-numbered Bernoulli numbers are stored.
!             B(2N) starts in MBERN(NPTBRN(N)) for 2N >= 28.
!             The first few numbers have small numerators and
!             denominators, and they are done using FMMPYI and FMDIVI,
!             and are not stored in MBERN.

      DOUBLE PRECISION U,X,B
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MNEXP,MXSAVE
      INTEGER IEXTRA,INTNDG,J,J2,JSIZE,K,KASAVE,KOVUN,KRESLT,L,LARGE,     &
              LARGED,N2,NBOT,NDGOAL,NDIV,NDOLD,NDP,NDSAV1,NDSAV2,NDSAVE,  &
              NEEDED,NEXTD,NEXTN,NGOAL,NMPY,NSTART,NTD,NTN,NTOP,NUMTRY,NX

      IF (NTRACE /= 0) THEN
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMBERN'
          CALL FMNTRI(2,N,1)
          NCALL = NCALL - 1
      ENDIF
      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (ABS(MA(1)) > MEXPAB) THEN
          CALL FMENT2('FMBERN',MA,MA,1,0,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                      KOVUN)
          IF (KRESLT /= 0) RETURN
      ELSE
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMBERN'
          IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,0)
          KOVUN = 0
          IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
          NDSAVE = NDIG
          IF (NCALL == 1) THEN
              K = INT(5.0/ALOGMT + 2.0 + (REAL(NDIG)*ALOGMT)**0.35/ALOGMT)
              NDIG = MAX(NDIG+K,2)
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWARN
                  NDIG = NDSAVE
                  KRESLT = 12
                  CALL FMRSLT(MA,MA,MB,KRESLT)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  RETURN
              ENDIF
          ENDIF
          KASAVE = KACCSW
          MXSAVE = MXEXP
          MXEXP = MXEXP2
      ENDIF

      KACCSW = 1
      MACCA = MA(0)
      CALL FMEQ2(MA,M20,NDSAVE,NDIG)
      M20(0) = NINT(NDIG*ALOGM2)
      NUMTRY = 0

!             Check for special cases.

  110 IF (N >= 2 .AND. N <= 26) THEN
          CALL FMBER2(N,M20,M19)
          GO TO 130
      ELSE IF (N == 0) THEN
          CALL FMEQ(M20,M19)
          GO TO 130
      ELSE IF (N == 1) THEN
          CALL FMDIVI(M20,-2,M19)
          GO TO 130
      ELSE IF (MOD(N,2) == 1 .OR. N < 0) THEN
          CALL FMI2M(0,M19)
          GO TO 130
      ELSE IF (MA(2) == 0) THEN
          CALL FMI2M(0,M19)
          GO TO 130
      ENDIF

!             See if B(N) has already been computed with sufficient
!             precision.

      N2 = N/2
      IF (MBASE == MBSBRN) THEN
          IF (N < NUMBRN .AND. NPTBRN(N2+1)-NPTBRN(N2) >= NDIG+3) THEN
              CALL FMMPY(MBERN(NPTBRN(N2)),M20,M19)
              GO TO 130
          ELSE IF (N == NUMBRN .AND. NWDBRN-NPTBRN(N2) >= NDIG+2) THEN
              CALL FMMPY(MBERN(NPTBRN(N2)),M20,M19)
              GO TO 130
          ENDIF
      ENDIF

      IF (MBSBRN /= MBASE) THEN
          NUMBRN = 0
          NWDBRN = 0
      ENDIF

!             See if the MBERN array is big enough to hold the
!             additional Bernoulli numbers up to B(N).

      NSTART = 28
      IF (MBSBRN == MBASE .AND. NUMBRN >= 28) THEN
          NSTART = NUMBRN + 2
          DO J = 28, NUMBRN-2, 2
             J2 = J/2
             JSIZE = NPTBRN(J2+1) - NPTBRN(J2)
             IF (JSIZE < NDIG+3) THEN
                 NSTART = J
                 NWDBRN = NPTBRN(J2) - 1
                 GO TO 120
             ENDIF
          ENDDO
          JSIZE = NWDBRN - NPTBRN(NUMBRN/2)
          IF (JSIZE < NDIG+2) THEN
              NSTART = NUMBRN
              NWDBRN = NPTBRN(NUMBRN/2) - 1
              GO TO 120
          ENDIF
      ENDIF

  120 NEEDED = ((N-NSTART)/2+1)*(NDIG+3)
      IF (NEEDED > LMBERN-NWDBRN) THEN
          KFLAG = -11
          CALL FMWRN2
          WRITE (KW,*) ' Out of memory for storing Bernoulli numbers in FMBERN.'
          WRITE (KW,*) ' For B(',N,') with NDIG = ',NDIG,', ',NEEDED+NWDBRN,  &
                ' words are needed.'
          WRITE (KW,*) ' The current dimension of MBERN is ',LMBERN
          WRITE (KW,*) ' '
          MXEXP = MXSAVE
          NDIG = NDSAVE
          CALL FMST2M('UNKNOWN',MB)
          IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
          NCALL = NCALL - 1
          KACCSW = KASAVE
          RETURN
      ENDIF

!             Compute more Bernoulli numbers.

      X = 1.0D0
      B = DBLE(MBASE)
      NDP = 0
      DO J = 1, 80
         X = X/B
         IF ((1.0D0+X) <= 1.0D0) THEN
             NDP = J-1
             IF (NDIG <= NDP) X = 4.0D0*DPPI*DPPI
             EXIT
         ENDIF
      ENDDO
      INTNDG = INT(ALOGMX/ALOGMB + 1.0)
      NX = INT(DBLE(NDIG)*DLOGMB/DLOGTW + 2.0D0)

      DO J = NSTART, N, 2

!             Check to see if J is large enough so that the formula
!             B(J) = -B(J-2)*(J-1)*J/(2*pi)**2 can be used.

         IF (J >= NX .AND. NDIG <= NDP .AND. J > 28) THEN
             J2 = J/2
             MNEXP = MBERN(NPTBRN(J2-1)+2)
             MBERN(NPTBRN(J2-1)+2) = 0
             CALL FMM2DP(MBERN(NPTBRN(J2-1)),U)
             MBERN(NPTBRN(J2-1)+2) = MNEXP
             U = -U*(J*J-J)/X
             NPTBRN(J2) = NWDBRN + 1
             NUMBRN = J
             MBSBRN = MBASE
             NWDBRN = NPTBRN(J2) + NDIG + 02
             CALL FMDPM(U,MBERN(NPTBRN(J2)))
             MBERN(NPTBRN(J2)+2) = MBERN(NPTBRN(J2)+2) + MNEXP
             CYCLE
         ENDIF

         IF (J >= NX .AND. J > 28) THEN
             J2 = J/2
             NPTBRN(J2) = NWDBRN + 1
             NUMBRN = J
             MBSBRN = MBASE
             NWDBRN = NPTBRN(J2) + NDIG + 02
             CALL FMPI(M17)
             CALL FMSQR_R1(M17)
             IF (MOD(J,4) == 0 .OR. MOD(J,4) == 1) THEN
                 L = -(J*J-J)/4
                 CALL FMMPYI(MBERN(NPTBRN(J2-1)),L,M18)
             ELSE
                 L = -(J*J-J)
                 CALL FMMPYI(MBERN(NPTBRN(J2-1)),L,M18)
                 CALL FMDIVI_R1(M18,4)
             ENDIF
             CALL FMDIV(M18,M17,MBERN(NPTBRN(J2)))
             CYCLE
         ENDIF

!             Use the recurrence involving a sum of binomial
!             coefficients times previous B's.

         NTOP = J + 3
         NBOT = J - 6
         LARGE = INT(INTMAX/NTOP)
         LARGED = MIN(LARGE,INT(MXBASE))
         CALL FMCMBI(NTOP,NBOT,M17)
         IF (NBOT <= 26) THEN
             CALL FMBER2(NBOT,M17,M18)
         ELSE
             CALL FMMPY(MBERN(NPTBRN(NBOT/2)),M17,M18)
         ENDIF
         NDSAV1 = NDIG
         DO NBOT = J-12, 0, -6
            NTN = NBOT + 6
            NTD = NTOP - NBOT - 5
            NEXTN = NTN
            NEXTD = NTD
            IF (NBOT >= 6) THEN
                NDSAV2 = NDIG
                DO K = 1, 5
                   NEXTN = NEXTN - 1
                   NEXTD = NEXTD + 1
                   NMPY = NTN*NEXTN
                   NDIV = NTD*NEXTD
                   IF (NMPY <= LARGE .AND. NDIV <= LARGED) THEN
                       NTN = NMPY
                       NTD = NDIV
                   ELSE
                       CALL FMGCDI(NMPY,NDIV)
                       IF (NMPY <= LARGE .AND. NDIV <= LARGED) THEN
                           NTN = NMPY
                           NTD = NDIV
                       ELSE
                           NDIG = MAX(2,MIN(NDSAV2,INT(M17(1))+INTNDG))
                           CALL FMMPYI_R1(M17,NTN)
                           CALL FMDIVI_R1(M17,NTD)
                           NTN = NEXTN
                           NTD = NEXTD
                       ENDIF
                   ENDIF
                ENDDO
                NDIG = MAX(2,MIN(NDSAV2,INT(M17(1))+INTNDG))
                CALL FMMPYI_R1(M17,NTN)
                CALL FMDIVI_R1(M17,NTD)
                NDIG = NDSAV2
            ELSE
                CALL FMCMBI(NTOP,NBOT,M17)
            ENDIF
            M17(0) = NINT(NDIG*ALOGM2)

!             Now M17 is the combination NTOP choose NBOT.

            IF (NBOT <= 26) THEN
                CALL FMBER2(NBOT,M17,M19)
            ELSE
                CALL FMMPY(MBERN(NPTBRN(NBOT/2)),M17,M19)
            ENDIF
            NDIG = NDSAV1
            CALL FMADD_R1(M18,M19)
            NDIG = MAX(2,NDSAV1-INT(M18(1)-M19(1)))
         ENDDO

         NDIG = NDSAV1
         IF (MOD(J,6) == 4) THEN
             CALL FMI2M(NTOP,M16)
             CALL FMDIVI(M16,-6,M19)
             CALL FMSUB_R2(M19,M18)
         ELSE
             CALL FMI2M(NTOP,M16)
             CALL FMDIVI(M16,3,M19)
             CALL FMSUB_R2(M19,M18)
         ENDIF

         J2 = J/2
         NPTBRN(J2) = NWDBRN + 1
         NUMBRN = J
         MBSBRN = MBASE
         NWDBRN = NPTBRN(J2) + NDIG + 02

         CALL FMMPYI_R1(M18,6)
         NTN = NTOP*(NTOP-1)
         LARGE = INT(INTMAX/NTOP)
         IF (NTN > MXBASE .OR. NTOP > LARGE) THEN
             CALL FMDIVI_R1(M18,NTOP)
             NTN = NTOP - 1
             CALL FMDIVI_R1(M18,NTN)
             NTN = NTOP - 2
             CALL FMDIVI(M18,NTN,MBERN(NPTBRN(J2)))
         ELSE IF (NTN*(NTOP-2) > MXBASE .OR. NTN > LARGE) THEN
             CALL FMDIVI_R1(M18,NTN)
             NTN = NTOP - 2
             CALL FMDIVI(M18,NTN,MBERN(NPTBRN(J2)))
         ELSE
             NTN = NTN*(NTOP-2)
             CALL FMDIVI(M18,NTN,MBERN(NPTBRN(J2)))
         ENDIF
      ENDDO

      CALL FMMPY(MBERN(NPTBRN(N2)),M20,M19)

!             Check for too much cancellation.

  130 IF (NCALL <= 1) THEN
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
      ELSE
          NGOAL = INT(-MXEXP2)
      ENDIF
      IF (M19(0) <= NGOAL) THEN
          IF (NUMTRY > 0) THEN
              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
              DO J = 1, NDGOAL+1
                 IF (MRETRY(J) /= M19(J)) GO TO 140
              ENDDO
              GO TO 150
          ENDIF
  140     IEXTRA = INT(REAL(NGOAL-M19(0))/ALOGM2 + 23.03/ALOGMB) + 1
          NDOLD = NDIG
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDIG - IEXTRA
              CALL FMST2M('UNKNOWN',M19)
              GO TO 150
          ENDIF
          CALL FMEQ2_R1(M20,NDSAVE,NDIG)
          NUMTRY = NUMTRY + 1
          CALL FMEQ2(M19,MRETRY,NDOLD,NDIG)
          GO TO 110
      ENDIF

  150 MACMAX = NINT(NDSAVE*ALOGM2)
      M19(0) = MIN(M19(0),MACCA,MACMAX)
      CALL FMEXT2(M19,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMBERN

      SUBROUTINE FMBER2(N,MA,MB)

!  Internal routine for small Bernoulli numbers.

!  MB = MA*B(N) for N an even integer between 2 and 26.

      USE FMVALS
      IMPLICIT NONE

      INTEGER N
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER N2
      INTEGER :: NBTOP(13) = (/  &
              1,   1,  1,   1,  5, -691, 7, -3617, 43867, -174611,  &
                  854513, -236364091, 8553103 /)
      INTEGER :: NBBOT(13) = (/  &
              6, -30, 42, -30, 66, 2730, 6,   510,   798,     330,  &
                     138,       2730,       6 /)

      IF (N <= 0) THEN
          CALL FMEQ(MA,MB)
          RETURN
      ELSE IF (N == 1) THEN
          CALL FMDIVI(MA,-2,MB)
          RETURN
      ELSE IF (MOD(N,2) == 1) THEN
          CALL FMI2M(0,MB)
          RETURN
      ENDIF

      N2 = N/2

      IF (N <= 26) THEN
          IF (NBTOP(N2) == 1) THEN
              CALL FMDIVI(MA,NBBOT(N2),MB)
          ELSE
              CALL FMMPYI(MA,NBTOP(N2),MB)
              CALL FMDIVI_R1(MB,NBBOT(N2))
          ENDIF
      ENDIF
      RETURN
      END SUBROUTINE FMBER2

      SUBROUTINE FMBETA(MA,MB,MC)

!  MC = beta(MA,MB).  beta(MA,MB) = gamma(MA) * gamma(MB) / gamma(MA+MB)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MXSAVE,MZERO
      INTEGER IEXTRA,J,K,K10,K11,KASAVE,KB,KC,KFLKB,KFLNKB,KOVUN,KRESLT,  &
              KWRNSV,N,NB,NBOT,NDGOAL,NDOLD,NDSAVE,NGOAL,NK,NKB,NUMTRY
      LOGICAL FMCOMP
      REAL X

      CALL FMENT2('FMBETA',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      KACCSW = 1
      MACCA = MA(0)
      MACCB = MB(0)
      CALL FMEQ2(MA,M29,NDSAVE,NDIG)
      M29(0) = NINT(NDIG*ALOGM2)
      CALL FMEQ2(MB,M30,NDSAVE,NDIG)
      M30(0) = NINT(NDIG*ALOGM2)
      CALL FMEQ(M29,M32)
      NUMTRY = 0

  110 CALL FMADD(M29,M30,M28)
      IF (M29(2) == 0 .OR. M30(2) == 0) THEN
          CALL FMST2M('UNKNOWN',M33)
          KFLAG = -4
          GO TO 140
      ENDIF
      IF (FMCOMP(M28,'==',M29)) THEN
          IF (M30(1) > MEXPAB) THEN
              CALL FMABS(M30,M23)
              CALL FMDPM(DLOGMB,M16)
              CALL FMMPY_R2(M16,M23)
              J = (M29(1)+1)
              CALL FMMPYI_R1(M23,J)
          ELSE
              CALL FMEQ(M30,M23)
          ENDIF
          CALL FMI2M(1,M16)
          CALL FMULP(M16,M17)
          CALL FMEQ(M17,M16)
          IF (FMCOMP(M23,'<=',M16)) THEN
              CALL FMGAM(M30,M33)
              GO TO 140
          ENDIF
      ENDIF
      IF (FMCOMP(M28,'==',M30)) THEN
          IF (M29(1) > MEXPAB) THEN
              CALL FMABS(M29,M23)
              CALL FMDPM(DLOGMB,M16)
              CALL FMMPY_R2(M16,M23)
              J = (M30(1)+1)
              CALL FMMPYI_R1(M23,J)
          ELSE
              CALL FMEQ(M29,M23)
          ENDIF
          CALL FMI2M(1,M16)
          CALL FMULP(M16,M17)
          CALL FMEQ(M17,M16)
          IF (FMCOMP(M23,'<=',M16)) THEN
              CALL FMGAM(M29,M33)
              GO TO 140
          ENDIF
      ENDIF
      IF (M29(1) == MEXPOV) THEN
          IF (M29(-1)*M29(2) > 0 .AND. M30(-1) > 0 .AND. M30(1) >= 1) THEN
              CALL FMST2M('UNDERFLOW',M33)
              KFLAG = -6
              GO TO 140
          ENDIF
      ENDIF
      IF (M30(1) == MEXPOV) THEN
          IF (M30(-1)*M30(2) > 0 .AND. M29(-1) > 0 .AND. M29(1) >= 1) THEN
              CALL FMST2M('UNDERFLOW',M33)
              KFLAG = -6
              GO TO 140
          ENDIF
      ENDIF

!             See if any of the terms are negative integers.

      CALL FMINT(M29,M18)
      IF (M29(-1) < 0) THEN
          IF (FMCOMP(M29,'==',M18)) THEN
              CALL FMST2M('UNKNOWN',M33)
              KFLAG = -4
              GO TO 140
          ENDIF
      ENDIF
      CALL FMINT(M30,M19)
      IF (M30(-1) < 0) THEN
          IF (FMCOMP(M30,'==',M19)) THEN
              CALL FMST2M('UNKNOWN',M33)
              KFLAG = -4
              GO TO 140
          ENDIF
      ENDIF
      IF (M28(2) == 0) THEN
          CALL FMI2M(0,M33)
          GO TO 120
      ELSE IF (M28(-1) < 0) THEN
          CALL FMSUB(M29,M18,M16)
          CALL FMSUB(M30,M19,M23)
          CALL FMADD_R2(M16,M23)
          CALL FMINT(M23,M24)
          IF (FMCOMP(M23,'==',M24)) THEN
              CALL FMI2M(0,M33)
              GO TO 120
          ENDIF
      ENDIF

!             See if any of the terms are small integers.

      KWRNSV = KWARN
      KWARN = 0
      CALL FMM2I(M29,N)
      KFLKB = KFLAG
      CALL FMM2I(M30,K)
      KFLNKB = KFLAG
      CALL FMM2I(M28,NK)
      KWARN = KWRNSV
      NB = N + K - 2
      KB = N - 1
      NKB = K - 1

      IF (KFLKB == 0 .AND. KFLNKB == 0) THEN
          IF (MIN(KB,NKB) <= 200) THEN
              CALL FMCMBI(NB,KB,M33)
              CALL FMI2M(N+K-1,M18)
              CALL FMMPY_R1(M33,M18)
              CALL FMI2M(1,M16)
              CALL FMDIV_R2(M16,M33)
              GO TO 120
          ENDIF
      ENDIF
      NBOT = 0
      IF (KFLKB == 0 .AND. N <= 200) THEN
          CALL FMEQ(M30,M31)
          CALL FMPOCH(M31,N,M15)
          CALL FMEQ(M15,M31)
          CALL FMFCTI(KB,M21)
          CALL FMDIV(M21,M31,M32)
          IF (ABS(M32(1)) < MXSAVE) THEN
              CALL FMEQ(M32,M33)
              GO TO 140
          ENDIF
          NBOT = 1
      ELSE IF (KFLNKB == 0 .AND. K <= 200) THEN
          CALL FMEQ(M29,M31)
          CALL FMPOCH(M31,K,M15)
          CALL FMEQ(M15,M31)
          CALL FMFCTI(NKB,M21)
          CALL FMDIV(M21,M31,M32)
          IF (ABS(M32(1)) < MXSAVE) THEN
              CALL FMEQ(M32,M33)
              GO TO 140
          ENDIF
          NBOT = 1
      ENDIF
      IF (NBOT == 1) THEN
          CALL FMEQ2(MA,M29,NDSAVE,NDIG)
          M29(0) = NINT(NDIG*ALOGM2)
          CALL FMEQ2(MB,M30,NDSAVE,NDIG)
          M30(0) = NINT(NDIG*ALOGM2)
          CALL FMEQ(M29,M32)
          CALL FMADD(M29,M30,M28)
      ENDIF

!             General case.  Use FMGAM, unless one of the numbers
!             is too big.  If so, use FMLNGM.

      X = ALOGMB*REAL(MXEXP)
      CALL FMSP2M(X/LOG(X),M17)
      CALL FMABS(M28,M04)
      CALL FMABS(M29,M05)
      CALL FMABS(M30,M06)
      IF (FMCOMP(M04,'>=',M17) .OR. FMCOMP(M05,'>=',M17) .OR.  &
          FMCOMP(M06,'>=',M17)) THEN

!             See if one argument is not very large and the other is
!             much larger.  For many of these cases, Stirling's formula
!             can be used to simplify Beta and avoid cancellation.

          IF (M29(1) > M30(1)) THEN
              CALL FMEQ(M29,M20)
              CALL FMEQ(M30,M21)
          ELSE
              CALL FMEQ(M30,M20)
              CALL FMEQ(M29,M21)
          ENDIF
          IF (M20(1) > NDIG .AND. M20(1) >= M21(1)+NDIG) THEN
              IF (M21(-1) < 0) THEN
                  IF (M21(1) > NDIG) THEN
                      KFLAG = -9
                      CALL FMWRN2
                      NDIG = NDIG - IEXTRA
                      CALL FMST2M('UNKNOWN',M33)
                      GO TO 140
                  ELSE
                      CALL FMI2M(2,M04)
                      CALL FMEQ(M21,M05)
                      M05(-1) = -M05(-1)
                      CALL FMINT(M05,M16)
                      CALL FMMOD(M16,M04,M22)
                      IF (M22(2) == 0) THEN
                          CALL FMADD(M20,M21,M27)
                          CALL FMLN(M27,M16)
                          CALL FMMPY(M21,M16,M27)
                          CALL FMI2M(1,M16)
                          CALL FMADD(M21,M16,M28)
                          CALL FMEQ(M21,M31)
                          CALL FMLNGM(M28,M14)
                          CALL FMEQ(M14,M28)
                          CALL FMSUB(M28,M27,M16)
                          CALL FMEXP(M16,M23)
                          CALL FMDIV_R1(M23,M31)
                          CALL FMEQ(M23,M33)
                          GO TO 120
                      ENDIF
                  ENDIF
              ENDIF
                  CALL FMADD(M20,M21,M27)
                  CALL FMLN(M27,M16)
                  CALL FMMPY(M21,M16,M27)
              CALL FMEQ(M21,M31)
              CALL FMLNGM(M31,M28)
              CALL FMSUB(M28,M27,M16)
              CALL FMEXP(M16,M23)
              CALL FMEQ(M23,M33)
              GO TO 120
          ENDIF

!             See if both arguments are large.  For many of these cases,
!             Stirling's formula can be used to detect cases where the
!             result will underflow.

          CALL FMDPM(1.0D7,M16)
          IF (FMCOMP(M29,'>',M16) .AND. FMCOMP(M30,'>',M16)) THEN
              CALL FMADD(M29,M30,M16)
              CALL FMLN(M16,M26)
              CALL FMMPY_R2(M16,M26)
              IF (M26(1) /= MUNKNO .AND. M26(2) /= 0) M26(-1) = -M26(-1)
              CALL FMLN(M29,M16)
              CALL FMMPY_R2(M29,M16)
              CALL FMADD_R1(M26,M16)
              CALL FMLN(M30,M16)
              CALL FMMPY_R2(M30,M16)
              CALL FMADD_R1(M26,M16)
              CALL FMEXP(M26,M27)
              IF (M27(1) == MEXPUN) THEN
                  CALL FMEQ(M27,M33)
                  GO TO 140
              ENDIF
          ENDIF

!             Compute IEXTRA, the number of extra digits required
!             to compensate for cancellation error.

          MZERO = 0
          IEXTRA = INT(MAX(M28(1),M29(1),M30(1),MZERO))
          IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
              CALL FMEQ2_R1(M29,NDIG,NDIG+IEXTRA)
              CALL FMEQ2_R1(M30,NDIG,NDIG+IEXTRA)
          ENDIF
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDIG - IEXTRA
              CALL FMST2M('UNKNOWN',M33)
              GO TO 140
          ENDIF
          CALL FMADD(M29,M30,M28)
          CALL FMI2M(1,M20)
          CALL FMI2M(2,M21)
          CALL FMEQ(M28,M33)
          K10 = 0
          K11 = 0
          KC = 0
          IF (M29(-1) < 0) THEN
              CALL FMINT(M29,M22)
              CALL FMMOD(M22,M21,M23)
              IF (M23(2) == 0) THEN
                  K10 = 1
                  CALL FMADD_R1(M29,M20)
              ENDIF
          ENDIF
          IF (M30(-1) < 0) THEN
              CALL FMINT(M30,M22)
              CALL FMMOD(M22,M21,M23)
              IF (M23(2) == 0) THEN
                  K11 = 1
                  CALL FMADD_R1(M30,M20)
              ENDIF
          ENDIF
          IF (M33(-1) < 0) THEN
              CALL FMINT(M33,M22)
              CALL FMMOD(M22,M21,M23)
              IF (M23(2) == 0) THEN
                  KC = 1
                  CALL FMADD_R1(M33,M20)
              ENDIF
          ENDIF
          CALL FMLNGM(M29,M28)
          CALL FMLNGM(M30,M31)
          CALL FMADD_R1(M28,M31)
          CALL FMLNGM(M33,M31)
          CALL FMSUB(M28,M31,M16)
          CALL FMEXP(M16,M28)
          IF (K10 == 1 .OR. K11 == 1 .OR. KC == 1) THEN
              CALL FMI2M(1,M20)
              IF (K10 == 1) THEN
                  CALL FMSUB_R1(M29,M20)
                  CALL FMDIV_R1(M28,M29)
              ENDIF
              IF (K11 == 1) THEN
                  CALL FMSUB_R1(M30,M20)
                  CALL FMDIV_R1(M28,M30)
              ENDIF
              IF (KC == 1) THEN
                  CALL FMSUB_R1(M33,M20)
                  CALL FMMPY_R1(M28,M33)
              ENDIF
          ENDIF
          CALL FMEQ(M28,M33)
      ELSE
          CALL FMEQ(M28,M33)
          CALL FMGAM(M29,M31)
          CALL FMEQ(M31,M29)
          CALL FMGAM(M30,M31)
          CALL FMEQ(M31,M30)
          CALL FMGAM(M33,M31)
          CALL FMEQ(M31,M33)
          CALL FMMPY(M29,M30,M18)
          CALL FMDIV_R2(M18,M33)
      ENDIF

!             Check for too much cancellation.

  120 IF (NCALL <= 1) THEN
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
      ELSE
          NGOAL = INT(-MXEXP2)
      ENDIF
      IF (M33(0) <= NGOAL) THEN
          IF (NUMTRY > 0) THEN
              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
              DO J = 1, NDGOAL+1
                 IF (MRETRY(J) /= M33(J)) GO TO 130
              ENDDO
              GO TO 140
          ENDIF
  130     IEXTRA = INT(REAL(NGOAL-M33(0))/ALOGM2 + 23.03/ALOGMB) + 1
          NDOLD = NDIG
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDIG - IEXTRA
              CALL FMST2M('UNKNOWN',M33)
              GO TO 140
          ENDIF
          CALL FMEQ2(MA,M29,NDSAVE,NDIG)
          CALL FMEQ2(MB,M30,NDSAVE,NDIG)
          NUMTRY = NUMTRY + 1
          CALL FMEQ2(M33,MRETRY,NDOLD,NDIG)
          GO TO 110
      ENDIF

  140 MACMAX = NINT(NDSAVE*ALOGM2)
      M33(0) = MIN(M33(0),MACCA,MACCB,MACMAX)
      CALL FMEXT2(M33,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMBETA

      SUBROUTINE FMCMBI(N,K,MA)

!  Internal routine for computing binomial coefficients for integers.

!  MA = N choose K.

      USE FMVALS
      IMPLICIT NONE

      INTEGER N,K
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      INTEGER INTNDG,J,KSTART,KT,L,LARGE,LARGED,NDIV,NDSAVE,NEXTD,NEXTN,  &
              NMPY,NTD,NTN

      IF (MBLOGS /= MBASE) CALL FMCONS
      L = MIN(K,N-K)
      IF (L <= 0) THEN
          CALL FMI2M(1,MA)
          RETURN
      ENDIF
      IF (L <= 1) THEN
          CALL FMI2M(N,MA)
          RETURN
      ENDIF

!             Find the largest value for N choose J using integers.

      NTN = N
      NTD = 1
      LARGE = INT(INTMAX/N)
      DO J = 2, L
         IF (NTN <= LARGE) THEN
             NTN = (NTN*((N+1)-J))/J
         ELSE
             CALL FMI2M(NTN,MA)
             NTN = (N+1) - J
             NTD = J
             GO TO 110
         ENDIF
      ENDDO

  110 IF (NTD == 1) THEN
          CALL FMI2M(NTN,MA)
          RETURN
      ENDIF

      INTNDG = INT(ALOGMX/ALOGMB + 1.0)
      NEXTN = NTN
      NEXTD = NTD
      KSTART = NTD + 1
      NDSAVE = NDIG

!             Compute the rest of N choose K.

      LARGED = MIN(LARGE,INT(MXBASE))
      DO KT = KSTART, L
         NEXTN = NEXTN - 1
         NEXTD = NEXTD + 1
         IF (NTN >= LARGE .OR. NTD >= LARGED) THEN
             NDIG = MAX(2,MIN(NDSAVE,INT(MA(1))+INTNDG))
             CALL FMMPYI_R1(MA,NTN)
             CALL FMDIVI_R1(MA,NTD)
             NTN = NEXTN
             NTD = NEXTD
             CYCLE
         ENDIF
         NMPY = NTN*NEXTN
         NDIV = NTD*NEXTD
         IF (NMPY <= LARGE .AND. NDIV <= LARGED) THEN
             NTN = NMPY
             NTD = NDIV
         ELSE
             CALL FMGCDI(NMPY,NDIV)
             IF (NMPY <= LARGE .AND. NDIV <= LARGED) THEN
                 NTN = NMPY
                 NTD = NDIV
             ELSE
                 NDIG = MAX(2,MIN(NDSAVE,INT(MA(1))+INTNDG))
                 CALL FMMPYI_R1(MA,NTN)
                 CALL FMDIVI_R1(MA,NTD)
                 NTN = NEXTN
                 NTD = NEXTD
             ENDIF
         ENDIF
      ENDDO
      NDIG = MAX(2,MIN(NDSAVE,INT(MA(1))+INTNDG))
      CALL FMGCDI(NTN,NTD)
      CALL FMMPYI_R1(MA,NTN)
      CALL FMDIVI_R1(MA,NTD)
      NDIG = NDSAVE
      MA(0) = NINT(ALOGM2*NDSAVE)

      RETURN
      END SUBROUTINE FMCMBI

      SUBROUTINE FMCOMB(MA,MB,MC)

!  MC = MA choose MB.  (Binomial coefficient -- uses gamma for non-integers)

!  MC = (MA)! / ( (MB)! * (MA-MB)! )

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MXSAVE,MZERO
      INTEGER IEXTRA,J,K,K09,K10,K11,KASAVE,KBOT,KC,KFLGK,KFLGNK,KOVUN,    &
              KRESLT,KSIGN,KWRNSV,LARGE,N,NBOT,NDGOAL,NDOLD,NDSAVE,NGOAL,  &
              NK,NUMTRY
      LOGICAL FMCOMP
      LOGICAL LC1,LC2,LC3
      REAL X

      CALL FMENT2('FMCOMB',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      KSIGN = 1
      KACCSW = 1
      MACCA = MA(0)
      MACCB = MB(0)
      CALL FMEQ2(MA,M29,NDSAVE,NDIG)
      M29(0) = NINT(NDIG*ALOGM2)
      CALL FMEQ2(MB,M30,NDSAVE,NDIG)
      M30(0) = NINT(NDIG*ALOGM2)
      NUMTRY = 0

  110 CALL FMSUB(M29,M30,M28)
      IF (M30(2) == 0) THEN
          CALL FMI2M(1,M32)
          GO TO 120
      ENDIF

!             See if any of the terms are negative integers.

      CALL FMI2M(1,M22)
      K10 = 0
      IF (M29(-1) < 0) THEN
          CALL FMINT(M29,M18)
          IF (FMCOMP(M29,'==',M18)) K10 = -1
      ENDIF
      K11 = 0
      IF (M30(-1) < 0) THEN
          CALL FMINT(M30,M19)
          IF (FMCOMP(M30,'==',M19)) K11 = -1
      ENDIF
      K09 = 0
      IF (FMCOMP(M29,'<',M30)) THEN
          CALL FMMOD(M29,M22,M20)
          CALL FMMOD(M30,M22,M21)
          CALL FMSUB_R2(M20,M21)
          CALL FMINT(M21,M20)
          IF (FMCOMP(M21,'==',M20)) K09 = -1
      ENDIF

      CALL FMI2M(2,M21)

      IF (K11 == -1) THEN
          CALL FMI2M(0,M32)
          GO TO 120
      ELSE IF (M28(2) == 0) THEN
          CALL FMI2M(1,M32)
          GO TO 120
      ELSE IF (K09 == -1 .AND. K10 == 0) THEN
          CALL FMI2M(0,M32)
          GO TO 120
      ELSE IF (K10 == -1 .AND. K09 == 0) THEN
          CALL FMST2M('UNKNOWN',M32)
          KFLAG = -4
          GO TO 140
      ELSE IF (K10 == -1 .AND. K09 == -1) THEN
          CALL FMMOD(M30,M21,M23)
          IF (M23(2) /= 0) KSIGN = -1
          CALL FMSUB(M30,M29,M23)
          CALL FMSUB(M23,M22,M29)
          CALL FMSUB(M29,M30,M28)
      ENDIF

!             Check for an obviously overflowed result.

      IF (M29(1) == MEXPOV) THEN
          IF (M29(-1)*M29(2) > 0 .AND. M30(-1) > 0 .AND. M30(1) >= 1  &
              .AND. M30(1) < MEXPOV) THEN
              CALL FMST2M('OVERFLOW',M32)
              KFLAG = -5
              GO TO 140
          ENDIF
      ENDIF
      IF (M29(1) >= 10000) THEN
          CALL FMI2M(1,M16)
          IF (FMCOMP(M30,'>',M16) .AND. FMCOMP(M30,'<',M29)) THEN
              CALL FMSUB(M29,M30,M16)
              CALL FMMIN(M30,M16,M24)
              CALL FMSUB(M29,M24,M16)
              CALL FMADDI(M16,1)
              CALL FMDIV(M16,M24,M23)
              CALL FMLN(M23,M16)
              CALL FMADDI(M16,1)
              CALL FMMPY(M24,M16,M23)
              CALL FMDPM(6.283185D0,M06)
              CALL FMMPY(M06,M24,M16)
              CALL FMLN(M16,M06)
              CALL FMDIVI(M06,2,M16)
              CALL FMSUB_R1(M23,M16)
              CALL FMEXP(M23,M12)
              CALL FMEQ(M12,M23)
              IF (M23(1) == MEXPOV) THEN
                  CALL FMST2M('OVERFLOW',M32)
                  KFLAG = -5
                  GO TO 140
              ENDIF
          ENDIF
      ENDIF

!             See if any of the terms are small integers.

      KWRNSV = KWARN
      KWARN = 0
      CALL FMM2I(M29,N)
      CALL FMM2I(M30,K)
      KFLGK = KFLAG
      CALL FMM2I(M28,NK)
      KFLGNK = KFLAG
      KWARN = KWRNSV

      CALL FMI2M(1,M16)
      CALL FMADD(M29,M16,M06)
      CALL FMSUB_R1(M06,M16)
      IF (KFLGK == 0 .AND. M06(2) == 0) THEN
          CALL FMI2M(2,M32)
          CALL FMMOD(M30,M32,M16)
          CALL FMEQ(M16,M32)
          IF (M32(2) == 0) THEN
              CALL FMDIV(M29,M30,M32)
              IF (M32(1) /= MUNKNO .AND. M32(2) /= 0) M32(-1) = -M32(-1)
          ELSE
              CALL FMDIV(M29,M30,M32)
          ENDIF
          GO TO 120
      ENDIF
      IF (KFLGK == 0 .AND. KFLGNK == 0 .AND. N /= 0) THEN
          IF (MIN(K,NK) <= 200) THEN
              CALL FMCMBI(N,K,M32)
              GO TO 120
          ENDIF
      ENDIF
      NBOT = 0
      IF (KFLGK == 0 .AND. K <= 200) NBOT = K
      IF (KFLGNK == 0 .AND. NK <= 200) NBOT = NK
      IF (NBOT > 0) THEN
          LARGE = INT(MXBASE/NBOT)
          KBOT = 1
          CALL FMEQ(M29,M18)
          CALL FMEQ(M29,M19)
          CALL FMI2M(-1,M20)
          DO J = 2, NBOT
             CALL FMADD_R1(M18,M20)
             CALL FMMPY_R2(M18,M19)
             KBOT = KBOT*J
             IF (KBOT >= LARGE) THEN
                 CALL FMDIVI_R1(M19,KBOT)
                 KBOT = 1
             ENDIF
          ENDDO
          CALL FMDIVI(M19,KBOT,M32)
          GO TO 120
      ENDIF

!             General case.  Use FMFACT, unless one of the numbers
!             is too big.  If so, use FMLNGM.

      X = ALOGMB*REAL(MXEXP)
      CALL FMSP2M(X/LOG(X),M17)
      CALL FMABS(M28,M16)
      LC1 = FMCOMP(M16,'>=',M17)
      CALL FMABS(M29,M16)
      LC2 = FMCOMP(M16,'>=',M17)
      CALL FMABS(M30,M16)
      LC3 = FMCOMP(M16,'>=',M17)
      IF (LC1 .OR. LC2 .OR. LC3) THEN

!             See if the second argument is not very large and the first
!             is much larger.  For many of these cases, Stirling's formula
!             can be used to simplify Comb and avoid cancellation.

          IF (M29(1) > M30(1) .AND. M29(-1) > 0 .AND.  &
              M30(-1) > 0) THEN
              CALL FMEQ(M29,M20)
              CALL FMEQ(M30,M21)
          ELSE
              CALL FMI2M(1,M20)
              CALL FMI2M(1,M21)
          ENDIF
          IF (M20(1) > NDIG .AND. M20(1) >= M21(1)+NDIG) THEN
              CALL FMI2M(1,M16)
              CALL FMADD(M21,M16,M31)
              CALL FMLN(M20,M16)
              CALL FMADDI(M16,-1)
              CALL FMMPY(M21,M16,M27)
              CALL FMADD_R2(M21,M27)
              CALL FMLNGM(M31,M28)
              CALL FMSUB(M27,M28,M16)
              CALL FMEXP(M16,M23)
              CALL FMEQ(M23,M32)
              GO TO 120
          ENDIF

!             Compute IEXTRA, the number of extra digits required
!             to compensate for cancellation error.

          MZERO = 0
          IEXTRA = INT(MAX(M28(1),M29(1),M30(1),MZERO))
          IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
              CALL FMEQ2_R1(M29,NDIG,NDIG+IEXTRA)
              CALL FMEQ2_R1(M30,NDIG,NDIG+IEXTRA)
          ENDIF
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDIG - IEXTRA
              CALL FMST2M('UNKNOWN',M32)
              CALL FMEXT2(M32,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
              RETURN
          ENDIF
          CALL FMSUB(M29,M30,M28)
          CALL FMI2M(1,M20)
          CALL FMI2M(2,M21)
          CALL FMADD(M28,M20,M32)
          CALL FMADD_R1(M29,M20)
          CALL FMADD_R1(M30,M20)
          K10 = 0
          K11 = 0
          KC = 0
          IF (M29(-1) < 0) THEN
              CALL FMINT(M29,M22)
              CALL FMMOD(M22,M21,M23)
              IF (M23(2) == 0) THEN
                  K10 = 1
                  CALL FMADD_R1(M29,M20)
              ENDIF
          ENDIF
          IF (M30(-1) < 0) THEN
              CALL FMINT(M30,M22)
              CALL FMMOD(M22,M21,M23)
              IF (M23(2) == 0) THEN
                  K11 = 1
                  CALL FMADD_R1(M30,M20)
              ENDIF
          ENDIF
          IF (M32(-1) < 0) THEN
              CALL FMINT(M32,M22)
              CALL FMMOD(M22,M21,M23)
              IF (M23(2) == 0) THEN
                  KC = 1
                  CALL FMADD_R1(M32,M20)
              ENDIF
          ENDIF
          CALL FMLNGM(M29,M28)
          CALL FMLNGM(M30,M31)
          CALL FMSUB_R1(M28,M31)
          CALL FMLNGM(M32,M31)
          CALL FMSUB_R1(M28,M31)
          CALL FMEXP(M28,M12)
          CALL FMEQ(M12,M28)
          IF (K10 == 1 .OR. K11 == 1 .OR. KC == 1) THEN
              CALL FMI2M(1,M20)
              IF (K10 == 1) THEN
                  CALL FMSUB_R1(M29,M20)
                  CALL FMDIV_R1(M28,M29)
              ENDIF
              IF (K11 == 1) THEN
                  CALL FMSUB_R1(M30,M20)
                  CALL FMMPY_R1(M28,M30)
              ENDIF
              IF (KC == 1) THEN
                  CALL FMSUB_R1(M32,M20)
                  CALL FMMPY_R1(M28,M32)
              ENDIF
          ENDIF
          CALL FMEQ(M28,M32)
      ELSE
          CALL FMEQ(M28,M32)
          CALL FMFACT(M29,M31)
          CALL FMEQ(M31,M29)
          CALL FMFACT(M30,M31)
          CALL FMEQ(M31,M30)
          CALL FMFACT(M32,M31)
          CALL FMEQ(M31,M32)
          CALL FMMPY(M32,M30,M18)
          CALL FMDIV(M29,M18,M32)
      ENDIF

!             Check for too much cancellation.

  120 IF (NCALL <= 1) THEN
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
      ELSE
          NGOAL = INT(-MXEXP2)
      ENDIF
      IF (M32(0) <= NGOAL) THEN
          IF (NUMTRY > 0) THEN
              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
              DO J = 1, NDGOAL+1
                 IF (MRETRY(J) /= M32(J)) GO TO 130
              ENDDO
              GO TO 140
          ENDIF
  130     IEXTRA = INT(REAL(NGOAL-M32(0))/ALOGM2 + 23.03/ALOGMB) + 1
          NDOLD = NDIG
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDIG - IEXTRA
              CALL FMST2M('UNKNOWN',M32)
              GO TO 140
          ENDIF
          CALL FMEQ2(MA,M29,NDSAVE,NDIG)
          CALL FMEQ2(MB,M30,NDSAVE,NDIG)
          NUMTRY = NUMTRY + 1
          CALL FMEQ2(M32,MRETRY,NDOLD,NDIG)
          GO TO 110
      ENDIF

  140 M32(-1) = KSIGN*M32(-1)
      MACMAX = NINT(NDSAVE*ALOGM2)
      M32(0) = MIN(M32(0),MACCA,MACCB,MACMAX)
      CALL FMEXT2(M32,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMCOMB

      FUNCTION FMDPLG(A)

!  Internal routine for computing an approximation to
!  Log(Gamma(A)) using Stirling's formula.

      USE FMVALS
      IMPLICIT NONE

      DOUBLE PRECISION FMDPLG,A

      IF (MBLOGS /= MBASE) CALL FMCONS
      IF (A > 0.0D0) THEN
          FMDPLG = -A + (A-0.5D0)*LOG(A) + DLOGTP/2.0D0
      ELSE IF (A < 0.0D0) THEN
          FMDPLG = -(A-1.0D0) - (0.5D0-A)*LOG(1.0D0-A) -  &
                   DLOGTP/2.0D0 - LOG(ABS(SIN(DPPI*A))+1.0D-10) +  &
                   DLOGPI
      ELSE

!             A = 0 is really an approximation for some value in [-1,1].

          FMDPLG = 0.0D0
      ENDIF
      RETURN
      END FUNCTION FMDPLG

      SUBROUTINE FMENT2(NROUTN,MA,MB,NARGS,KNAM,MC,KRESLT,NDSAVE,MXSAVE,  &
                        KASAVE,KOVUN)

!  Do the argument checking and increasing of precision, overflow
!  threshold, etc., upon entry to an FM routine.

!  NROUTN - routine name of calling routine
!  MA     - first input argument
!  MB     - second input argument (optional)
!  NARGS  - number of input arguments
!  KNAM   - positive if the routine name is to be printed.
!  MC     - result argument
!  KRESLT - returned nonzero if the input arguments give the result
!           immediately (e.g., MA*0 or OVERFLOW*MB)
!  NDSAVE - saves the value of NDIG after NDIG is increased
!  MXSAVE - saves the value of MXEXP
!  KASAVE - saves the value of KACCSW
!  KOVUN  - returned nonzero if an input argument is (+ or -) overflow
!           or underflow.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(6) :: NROUTN
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK),MXSAVE
      INTEGER KNAM,NARGS,KRESLT,NDSAVE,KASAVE,KOVUN

      INTEGER K

      IF (MBLOGS /= MBASE) CALL FMCONS
      NCALL = NCALL + 1
      NAMEST(NCALL) = NROUTN
      IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,NARGS,KNAM)
      CALL FMARG2(NROUTN,NARGS,MA,MB,KRESLT)

      KOVUN = 0
      IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
      IF (NARGS == 2) THEN
          IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1
      ENDIF

!             Increase the working precision.

      NDSAVE = NDIG
      MXSAVE = MXEXP
      KASAVE = KACCSW
      IF (NCALL == 1) THEN
          K = INT(5.0/ALOGMT + 2.0 + (REAL(NDIG)*ALOGMT)**0.35/ALOGMT)
          NDIG = MAX(NDIG+K,2)
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              KRESLT = 12
          ENDIF
      ENDIF

      IF (KRESLT /= 0) THEN
          IF (KRESLT == 9 .OR. KRESLT == 10 .OR. KRESLT >= 13) THEN
              IF (KRAD == 1) THEN
                  CALL FMPI(MC)
              ELSE
                  CALL FMI2M(180,MC)
              ENDIF
              IF (KRESLT <= 10) CALL FMDIVI_R1(MC,2)
              IF (KRESLT >= 14) CALL FMDIVI_R1(MC,4)
              CALL FMEQ2_R1(MC,NDIG,NDSAVE)
              NDIG = NDSAVE
              IF (KRESLT == 9 .OR. KRESLT == 14) MC(-1) = -1
              IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
              NCALL = NCALL - 1
              RETURN
          ENDIF

          NDIG = NDSAVE
          CALL FMRSLT(MA,MB,MC,KRESLT)
          IF (NTRACE /= 0 .AND. NROUTN /= 'FMIBTA') THEN
              CALL FMNTR(1,MC,MC,1,1)
          ENDIF
          NCALL = NCALL - 1
          RETURN
      ENDIF

!             Extend the overflow/underflow threshold.

      MXEXP = MXEXP2
      RETURN
      END SUBROUTINE FMENT2

      SUBROUTINE FMEULR(MA)

!  MA = Euler's constant ( 0.5772156649... )

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
      CHARACTER(2315) :: STRING
      INTEGER K,KASAVE,NDMB,NDSAVE,NDSV

      IF (MBLOGS /= MBASE) CALL FMCONS
      KFLAG = 0
      NCALL = NCALL + 1
      NAMEST(NCALL) = 'FMEULR'
      IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
          WRITE (KW,"(' Input to FMEULR')")
      ENDIF
      KASAVE = KACCSW

!             Increase the working precision.

      NDSAVE = NDIG
      IF (NCALL == 1) THEN
          K = INT(5.0/ALOGMT + 2.0 + (REAL(NDIG)*ALOGMT)**0.35/ALOGMT)
          NDIG = MAX(NDIG+K,2)
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDIG - K
              CALL FMST2M('UNKNOWN',MA)
              GO TO 110
          ENDIF
      ENDIF

!             Check to see if Euler's constant has previously been
!             saved in base MBASE with sufficient precision.

      IF (MBSEUL == MBASE .AND. NDGEUL >= NDIG) THEN
          CALL FMEQ2(M_EULER,MA,NDGEUL,NDSAVE)
      ELSE

!             Euler's constant is slower to compute (using PSI) than the
!             other saved constants, so more digits are stored in STRING
!             for quick conversion.

          NDMB = INT(2300.0*2.302585/ALOGMB)
          IF (NDMB >= NDIG) THEN
              NDSV = NDIG
              NDIG = MIN(NDMB,NDG2MX)
              STRING = '0.57721566490153286060651209008240243104215933593'//  &
              '9923598805767234884867726777664670936947063291746749514631'//  &
              '4472498070824809605040144865428362241739976449235362535003'//  &
              '3374293733773767394279259525824709491600873520394816567085'//  &
              '3233151776611528621199501507984793745085705740029921354786'//  &
              '1466940296043254215190587755352673313992540129674205137541'//  &
              '3954911168510280798423487758720503843109399736137255306088'//  &
              '9331267600172479537836759271351577226102734929139407984301'//  &
              '0341777177808815495706610750101619166334015227893586796549'//  &
              '7252036212879226555953669628176388792726801324310104765059'//  &
              '6370394739495763890657296792960100901512519595092224350140'//  &
              '9349871228247949747195646976318506676129063811051824197444'//  &
              '8678363808617494551698927923018773910729457815543160050021'//  &
              '8284409605377243420328547836701517739439870030237033951832'//  &
              '8690001558193988042707411542227819716523011073565833967348'//  &
              '7176504919418123000406546931429992977795693031005030863034'//  &
              '1856980323108369164002589297089098548682577736428825395492'//  &
              '5873629596133298574739302373438847070370284412920166417850'//  &
              '2487333790805627549984345907616431671031467107223700218107'//  &
              '4504441866475913480366902553245862544222534518138791243457'//  &
              '3501361297782278288148945909863846006293169471887149587525'//  &
              '4923664935204732436410972682761608775950880951262084045444'//  &
              '7799229915724829251625127842765965708321461029821461795195'//  &
              '7959095922704208989627971255363217948873764210660607065982'//  &
              '5619901028807561251991375116782176436190570584407835735015'//  &
              '8005607745793421314498850078641517161519456570617043245075'//  &
              '0081687052307890937046143066848179164968425491504967243121'//  &
              '8378387535648949508684541023406016225085155838672349441878'//  &
              '8044094077010688379511130787202342639522692097160885690838'//  &
              '2511378712836820491178925944784861991185293910293099059255'//  &
              '2669172744689204438697111471745715745732039352091223160850'//  &
              '8682755889010945168118101687497547096936667121020630482716'//  &
              '5895049327314860874940207006742590918248759621373842311442'//  &
              '6531350292303175172257221628324883811245895743862398703757'//  &
              '6628551303314392999540185313414158621278864807611003015211'//  &
              '9657800681177737635016818389733896639868957932991456388644'//  &
              '3103706080781744899579583245794189620260498410439225078604'//  &
              '6036252772602291968299586098833901378717142269178838195298'//  &
              '4456079160519727973604759102510995779133515791772251502549'//  &
              '2932463250287476779484215840507599290401855764599018627262'
              CALL FMST2M(STRING,M_EULER)
              M_EULER(0) = NINT(NDIG*ALOGM2)
              MBSEUL = MBASE
              NDGEUL = NDIG
              IF (ABS(M_EULER(1)) > 10) NDGEUL = 0
              CALL FMEQ2(M_EULER,MA,NDIG,NDSAVE)
              NDIG = NDSV
          ELSE
              NDSV = NDIG
              NDIG = MIN(NDIG+2,NDG2MX)
              CALL FMI2M(1,M_EULER)
              CALL FMPSI(M_EULER,M14)
              CALL FMEQ(M14,M_EULER)
              M_EULER(-1) = ABS(M_EULER(-1))
              MBSEUL = MBASE
              NDGEUL = NDIG
              IF (ABS(M_EULER(1)) > 10) NDGEUL = 0
              CALL FMEQ2(M_EULER,MA,NDIG,NDSAVE)
              NDIG = NDSV
          ENDIF
      ENDIF

  110 NDIG = NDSAVE
      KACCSW = KASAVE
      IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
      NCALL = NCALL - 1
      RETURN
      END SUBROUTINE FMEULR

      SUBROUTINE FMEXT2(MT,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)

!  Upon exit from an FM routine, the result MT (having precision NDIG)
!  is rounded and returned in MC (having precision NDSAVE).
!  The values of NDIG, MXEXP, and KACCSW are restored.
!  KOVUN is nonzero if one of the routine's input arguments was overflow
!  or underflow.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MT(-1:LUNPCK),MC(-1:LUNPCK),MXSAVE
      INTEGER NDSAVE,KASAVE,KOVUN

      INTEGER KFSAVE,KWRNSV

      KWRNSV = KWARN
      KWARN = 0
      MXEXP = MXSAVE
      KFSAVE = KFLAG
      CALL FMEQ2(MT,MC,NDIG,NDSAVE)
      IF (KFLAG /= -5 .AND. KFLAG /= -6) KFLAG = KFSAVE
      NDIG = NDSAVE
      KWARN = KWRNSV
      IF (KFLAG == 1) KFLAG = 0
      IF ((MC(1) == MUNKNO .AND. KFLAG /= -9)  &
         .OR. (MC(1) == MEXPUN .AND. KOVUN == 0)  &
         .OR. (MC(1) == MEXPOV .AND. KOVUN == 0)) CALL FMWRN2
      IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
      NCALL = NCALL - 1
      KACCSW = KASAVE
      RETURN
      END SUBROUTINE FMEXT2

      SUBROUTINE FMFACT(MA,MB)

!  MB = MA!  ( = GAMMA(MA+1))

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
      INTEGER J,KASAVE,KOVUN,KRESLT,NDSAVE

      CALL FMENT2('FMFACT',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      MACCA = MA(0)
      CALL FMEQ2(MA,MB,NDSAVE,NDIG)
      MB(0) = NINT(NDIG*ALOGM2)
      CALL FMADDI(MB,1)
      CALL FMGAM(MB,M15)
      CALL FMEQ(M15,MB)
      MACMAX = NINT(NDSAVE*ALOGM2)
      MB(0) = MIN(MB(0),MACCA,MACMAX)
      DO J = -1, NDIG+1
         M01(J) = MB(J)
      ENDDO
      CALL FMEXT2(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMFACT

      SUBROUTINE FMFCTI(NUM,MA)

!  MA = NUM factorial, where NUM is an integer.

      USE FMVALS
      IMPLICIT NONE

      INTEGER NUM
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)

      INTEGER J,JK,K,LARGE

      CALL FMI2M(1,MA)
      IF (NUM <= 1) RETURN
      J = NUM
      K = 1
      LARGE = INT(INTMAX/J)
      DO JK = 2, J
         K = K*JK
         IF (K > LARGE) THEN
             CALL FMMPYI_R1(MA,K)
             K = 1
         ENDIF
      ENDDO
      IF (K > 1) CALL FMMPYI_R1(MA,K)
      RETURN
      END SUBROUTINE FMFCTI

      SUBROUTINE FMGAM(MA,MB)

!  MB = GAMMA(MA)

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
      INTEGER IEXTRA,INTA,J,K,K0,K1,K2,KASAVE,KDIFF,KFL,KOVUN,KRESLT,  &
              KRFLCT,KRSAVE,KSIGN,KWRNSV,KWSAVE,LARGE,LSHIFT,NDGOAL,   &
              NDOLD,NDSAV2,NDSAVE,NGOAL,NUMTRY
      LOGICAL FMCOMP

      CALL FMENT2('FMGAM ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      KACCSW = 1
      MACCA = MA(0)
      CALL FMEQ2(MA,M28,NDSAVE,NDIG)
      M28(0) = NINT(NDIG*ALOGM2)
      NUMTRY = 0

!             See if there is a small integer separating this argument
!             from the last one.

      IF (MBASE == MBSGAM .AND. NDIG <= NDGGAM) THEN
          CALL FMSUB(M28,M_GAMMA_MA,M18)
          IF (M18(2) == 0) THEN
              CALL FMEQ(M_GAMMA_MB,M22)
              GO TO 140
          ENDIF
          KWRNSV = KWARN
          KWARN = 0
          CALL FMM2I(M18,KDIFF)
          KWARN = KWRNSV
          IF (KFLAG == 0 .AND. ABS(KDIFF) <= 50) THEN
              IF (KDIFF > 0) THEN
                  CALL FMEQ(M_GAMMA_MA,M21)
              ELSE
                  CALL FMEQ(M28,M21)
              ENDIF
              CALL FMEQ(M21,M20)
              DO J = 1, ABS(KDIFF)-1
                 CALL FMI2M(1,M16)
                 CALL FMADD_R1(M21,M16)
                 CALL FMMPY_R1(M20,M21)
              ENDDO
              IF (KDIFF > 0) THEN
                  CALL FMMPY(M_GAMMA_MB,M20,M22)
              ELSE
                  CALL FMDIV(M_GAMMA_MB,M20,M22)
              ENDIF
              GO TO 140
          ENDIF
      ENDIF

      CALL FMEQ(M28,M_GAMMA_MB)

!             Near zero Gamma(x) is about 1/x.

  110 IF (M_GAMMA_MB(1) < (-NDIG-3)) THEN
          CALL FMI2M(1,M16)
          CALL FMDIV(M16,M_GAMMA_MB,M22)
          GO TO 140
      ENDIF

!             Check for special cases.

      KRFLCT = 0
      CALL FMDPM(DBLE(-0.5),M18)
      IF (FMCOMP(M_GAMMA_MB,'<=',M18)) THEN
          KRFLCT = 1
          KFL = 0
          IF (M28(1) <= NDSAVE) THEN
              CALL FMINT(M_GAMMA_MB,M21)
              IF (FMCOMP(M_GAMMA_MB,'==',M21)) KFL = -4
          ELSE
              KFL = -4
          ENDIF
          IF (KFL /= 0) THEN
              CALL FMST2M('UNKNOWN',M22)
              KFLAG = -4
              GO TO 140
          ELSE
              CALL FMI2M(1,M16)
              CALL FMSUB_R2(M16,M_GAMMA_MB)
          ENDIF
      ENDIF

!             To speed the asymptotic series calculation, increase
!             the argument by LSHIFT.

      KWSAVE = KWARN
      KWARN = 0
      CALL FMM2I(M_GAMMA_MB,INTA)
      KWARN = KWSAVE

      IF (KFLAG == -4) THEN
          LSHIFT = 0
      ELSE
          LSHIFT = INT(MAX(0.0,REAL(NDIG)*ALOGMB/4.46-REAL(INTA)))
      ENDIF
      IF (LSHIFT > 0) LSHIFT = 4*(LSHIFT/4 + 1)
      IF (KFLAG == 0) THEN
          IF (INTA <= 200) THEN
              IF (INTA <= 2) THEN
                  CALL FMI2M(1,M22)
                  GO TO 120
              ENDIF
              INTA = INTA - 1
              CALL FMFCTI(INTA,M22)
              GO TO 120
          ENDIF
      ENDIF

      IF (LSHIFT /= 0) THEN
          CALL FMI2M(LSHIFT,M16)
          CALL FMADD(M_GAMMA_MB,M16,M27)
      ELSE
          CALL FMEQ(M_GAMMA_MB,M27)
      ENDIF

!             Get Gamma for the shifted argument.

!             Compute IEXTRA, the number of extra digits required
!             to compensate for cancellation error when the
!             argument is large.

      IEXTRA = MIN(MAX(INT(M27(1))-1,0),INT(1.0+ALOGMX/ALOGMB))
      IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
          CALL FMEQ2_R1(M27,NDIG,NDIG+IEXTRA)
          CALL FMEQ2_R1(M_GAMMA_MB,NDIG,NDIG+IEXTRA)
      ENDIF
      NDSAV2 = NDIG
      NDIG = NDIG + IEXTRA
      IF (NDIG > NDG2MX .AND. KRFLCT == 1) THEN
          KFLAG = -9
          CALL FMWRN2
          NDIG = NDIG - IEXTRA
          CALL FMST2M('UNKNOWN',M22)
          GO TO 140
      ELSE IF (NDIG > NDG2MX .AND. KRFLCT == 0) THEN
          KFLAG = -5
          NDIG = NDIG - IEXTRA
          CALL FMST2M('OVERFLOW',M22)
          GO TO 140
      ENDIF
      CALL FMLNGM(M27,M14)
      CALL FMEQ(M14,M27)
      CALL FMEXP(M27,M22)

      NDIG = NDSAV2

!             Reverse the shifting.
!             The product MA*(MA+1)*...*(MA+LSHIFT-1) is computed
!             four terms at a time to reduce the number of FMMPY calls.

!             M17  is Z
!             M18 is Z**2
!             M19 is Z**3
!             M20 is (Z+K)*...*(Z+K+3)
!             M23 is the current product

      CALL FMEQ(M_GAMMA_MB,M17)
      IF (LSHIFT > 0) THEN
          CALL FMSQR(M17,M18)
          CALL FMMPY(M17,M18,M19)
          CALL FMSQR(M18,M20)
          CALL FMMPYI(M19,6,M24)
          CALL FMADD_R1(M20,M24)
          CALL FMMPYI(M18,11,M24)
          CALL FMADD_R1(M20,M24)
          CALL FMMPYI(M17,6,M24)
          CALL FMADD_R1(M20,M24)
          CALL FMEQ(M20,M23)
          CALL FMMPYI_R1(M19,16)
          LARGE = INTMAX
          DO K = 0, LSHIFT-8, 4
             CALL FMADD_R1(M20,M19)
             K2 = 24*(2*K + 7)
             CALL FMMPYI(M18,K2,M24)
             CALL FMADD_R1(M20,M24)
             IF (K <= SQRT(REAL(LARGE)/49.0)) THEN
                 K1 = 8*(6*K*K + 42*K + 79)
                 CALL FMMPYI(M17,K1,M24)
                 CALL FMADD_R1(M20,M24)
             ELSE
                 K1 = 48*K
                 CALL FMMPYI(M17,K1,M24)
                 CALL FMMPYI_R1(M24,K)
                 CALL FMADD_R1(M20,M24)
                 K1 = 336*K + 632
                 CALL FMMPYI(M17,K1,M24)
                 CALL FMADD_R1(M20,M24)
             ENDIF
             IF (K <= (REAL(LARGE)/17.0)**0.3333) THEN
                 K0 = 8*(2*K + 7)*(K*K + 7*K + 15)
                 CALL FMADDI(M20,K0)
             ELSE IF (K <= SQRT(REAL(LARGE)*0.9)) THEN
                 K0 = 8*(2*K + 7)
                 CALL FMI2M(K0,M24)
                 K0 = K*K + 7*K + 15
                 CALL FMMPYI_R1(M24,K0)
                 CALL FMADD_R1(M20,M24)
             ELSE
                 K0 = 8*(2*K + 7)
                 CALL FMI2M(K0,M24)
                 CALL FMMPYI(M24,K,M21)
                 CALL FMMPYI_R1(M21,K)
                 CALL FMADD_R1(M20,M21)
                 K0 = 7*K + 15
                 CALL FMMPYI_R1(M24,K0)
                 CALL FMADD_R1(M20,M24)
             ENDIF
             CALL FMMPY_R1(M23,M20)
          ENDDO
          CALL FMDIV_R1(M22,M23)
      ENDIF

!             Use the reflection formula if MA was less than -1/2.

  120 IF (KRFLCT == 1) THEN

!             Reduce the argument before multiplying by Pi.

          CALL FMNINT(M_GAMMA_MB,M18)
          CALL FMDIVI(M18,2,M19)
          CALL FMINT(M19,M08)
          CALL FMEQ(M08,M19)
          CALL FMMPYI(M19,2,M20)
          KSIGN = -1
          IF (FMCOMP(M18,'==',M20)) KSIGN = 1
          CALL FMSUB(M_GAMMA_MB,M18,M21)
          M21(0) = M_GAMMA_MB(0)
          CALL FMPI(M23)
          CALL FMMPY_R1(M23,M21)
          KRSAVE = KRAD
          KRAD = 1
          CALL FMSIN(M23,M12)
          CALL FMEQ(M12,M23)
          M23(-1) = KSIGN*M23(-1)
          KRAD = KRSAVE
          CALL FMDIV_R2(MPISAV,M23)
          CALL FMDIV_R2(M23,M22)
      ENDIF

!             Check for too much cancellation.

      IF (NCALL <= 1) THEN
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
      ELSE
          NGOAL = INT(-MXEXP2)
      ENDIF
      IF (M22(0) <= NGOAL) THEN
          IF (NUMTRY > 0) THEN
              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
              DO J = 1, NDGOAL+1
                 IF (MRETRY(J) /= M22(J)) GO TO 130
              ENDDO
              GO TO 140
          ENDIF
  130     IEXTRA = INT(REAL(NGOAL-M22(0))/ALOGM2 + 23.03/ALOGMB) + 1
          NDOLD = NDIG
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDIG - IEXTRA
              CALL FMST2M('UNKNOWN',M22)
              GO TO 140
          ENDIF
          CALL FMEQ2_R1(M28,NDSAVE,NDIG)
          CALL FMEQ(M28,M_GAMMA_MB)
          NUMTRY = NUMTRY + 1
          CALL FMEQ2(M22,MRETRY,NDOLD,NDIG)
          GO TO 110
      ENDIF

  140 MACMAX = NINT(NDSAVE*ALOGM2)
      M22(0) = MIN(M22(0),MACCA,MACMAX)

      CALL FMEQ(M28,M_GAMMA_MA)
      CALL FMEQ(M22,M_GAMMA_MB)
      NDGGAM = NDIG
      IF (ABS(M_GAMMA_MB(1)) > MEXPOV) NDGGAM = 0
      MBSGAM = MBASE

      CALL FMEXT2(M22,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMGAM

      SUBROUTINE FMIBTA(MX,MA,MB,MC)

!  MC = Incomplete Beta(MX,MA,MB)

!  Integral from 0 to MX of  t**(MA-1) * (1-t)**(MB-1)  dt.

!  0 <= MX <= 1,    0 < MA,    0 <= MB.

!  Some comments below refer to this function and its arguments as B(x,a,b).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MX(-1:LUNPCK),MA(-1:LUNPCK),MB(-1:LUNPCK),  &
                            MC(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACCB,MACCX,MACMAX,MLA,MXSAVE
      INTEGER IEXTRA,J,J4,JCHECK,JEXTRA,K,KASAVE,KASHIFT,KBIGAB,KBSHIFT,     &
              KICK,KOVUN,KPTMJ1,KPTMJ2,KPTMJ3,KPTMJ4,KPTMJ5,KPTMJ6,KPTMJ7,   &
              KRESLT,KRS,K_RETURN_CODE,NCSAVE,NDGOAL,NDIG2,NDOLD,NDS,NDSAV1, &
              NDSAVE,NGOAL,NMETHD,NTERMS,NUMTRY,NWDS1,NWDSAV,NWDSCH
      LOGICAL FMCOMP

      NCSAVE = NCALL
      CALL FMENT2('FMIBTA',MX,MA,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      NCALL = NCSAVE + 1
      KRS = KRESLT
      IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1
      IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
          NDS = NDIG
          NDIG = NDSAVE
          IF (NTRACE < 0) THEN
              CALL FMNTRJ(MB,NDIG)
          ELSE
              CALL FMPRNT(MB)
          ENDIF
          NDIG = NDS
      ENDIF
      KRESLT = KRS
      IF (MB(1) == MUNKNO) THEN
          KRESLT = 12
          KFLAG = -4
      ENDIF
      IF (KRESLT /= 0) THEN
          NDIG = NDSAVE
          CALL FMRSLT(MA,MB,MC,KRESLT)
          IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
          MXEXP = MXSAVE
          KACCSW = KASAVE
          NCALL = NCALL - 1
          RETURN
      ENDIF

!             Use more digits for smaller bases.

      J = 1.06*NDSAVE + 51.0/ALOGM2 + 1.0
      NDIG = MAX(NDIG,J)
      NDIG = MIN(NDIG,NDG2MX-16)
      KACCSW = 1
      MACCX = MX(0)
      MACCA = MA(0)
      MACCB = MB(0)
      CALL FMEQ2(MX,M36,NDSAVE,NDIG)
      M36(0) = NINT(NDIG*ALOGM2)
      CALL FMEQ2(MA,M37,NDSAVE,NDIG)
      M37(0) = NINT(NDIG*ALOGM2)
      CALL FMEQ2(MB,M38,NDSAVE,NDIG)
      M38(0) = NINT(NDIG*ALOGM2)

!             Handle cases where at least one of X, A, B is underflow or
!             overflow.  Increasing any underflowed values to 1/HUGE makes
!             the calculations more stable.  If A is underflow and the final
!             result is overflow, it is safe to return overflow.  If X is
!             underflow and the final result is underflow, it is safe to
!             return underflow.  If B is underflow, it is replaced by zero.
!             Similarly, decreasing any overflowed A or B values to HUGE
!             and then getting a final result of underflow means it is safe
!             to return underflow.
!             Any cases where the inequalities conflict, such as
!             A = underflow, B = overflow, will return unknown.

      KBIGAB = 0
      IF (MA(1) == MEXPOV) THEN
          CALL FMBIG(M37)
          M37(1) = MXSAVE + 1
          KBIGAB = -1
      ENDIF
      IF (MB(1) == MEXPOV) THEN
          CALL FMBIG(M38)
          M38(1) = MXSAVE + 1
          KBIGAB = -1
      ENDIF
      IF (MX(1) == MEXPUN) THEN
          CALL FMBIG(M36)
          M36(1) = MXSAVE + 1
          CALL FMI2M(1,M16)
          CALL FMDIV_R2(M16,M36)
          KBIGAB = -1
      ENDIF
      IF (MA(1) == MEXPUN) THEN
          CALL FMBIG(M37)
          M37(1) = MXSAVE + 1
          CALL FMI2M(1,M16)
          CALL FMDIV_R2(M16,M37)
          IF (KBIGAB < 0) THEN
              KBIGAB = -9
              CALL FMI2M(0,M25)
              GO TO 200
          ELSE
              KBIGAB = 1
          ENDIF
      ENDIF
      IF (MB(1) == MEXPUN) THEN
          CALL FMI2M(1,M16)
          IF (FMCOMP(M36,'/=',M16)) THEN
              CALL FMI2M(0,M38)
          ENDIF
      ENDIF
      NWDSAV = NDIG
      NUMTRY = 0
      NDGOAL = 0
      NWDS1 = 0
      KASHIFT = 0
      KBSHIFT = 0

!             Check for special cases.

  110 KICK = 0
      CALL FMIBTA2(K_RETURN_CODE,MXSAVE,NTERMS,NUMTRY,NMETHD)
      IF (K_RETURN_CODE == 1) GO TO 180
      IF (K_RETURN_CODE == 2) GO TO 200

!             Determine which method to use.

!             NMETHD = 1 means use the convergent series for B(x,a,b),
!                    = 2 means use continued fraction expansion 1
!                        for B(x,a,b),
!                    = 3 means use the convergent series
!                        for B(1-x,b,a).
!                    = 4 means use continued fraction expansion 1
!                        for B(1-x,b,a).
!                    = 5 means use continued fraction expansion 2
!                        for B(x,a,b).
!                    = 6 means use continued fraction expansion 2
!                        for B(1-x,b,a).

      CALL FMSQR(M37,M16)
      CALL FMDPM(DBLE(.00173),M06)
      CALL FMMPY(M06,M16,M05)
      CALL FMSQR(M38,M16)
      CALL FMDPM(DBLE(.01253),M06)
      CALL FMMPY(M06,M16,M04)
      CALL FMADD_R1(M05,M04)
      CALL FMDPM(DBLE(.21583),M06)
      CALL FMMPY(M06,M37,M04)
      CALL FMADD_R1(M05,M04)
      CALL FMDPM(DBLE(.03891),M06)
      CALL FMMPY(M06,M38,M04)
      CALL FMADD_R1(M05,M04)
      CALL FMDPM(DBLE(9.14350),M04)
      CALL FMADD_R1(M05,M04)

      CALL FMDPM(DBLE(.11709),M06)
      CALL FMMPY(M06,M37,M04)
      CALL FMDPM(DBLE(.62633),M06)
      CALL FMMPY(M06,M38,M03)
      CALL FMADD_R1(M04,M03)
      CALL FMADDI(M04,1)

      CALL FMDIV(M04,M05,M40)

      CALL FMDPM(DBLE(.29217),M06)
      CALL FMMPY(M06,M37,M05)
      CALL FMDPM(DBLE(2.09304),M06)
      CALL FMMPY(M06,M38,M04)
      CALL FMADD_R1(M05,M04)
      CALL FMDPM(DBLE(1.53724),M04)
      CALL FMADD_R1(M05,M04)

      CALL FMDPM(DBLE(.29217),M06)
      CALL FMMPY(M06,M37,M04)
      CALL FMDPM(DBLE(2.09304),M06)
      CALL FMMPY(M06,M38,M03)
      CALL FMADD_R1(M04,M03)
      CALL FMADDI(M04,1)

      CALL FMDIV(M04,M05,M41)

      CALL FMSQR(M37,M16)
      CALL FMDPM(DBLE(.04038),M06)
      CALL FMMPY(M06,M16,M05)
      CALL FMSQR(M38,M16)
      CALL FMDPM(DBLE(.05754),M06)
      CALL FMMPY(M06,M16,M04)
      CALL FMADD_R1(M05,M04)
      CALL FMDPM(DBLE(.02670),M06)
      CALL FMMPY(M06,M37,M04)
      CALL FMADD_R1(M05,M04)
      CALL FMDPM(DBLE(.56206),M06)
      CALL FMMPY(M06,M38,M04)
      CALL FMADD_R1(M05,M04)
      CALL FMDPM(DBLE(0.13746),M04)
      CALL FMADD_R1(M05,M04)

      CALL FMDPM(DBLE(.87312),M06)
      CALL FMMPY(M06,M37,M04)
      CALL FMDPM(DBLE(.20334),M06)
      CALL FMMPY(M06,M38,M03)
      CALL FMADD_R1(M04,M03)
      CALL FMADDI(M04,1)

      CALL FMDIV(M04,M05,M42)

      CALL FMDPM(DBLE(.64584),M06)
      CALL FMMPY(M06,M37,M05)
      CALL FMDPM(DBLE(.64584),M06)
      CALL FMMPY(M06,M38,M04)
      CALL FMADD_R1(M05,M04)
      CALL FMDPM(DBLE(6.31958),M04)
      CALL FMADD_R1(M05,M04)

      CALL FMDPM(DBLE(.64584),M06)
      CALL FMMPY(M06,M37,M04)
      CALL FMADDI(M04,1)

      CALL FMDIV(M04,M05,M43)

      CALL FMSQR(M37,M16)
      CALL FMDPM(DBLE(.11637),M06)
      CALL FMMPY(M06,M16,M05)
      CALL FMSQR(M38,M16)
      CALL FMDPM(DBLE(.10718),M06)
      CALL FMMPY(M06,M16,M04)
      CALL FMADD_R1(M05,M04)
      CALL FMDPM(DBLE(.92626),M06)
      CALL FMMPY(M06,M37,M04)
      CALL FMADD_R1(M05,M04)
      CALL FMDPM(DBLE(.05518),M06)
      CALL FMMPY(M06,M38,M04)
      CALL FMADD_R1(M05,M04)
      CALL FMDPM(DBLE(0.28962),M04)
      CALL FMADD_R1(M05,M04)

      CALL FMDPM(DBLE(.99773),M06)
      CALL FMMPY(M06,M37,M04)
      CALL FMDPM(DBLE(.56855),M06)
      CALL FMMPY(M06,M38,M03)
      CALL FMADD_R1(M04,M03)
      CALL FMADDI(M04,1)

      CALL FMDIV(M04,M05,M44)

      IF (FMCOMP(M36,'<=',M40)) THEN
          NMETHD = 1
      ELSE IF (FMCOMP(M36,'>=',M41)) THEN
          NMETHD = 3
      ELSE IF (FMCOMP(M36,'<',M44)) THEN
          IF (FMCOMP(M36,'<',M42)) THEN
              NMETHD = 2
          ELSE
              NMETHD = 4
          ENDIF
      ELSE
          IF (FMCOMP(M36,'<',M43)) THEN
              NMETHD = 5
          ELSE
              NMETHD = 6
          ENDIF
      ENDIF
      IF (M38(1) <= 0 .AND. M37(1)+NDIG < 0) THEN
          NMETHD = 1
      ENDIF
      IF (NMETHD == 2) GO TO 130
      IF (NMETHD == 5) GO TO 150
      IF (NMETHD == 3 .OR. NMETHD == 4 .OR. NMETHD == 6) GO TO 160

!             Method 1.  Use the Pochhammer(1-B,N)*X**N/((A+N)*N!)
!                        series.

!             M19 and M25 hold the positive and negative parts
!                 of the current sum.
!             M21 is the current term.
!             M22 is J-B.
!             M23 is 1.
!             M24 is A+J.

  120 JEXTRA = INT(0.06*NDIG)
      IF (NDIG+JEXTRA > NDG2MX-6) JEXTRA = NDG2MX - 6 - NDIG
      IF (NDIG+JEXTRA > NDIG) THEN
          CALL FMEQ2_R1(M36,NDIG,NDIG+JEXTRA)
          CALL FMEQ2_R1(M37,NDIG,NDIG+JEXTRA)
          CALL FMEQ2_R1(M38,NDIG,NDIG+JEXTRA)
      ENDIF
      NDIG = NDIG + JEXTRA
      CALL FMI2M(1,M21)
      CALL FMDIV(M21,M37,M19)
      CALL FMI2M(0,M25)
      CALL FMEQ(M38,M22)
      IF (M22(1) /= MUNKNO .AND. M22(2) /= 0) M22(-1) = -M22(-1)
      CALL FMEQ(M37,M24)
      CALL FMI2M(1,M23)
      CALL FMI2M(0,M20)
      CALL FMI2M(0,M26)
      JCHECK = 5
      NDSAV1 = NDIG

!             Method 1 summation loop.

      METHOD1:    DO J = 1, NTERMS
         NDIG = NDSAV1
         CALL FMADD_R1(M22,M23)
         IF (M22(2) == 0) M22(0) = M23(0)
         NDIG2 = MIN(NDSAV1,MAX(2,NDSAV1-INT(M19(1)-M21(1)),  &
                                  NDSAV1-INT(M25(1)-M21(1))))
         NDIG = NDIG2
         CALL FMMPY_R1(M21,M22)
         CALL FMMPY_R1(M21,M36)
         IF (J > 1) CALL FMDIVI_R1(M21,J)
         NDIG = NDSAV1
         CALL FMADD_R1(M24,M23)
         NDIG = NDIG2
         CALL FMDIV(M21,M24,M20)

         NDIG = NDSAV1
         IF (INT(M20(-1)) < 0) THEN
             CALL FMADD_R2(M20,M25)
         ELSE
             CALL FMADD_R2(M20,M19)
         ENDIF

         IF (KFLAG < 0) EXIT
         IF (MOD(J,JCHECK) == 0) THEN
             CALL FMADD(M19,M25,M20)
             DO K = NDIG+1, 1, -1
                IF (M20(K) /= M26(K)) THEN
                    CALL FMEQ(M20,M26)
                    CYCLE METHOD1
                ENDIF
             ENDDO
             EXIT
         ENDIF
      ENDDO METHOD1

      CALL FMPWR(M36,M37,M16)
      CALL FMADD(M19,M25,M06)
      CALL FMMPY(M06,M16,M25)

      IF (NMETHD == 1) THEN
          GO TO 180
      ELSE
          GO TO 170
      ENDIF

!             Method 2.  Continued fraction expansion for B(x,a,b).

!             M26 is the current approximation.
!             M25 is the previous approximation.
!             M21, M22 are the latest numerators (positive part).
!             M41, M42 are the latest numerators (negative part).
!             M23, M24 are the latest denominators (positive part).
!             M43, M44 are the latest denominators (negative part).

  130 JEXTRA = INT(MAX(1.0,5.76/ALOGMB + 1.0)) + NGRD52 + INT(0.152*NDIG)
      IF (NDIG+JEXTRA > NDG2MX-6) JEXTRA = NDG2MX - 6 - NDIG
      IF (NDIG+JEXTRA > NDIG) THEN
          CALL FMEQ2_R1(M36,NDIG,NDIG+JEXTRA)
          CALL FMEQ2_R1(M37,NDIG,NDIG+JEXTRA)
          CALL FMEQ2_R1(M38,NDIG,NDIG+JEXTRA)
      ENDIF
      NDIG = NDIG + JEXTRA
      CALL FMI2M(0,M21)
      CALL FMI2M(1,M22)
      CALL FMI2M(1,M23)
      CALL FMI2M(1,M24)
      CALL FMI2M(0,M41)
      CALL FMI2M(0,M42)
      CALL FMI2M(0,M43)
      CALL FMI2M(0,M44)
      CALL FMI2M(0,M25)
      CALL FMI2M(0,M26)
      CALL FMADD(M37,M24,M16)
      CALL FMMPYI(M16,2,M27)
      CALL FMSUB(M27,M24,M16)
      CALL FMADD(M16,M38,M06)
      CALL FMMPY(M06,M36,M28)
      CALL FMMPY(M38,M36,M16)
      CALL FMMPYI(M36,3,M06)
      CALL FMSUB(M16,M06,M32)
      CALL FMADD(M37,M38,M16)
      CALL FMMPY(M16,M37,M06)
      CALL FMMPY(M06,M36,M33)
      CALL FMMPYI(M36,2,M16)
      CALL FMADD(M32,M16,M34)
      CALL FMSQR(M37,M16)
      CALL FMADD(M16,M37,M35)

      JCHECK = 5

!             Method 2 continued fraction loop.

      DO J = 0, NTERMS
         CALL FMDIV(M33,M35,M19)
         IF (M19(1) /= MUNKNO .AND. M19(2) /= 0) M19(-1) = -M19(-1)
         IF (M19(-1)*M19(2) >= 0) THEN
             CALL FMMPY(M19,M21,M16)
             CALL FMADD(M16,M22,M21)
             CALL FMMPY(M19,M41,M16)
             CALL FMADD(M16,M42,M41)
             CALL FMMPY(M19,M23,M16)
             CALL FMADD(M16,M24,M23)
             CALL FMMPY(M19,M43,M16)
             CALL FMADD(M16,M44,M43)
         ELSE
             CALL FMEQ(M21,M40)
             CALL FMMPY(M19,M41,M21)
             CALL FMADD_R1(M21,M22)
             CALL FMMPY(M19,M40,M41)
             CALL FMADD_R1(M41,M42)
             CALL FMEQ(M23,M40)
             CALL FMMPY(M19,M43,M23)
             CALL FMADD_R1(M23,M24)
             CALL FMMPY(M19,M40,M43)
             CALL FMADD_R1(M43,M44)
         ENDIF
         CALL FMADD_R1(M35,M27)
         J4 = J*4
         CALL FMADDI(M35,J4)
         CALL FMDIV(M34,M35,M20)
         IF (M20(-1) >= 0) THEN
             CALL FMMPY(M20,M22,M16)
             CALL FMADD(M16,M21,M22)
             CALL FMMPY(M20,M42,M16)
             CALL FMADD(M16,M41,M42)
             CALL FMMPY(M20,M24,M16)
             CALL FMADD(M16,M23,M24)
             CALL FMMPY(M20,M44,M16)
             CALL FMADD(M16,M43,M44)
         ELSE
             CALL FMEQ(M22,M40)
             CALL FMMPY(M20,M42,M22)
             CALL FMADD_R1(M22,M21)
             CALL FMMPY(M20,M40,M42)
             CALL FMADD_R1(M42,M41)
             CALL FMEQ(M24,M40)
             CALL FMMPY(M20,M44,M24)
             CALL FMADD_R1(M24,M23)
             CALL FMMPY(M20,M40,M44)
             CALL FMADD_R1(M44,M43)
         ENDIF

!             Form the quotient and check for convergence.

         IF (MOD(J,JCHECK) == 0) THEN
             CALL FMEQ(M26,M25)
             CALL FMADD(M22,M42,M16)
             CALL FMADD(M24,M44,M06)
             CALL FMDIV(M16,M06,M26)
             IF (KFLAG == -4) THEN
                 M25(0) = -2
                 GO TO 180
             ENDIF
             NGOAL = 1.06*(INT(REAL(NDSAVE)*ALOGM2) + 29)
             IF (M26(0) < NGOAL) THEN
                 KICK = -2
                 EXIT
             ENDIF

             CALL FMSUB(M26,M25,M16)
             CALL FMABS(M16,M40)
             IF (J >= 1000*(NUMTRY+1)) THEN
                 IF (FMCOMP(M40,'>',M45)) THEN
                     KICK = -2
                     EXIT
                 ENDIF
             ENDIF
             CALL FMEQ(M40,M45)
             NWDSCH = NWDSAV + 1
             IF (NUMTRY == 1 .AND. (KASHIFT > 0 .OR. KBSHIFT > 0)) THEN
                 NWDSCH = NDIG - JEXTRA
             ELSE IF (NUMTRY > 0 .AND. NDGOAL > 0) THEN
                 NWDSCH = NDGOAL + NWDS1 + NGRD22
             ELSE IF (NUMTRY > 0 .AND. NDGOAL <= 0) THEN
                 NWDSCH = INT(REAL(INT(REAL(NDSAVE)*ALOGM2)+17)/ALOGM2  &
                          + 1.0) + NWDS1 + NGRD22
             ENDIF
             DO K = NWDSCH, 1, -1
                IF (M25(K) /= M26(K)) GO TO 140
             ENDDO
             EXIT
         ENDIF

  140    CALL FMADD_R1(M35,M27)
         K = 4*J + 2
         CALL FMADDI(M35,K)
         K = 2*J
         CALL FMMPYI(M36,K,M18)
         CALL FMADD_R1(M33,M28)
         CALL FMADD_R1(M33,M18)
         CALL FMADD_R1(M34,M32)
         CALL FMSUB_R1(M34,M18)
      ENDDO

      CALL FMLN(M36,M23)
      CALL FMMPY_R1(M23,M37)
      IF (M36(1)*(-10) >= NDIG) THEN
          CALL FMEQ(M36,M19)
          CALL FMEQ(M36,M24)
          DO K = 2, NTERMS
             CALL FMMPY_R1(M19,M36)
             CALL FMDIVI(M19,K,M16)
             CALL FMADD_R1(M24,M16)
             IF (KFLAG /= 0) EXIT
          ENDDO
          CALL FMMPY(M24,M38,M16)
          IF (M16(1) /= MUNKNO .AND. M16(2) /= 0) M16(-1) = -M16(-1)
      ELSE
          CALL FMI2M(1,M16)
          CALL FMSUB_R1(M16,M36)
          CALL FMLN(M16,M24)
          CALL FMMPY_R1(M24,M38)
      ENDIF
      CALL FMADD(M23,M24,M16)
      CALL FMEXP(M16,M25)
      CALL FMMPY_R2(M26,M25)
      IF (M25(1) == MUNKNO) THEN
          IF (M26(-1)*M26(2) > 0) THEN
              CALL FMLN(M26,M16)
              CALL FMADD(M16,M23,M06)
              CALL FMADD(M06,M24,M16)
              CALL FMEXP(M16,M25)
          ELSE
              CALL FMEQ(M26,M17)
              IF (M17(1) /= MUNKNO .AND. M17(2) /= 0) M17(-1) = -M17(-1)
              CALL FMLN(M17,M16)
              CALL FMADD(M16,M23,M06)
              CALL FMADD(M06,M24,M16)
              CALL FMEXP(M16,M25)
              IF (M25(1) /= MUNKNO .AND. M25(2) /= 0) M25(-1) = -M25(-1)
          ENDIF
      ENDIF
      IF (ABS(M25(1)) < MEXPOV) CALL FMDIV_R1(M25,M37)
      IF (NMETHD == 2) THEN
          GO TO 180
      ELSE
          GO TO 170
      ENDIF

!             Method 5.  Continued fraction expansion 2 for B(x,a,b).

!             M26 is the current approximation.
!             M25 is the previous approximation.
!             M21, M22 are the latest numerators (positive part).
!             M41, M42 are the latest numerators (negative part).
!             M23, M24 are the latest denominators (positive part).
!             M43, M44 are the latest denominators (negative part).

  150 JEXTRA = INT(MAX(1.0,5.76/ALOGMB + 1.0)) + INT(0.07*NDIG)
      IF (NDIG+JEXTRA > NDG2MX-6) JEXTRA = NDG2MX - 6 - NDIG
      IF (NDIG+JEXTRA > NDIG) THEN
          CALL FMEQ2_R1(M36,NDIG,NDIG+JEXTRA)
          CALL FMEQ2_R1(M37,NDIG,NDIG+JEXTRA)
          CALL FMEQ2_R1(M38,NDIG,NDIG+JEXTRA)
      ENDIF
      NDIG = NDIG + JEXTRA
      KPTMJ1 = 0
      KPTMJ2 = (LUNPCK+3)
      KPTMJ3 = 2*(LUNPCK+3)
      KPTMJ4 = 3*(LUNPCK+3)
      KPTMJ5 = 4*(LUNPCK+3)
      KPTMJ6 = 5*(LUNPCK+3)
      KPTMJ7 = 6*(LUNPCK+3)

      CALL FMI2M(0,M21)
      CALL FMI2M(1,M22)
      CALL FMI2M(1,M23)
      CALL FMI2M(0,M25)
      CALL FMI2M(0,M26)

      CALL FMSUB(M37,M22,M30)
      CALL FMSUB(M30,M22,MJSUMS(KPTMJ5-1))
      CALL FMSQR(M36,MJSUMS(KPTMJ4-1))

      IF (NMETHD == 6) THEN
          CALL FMADD(M37,M38,M16)
          CALL FMMPY(M16,M36,M06)
          CALL FMSUB(M37,M06,M29)
          CALL FMEQ2(MX,M28,NDSAVE,NDIG)
          CALL FMADD(M37,M38,M16)
          CALL FMMPY(M16,M28,M06)
          CALL FMSUB(M06,M38,M31)
          IF (M29(0) > M31(0)) CALL FMEQ(M29,M31)
      ELSE
          CALL FMADD(M37,M38,M16)
          CALL FMMPY(M16,M36,M06)
          CALL FMSUB(M37,M06,M31)
      ENDIF
      IF (M31(0) == 0 .AND. M31(2) == 0) THEN
          M31(0) = M22(0)
      ENDIF

      CALL FMI2M(0,M28)
      CALL FMMPY(M30,M30,M29)

      CALL FMMPY(MJSUMS(KPTMJ4-1),MJSUMS(KPTMJ5-1),M18)
      CALL FMADD(MJSUMS(KPTMJ5-1),M38,M19)
      CALL FMMPY_R1(M18,M19)
      CALL FMADD(M38,M22,M19)
      CALL FMMPY(M18,M19,MJSUMS(KPTMJ1-1))

      CALL FMSUB(MJSUMS(KPTMJ5-1),M22,M18)
      CALL FMMPY_R2(MJSUMS(KPTMJ5-1),M18)
      CALL FMADD(M30,M38,M16)
      CALL FMMPY(M16,M38,M19)
      CALL FMSUB(M19,M18,M16)
      CALL FMMPYI(M16,2,M18)
      CALL FMMPY(M18,MJSUMS(KPTMJ4-1),MJSUMS(KPTMJ2-1))

      CALL FMMPY(MJSUMS(KPTMJ4-1),MJSUMS(KPTMJ5-1),M18)
      CALL FMMPYI(M18,-6,MJSUMS(KPTMJ3-1))

      CALL FMMPYI_R1(MJSUMS(KPTMJ4-1),-4)

      CALL FMMPYI(MJSUMS(KPTMJ5-1),4,M27)

      CALL FMI2M(4,M16)
      CALL FMADD(M38,M16,M06)
      CALL FMSUB(M06,M37,M16)
      CALL FMMPY(M16,M36,M18)
      CALL FMADD(MJSUMS(KPTMJ5-1),M31,M19)
      CALL FMMPYI(M19,3,M16)
      CALL FMADD(M18,M16,M19)
      CALL FMMPY(M19,M30,MJSUMS(KPTMJ5-1))

      CALL FMMPYI(M37,-2,M16)
      CALL FMADD(M16,M38,M06)
      CALL FMADDI(M06,3)
      CALL FMMPY(M06,M36,M18)
      CALL FMMPYI(M37,5,M19)

      CALL  FMADD(M18,M19,M16)
      CALL FMADD(M16,M31,M06)
      CALL FMI2M(6,M16)
      CALL FMSUB(M06,M16,M18)
      CALL FMMPYI(M18,4,MJSUMS(KPTMJ6-1))

      CALL FMI2M(2,M16)
      CALL FMSUB(M36,M16,M18)
      CALL FMMPYI(M18,-12,MJSUMS(KPTMJ7-1))

      CALL FMADD(M22,M31,M16)
      CALL FMMPY(M16,M37,M06)
      CALL FMMPY(M06,M30,M31)

      CALL FMADD(M22,M37,M16)
      CALL FMMPY(M16,M30,M32)

      CALL FMMPYI_R1(M30,4)
      CALL FMDIV(M31,M32,M24)
      CALL FMI2M(0,M41)
      CALL FMI2M(0,M42)
      CALL FMI2M(0,M43)
      CALL FMI2M(0,M44)
      IF (M24(-1) < 0) THEN
          CALL FMEQ(M24,M44)
          CALL FMI2M(0,M24)
      ENDIF
      JCHECK = 5

!             Method 5 continued fraction loop.

      METHOD5:    DO J = 1, NTERMS
         CALL FMMPYI(MJSUMS(KPTMJ4-1),J,M18)
         CALL FMADD_R1(M18,MJSUMS(KPTMJ3-1))
         CALL FMMPYI_R1(M18,J)
         CALL FMADD_R1(M18,MJSUMS(KPTMJ2-1))
         CALL FMMPYI_R1(M18,J)
         CALL FMADD_R1(M18,MJSUMS(KPTMJ1-1))

         CALL FMADDI(M27,8)
         CALL FMADD_R1(M28,M18)
         CALL FMADD_R1(M29,M27)
         CALL FMDIV(M28,M29,M18)

         CALL FMMPYI(MJSUMS(KPTMJ7-1),J,M19)
         CALL FMADD_R1(M19,MJSUMS(KPTMJ6-1))
         CALL FMMPYI_R1(M19,J)
         CALL FMADD_R1(M19,MJSUMS(KPTMJ5-1))

         CALL FMADDI(M30,8)

         CALL FMADD_R1(M31,M19)
         CALL FMADD_R1(M32,M30)
         CALL FMDIV(M31,M32,M19)

         IF (M18(-1) >= 0 .AND. M19(-1) >= 0) THEN
             CALL FMMPY(M18,M21,M20)
             CALL FMMPY(M19,M22,M21)
             CALL FMADD_R1(M20,M21)
             CALL FMMPY(M18,M41,M40)
             CALL FMMPY(M19,M42,M41)
             CALL FMADD_R1(M40,M41)
             CALL FMEQ(M22,M21)
             CALL FMEQ(M20,M22)
             CALL FMEQ(M42,M41)
             CALL FMEQ(M40,M42)
             CALL FMMPY(M18,M23,M20)
             CALL FMMPY(M19,M24,M23)
             CALL FMADD_R1(M20,M23)
             CALL FMMPY(M18,M43,M40)
             CALL FMMPY(M19,M44,M43)
             CALL FMADD_R1(M40,M43)
             CALL FMEQ(M24,M23)
             CALL FMEQ(M20,M24)
             CALL FMEQ(M44,M43)
             CALL FMEQ(M40,M44)
         ELSE IF (M18(-1) >= 0 .AND. M19(-1) < 0) THEN
             CALL FMMPY(M18,M21,M16)
             CALL FMMPY(M19,M42,M06)
             CALL FMADD(M16,M06,M20)
             CALL FMMPY(M18,M41,M16)
             CALL FMMPY(M19,M22,M06)
             CALL FMADD(M16,M06,M40)
             CALL FMEQ(M22,M21)
             CALL FMEQ(M20,M22)
             CALL FMEQ(M42,M41)
             CALL FMEQ(M40,M42)
             CALL FMMPY(M18,M23,M16)
             CALL FMMPY(M19,M44,M06)
             CALL FMADD(M16,M06,M20)
             CALL FMMPY(M18,M43,M16)
             CALL FMMPY(M19,M24,M06)
             CALL FMADD(M16,M06,M40)
             CALL FMEQ(M24,M23)
             CALL FMEQ(M20,M24)
             CALL FMEQ(M44,M43)
             CALL FMEQ(M40,M44)
         ELSE IF (M18(-1) < 0 .AND. M19(-1) >= 0) THEN
             CALL FMMPY(M18,M41,M20)
             CALL FMMPY(M19,M22,M41)
             CALL FMADD_R1(M20,M41)
             CALL FMMPY(M18,M21,M40)
             CALL FMMPY(M19,M42,M41)
             CALL FMADD_R1(M40,M41)
             CALL FMEQ(M22,M21)
             CALL FMEQ(M20,M22)
             CALL FMEQ(M42,M41)
             CALL FMEQ(M40,M42)
             CALL FMMPY(M18,M43,M20)
             CALL FMMPY(M19,M24,M43)
             CALL FMADD_R1(M20,M43)
             CALL FMMPY(M18,M23,M40)
             CALL FMMPY(M19,M44,M43)
             CALL FMADD_R1(M40,M43)
             CALL FMEQ(M24,M23)
             CALL FMEQ(M20,M24)
             CALL FMEQ(M44,M43)
             CALL FMEQ(M40,M44)
         ELSE
             CALL FMMPY(M18,M41,M16)
             CALL FMMPY(M19,M42,M06)
             CALL FMADD(M16,M06,M20)
             CALL FMMPY(M18,M21,M16)
             CALL FMMPY(M19,M22,M06)
             CALL FMADD(M16,M06,M40)
             CALL FMEQ(M22,M21)
             CALL FMEQ(M20,M22)
             CALL FMEQ(M42,M41)
             CALL FMEQ(M40,M42)
             CALL FMMPY(M18,M43,M16)
             CALL FMMPY(M19,M44,M06)
             CALL FMADD(M16,M06,M20)
             CALL FMMPY(M18,M23,M16)
             CALL FMMPY(M19,M24,M06)
             CALL FMADD(M16,M06,M40)
             CALL FMEQ(M24,M23)
             CALL FMEQ(M20,M24)
             CALL FMEQ(M44,M43)
             CALL FMEQ(M40,M44)
         ENDIF

!             Form the quotient and check for convergence.

         IF (MOD(J,JCHECK) == 0) THEN
             CALL FMEQ(M26,M25)
             CALL FMADD(M22,M42,M16)
             CALL FMADD(M24,M44,M06)
             CALL FMDIV(M16,M06,M26)
             IF (KFLAG == -4) THEN
                 M25(0) = -2
                 GO TO 180
             ENDIF
             NGOAL = 1.06*(INT(REAL(NDSAVE)*ALOGM2) + 29)
             IF (M26(0) < NGOAL) THEN
                 KICK = -2
                 EXIT
             ENDIF

             CALL FMSUB(M26,M25,M16)
             CALL FMABS(M16,M40)
             IF (J >= 1000*(NUMTRY+1)) THEN
                 IF (FMCOMP(M40,'>',M45)) THEN
                     KICK = -2
                     EXIT
                 ENDIF
             ENDIF
             CALL FMEQ(M40,M45)
             NWDSCH = NWDSAV + 1
             IF (NUMTRY >= 1 .AND. (KASHIFT > 0 .OR. KBSHIFT > 0)) THEN
                 NWDSCH = NDIG - JEXTRA
             ELSE IF (NUMTRY > 0 .AND. NDGOAL > 0) THEN
                 NWDSCH = NDGOAL + NWDS1 + NGRD22
             ELSE IF (NUMTRY > 0 .AND. NDGOAL <= 0) THEN
                 NWDSCH = INT(REAL(INT(REAL(NDSAVE)*ALOGM2)+17)/ALOGM2  &
                          + 1.0) + NWDS1 + NGRD22
             ENDIF
             DO K = NWDSCH, 1, -1
                IF (M25(K) /= M26(K)) CYCLE METHOD5
             ENDDO
             EXIT
         ENDIF

      ENDDO METHOD5

      CALL FMI2M(1,M16)
      IF (FMCOMP(M36,'==',M16) .AND. NMETHD == 6) THEN
          CALL FMEQ2(MX,M23,NDSAVE,NDIG)
          CALL FMMPY_R1(M23,M37)
          IF (M23(1) /= MUNKNO .AND. M23(2) /= 0) M23(-1) = -M23(-1)
      ELSE IF (MX(1) <= -1 .AND. NMETHD == 6) THEN
          CALL FMEQ2(MX,M23,NDSAVE,NDIG)
          CALL FMEQ(M23,M19)
          CALL FMEQ(M23,M24)
          DO K = 2, NTERMS
             CALL FMMPY_R1(M19,M23)
             CALL FMDIVI(M19,K,M16)
             CALL FMADD_R1(M24,M16)
             IF (KFLAG /= 0) EXIT
          ENDDO
          CALL FMMPY(M24,M37,M23)
          IF (M23(1) /= MUNKNO .AND. M23(2) /= 0) M23(-1) = -M23(-1)
      ELSE
          CALL FMLN(M36,M23)
          CALL FMMPY_R1(M23,M37)
      ENDIF
      IF (NMETHD == 6) THEN
          CALL FMEQ2(MX,M24,NDSAVE,NDIG)
      CALL FMLN(M24,M13)
      CALL FMEQ(M13,M24)
      CALL FMMPY_R1(M24,M38)
      ELSE IF (M36(1) <= -1) THEN
          CALL FMEQ(M36,M19)
          CALL FMEQ(M36,M24)
          DO K = 2, NTERMS
             CALL FMMPY_R1(M19,M36)
             CALL FMDIVI(M19,K,M16)
             CALL FMADD_R1(M24,M16)
             IF (KFLAG /= 0) EXIT
          ENDDO
          CALL FMMPY_R1(M24,M38)
          IF (M24(1) /= MUNKNO .AND. M24(2) /= 0) M24(-1) = -M24(-1)
      ELSE
          CALL FMI2M(1,M06)
          CALL FMSUB(M06,M36,M16)
          CALL FMLN(M16,M24)
          CALL FMMPY_R1(M24,M38)
      ENDIF
      CALL FMADD(M23,M24,M16)
      CALL FMEXP(M16,M25)
      CALL FMMPY_R1(M25,M26)
      IF (M25(1) == MUNKNO) THEN
          IF (M26(-1)*M26(2) > 0) THEN
              CALL FMLN(M26,M16)
              CALL FMADD(M16,M23,M06)
              CALL FMADD(M06,M24,M16)
              CALL FMEXP(M16,M25)
          ELSE
              CALL FMEQ(M26,M17)
              IF (M17(1) /= MUNKNO .AND. M17(2) /= 0) M17(-1) = -M17(-1)
              CALL FMLN(M17,M16)
              CALL FMADD(M16,M23,M06)
              CALL FMADD(M06,M24,M16)
              CALL FMEXP(M16,M25)
              IF (M25(1) /= MUNKNO .AND. M25(2) /= 0) M25(-1) = -M25(-1)
          ENDIF
      ENDIF
      IF (NMETHD == 5) THEN
          GO TO 180
      ELSE
          GO TO 170
      ENDIF

!             Method 3, 4, or 6.  B(X,A,B) = B(A,B) - B(1-X,B,A).

  160 MLA = M36(0)
      CALL FMI2M(1,M16)
      CALL FMSUB_R2(M16,M36)
      M36(0) = MLA
      DO J = -1, NDIG+1
         MLA = M37(J)
         M37(J) = M38(J)
         M38(J) = MLA
      ENDDO
      IF (NMETHD == 3) THEN
          GO TO 120
      ELSE IF (NMETHD == 4) THEN
          GO TO 130
      ELSE
          GO TO 150
      ENDIF
  170 K = NWDS1
      CALL FMEQ(M25,M34)
      CALL FMBETA(M37,M38,M39)
      NWDS1 = INT(MAX(M39(1),M34(1)))
      CALL FMSUB(M39,M34,M25)
      NWDS1 = MAX(0,NWDS1-INT(M25(1)))
      IF (K /= NWDS1 .AND. NUMTRY >= 1) THEN
          IF (KASHIFT == 0 .AND. KBSHIFT == 0) M25(0) = -1
      ENDIF

!             Check for too much cancellation.

  180 K = KFLAG
      IF (KICK < 0) M25(0) = KICK

!             Reverse the translation if KASHIFT is positive.
!             This is used when a is small and a retry was required
!             because of cancellation.

      IF (KASHIFT > 0 .AND. M25(0) > 0) THEN
          CALL FMEQ2(MX,M26,NDSAVE,NDIG)
          CALL FMEQ2(MA,M27,NDSAVE,NDIG)
          CALL FMEQ2(MB,M28,NDSAVE,NDIG)
          IF (KBSHIFT > 0) CALL FMADDI(M28,KBSHIFT)
          CALL FMI2M(1,M23)
          CALL FMADD(M27,M28,M20)
          CALL FMI2M(1,M16)
          CALL FMADD(M27,M16,M06)
          CALL FMDIV(M20,M06,M24)
          CALL FMI2M(1,M16)
          CALL FMSUB(M16,M26,M21)
          CALL FMEQ(M26,M22)
          CALL FMMPY(M24,M26,M16)
          CALL FMADD_R1(M23,M16)
          CALL FMEQ(M20,M18)
          CALL FMEQ(M27,M19)
          CALL FMADDI(M19,1)
          DO J = 2, KASHIFT-1
             CALL FMADDI(M18,1)
             CALL FMADDI(M19,1)
             CALL FMMPY_R1(M24,M18)
             CALL FMDIV_R1(M24,M19)
             CALL FMMPY_R1(M22,M26)
             CALL FMMPY(M24,M22,M17)
             CALL FMADD_R1(M23,M17)
          ENDDO
          IF (M26(1)*(-10) >= NDIG) THEN
              CALL FMEQ(M26,M19)
              CALL FMEQ(M26,M21)
              DO K = 2, NTERMS
                 CALL FMMPY_R1(M19,M26)
                 CALL FMDIVI(M19,K,M16)
                 CALL FMADD_R1(M21,M16)
                 IF (KFLAG /= 0) EXIT
              ENDDO
              CALL FMMPY(M21,M28,M16)
              IF (M16(1) /= MUNKNO .AND. M16(2) /= 0) M16(-1) = -M16(-1)
              CALL FMEXP(M16,M22)
              CALL FMEQ(M23,M19)
              CALL FMPWR(M26,M27,M16)
              CALL FMMPY(M23,M16,M06)
              CALL FMMPY(M06,M22,M16)
              CALL FMDIV(M16,M27,M23)
              IF (M23(1) == MUNKNO) THEN
                  CALL FMLN(M26,M16)
                  CALL FMMPY(M27,M16,M23)
                  CALL FMLN(M19,M16)
                  CALL FMADD_R2(M16,M23)
                  CALL FMMPY(M21,M28,M16)
                  CALL FMSUB_R1(M23,M16)
                  CALL FMLN(M27,M16)
                  CALL FMSUB_R2(M23,M16)
                  CALL FMEXP(M16,M23)
              ENDIF
          ELSE
              CALL FMPWR(M26,M27,M16)
              CALL FMMPY_R1(M23,M16)
              CALL FMPWR(M21,M28,M16)
              CALL FMMPY_R1(M23,M16)
              CALL FMDIV_R1(M23,M27)
          ENDIF
          CALL FMMPY(M25,M24,M16)
          CALL FMI2M(KASHIFT-1,M06)
          CALL FMADD_R2(M20,M06)
          CALL FMMPY_R1(M16,M06)
          CALL FMDIV(M16,M27,M24)
          CALL FMADD(M24,M23,M25)
      ENDIF

!             Reverse the translation if KBSHIFT is positive.
!             This is used when x is close to 1, b is small,
!             and a retry was required because of cancellation.

      IF (KBSHIFT > 0 .AND. M25(0) > 0) THEN
          CALL FMEQ2(MX,M26,NDSAVE,NDIG)
          CALL FMEQ2(MA,M27,NDSAVE,NDIG)
          CALL FMEQ2(MB,M28,NDSAVE,NDIG)
          CALL FMI2M(1,M23)
          CALL FMI2M(1,M16)
          CALL FMADD(M28,M16,M06)
          CALL FMADD(M27,M28,M16)
          CALL FMDIV(M16,M06,M24)
          CALL FMADD(M27,M28,M20)
          CALL FMI2M(1,M16)
          CALL FMSUB(M16,M26,M21)
          CALL FMEQ(M21,M22)
          CALL FMMPY(M24,M22,M16)
          CALL FMADD_R1(M23,M16)
          CALL FMEQ(M20,M18)
          CALL FMEQ(M28,M19)
          CALL FMADDI(M19,1)
          DO J = 2, KBSHIFT-1
             CALL FMADDI(M18,1)
             CALL FMADDI(M19,1)
             CALL FMMPY_R1(M24,M18)
             CALL FMDIV_R1(M24,M19)
             CALL FMMPY_R1(M22,M21)
             CALL FMMPY(M24,M22,M17)
             CALL FMADD_R1(M23,M17)
          ENDDO
          IF (M26(1)*(-10) >= NDIG) THEN
              CALL FMEQ(M26,M19)
              CALL FMEQ(M26,M21)
              DO K = 2, NTERMS
                 CALL FMMPY_R1(M19,M26)
                 CALL FMDIVI(M19,K,M16)
                 CALL FMADD_R1(M21,M16)
                 IF (KFLAG /= 0) EXIT
              ENDDO
              CALL FMMPY(M21,M28,M16)
              IF (M16(1) /= MUNKNO .AND. M16(2) /= 0) M16(-1) = -M16(-1)
              CALL FMEXP(M16,M21)
              CALL FMPWR(M26,M27,M16)
              CALL FMMPY(M23,M16,M06)
              CALL FMMPY(M06,M21,M16)
              CALL FMDIV(M16,M28,M23)
          ELSE
              CALL FMPWR(M26,M27,M16)
              CALL FMMPY_R1(M23,M16)
              CALL FMPWR(M21,M28,M16)
              CALL FMMPY_R1(M23,M16)
              CALL FMDIV_R1(M23,M28)
          ENDIF
          CALL FMMPY(M25,M24,M16)
          CALL FMI2M(KBSHIFT-1,M06)
          CALL FMADD_R2(M20,M06)
          CALL FMMPY_R1(M16,M06)
          CALL FMDIV(M16,M28,M24)
          CALL FMSUB(M24,M23,M25)
      ENDIF
      IF (NCALL <= 1) THEN
          NGOAL = 1.06*(INT(REAL(NDSAVE)*ALOGM2) + 29)
      ELSE
          NGOAL = INT(-MXEXP2)
      ENDIF
      NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
      IF (M25(0) <= NGOAL) THEN
          IF (NUMTRY > 0) THEN
              IF (M25(2) == 0 .OR. K < 0) GO TO 190
              DO J = 1, NDGOAL+1
                 IF (MRETRY(J) /= M25(J)) GO TO 190
              ENDDO
              CALL FMI2M(1,M19)
              M25(0) = M19(0)
              GO TO 200
          ENDIF
  190     IEXTRA = INT(REAL(NGOAL-M25(0))/ALOGM2 + 23.03/ALOGMB) + 1
          NDOLD = NDIG
          NDIG = NDIG + IEXTRA
          IF (M25(0) < 0) NDIG = NDOLD + 10*2**NUMTRY
          IF (NDIG > NDG2MX-6 .AND. NDOLD < NDG2MX-6) NDIG = NDG2MX - 6
          IF (NDIG > NDG2MX-6) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDOLD
              CALL FMST2M('UNKNOWN',M25)
              GO TO 200
          ENDIF
          CALL FMEQ2_R1(M36,NDSAVE,NDIG)
          CALL FMEQ2_R1(M37,NDSAVE,NDIG)
          CALL FMEQ2_R1(M38,NDSAVE,NDIG)
          IF (NMETHD == 3 .OR. NMETHD == 4 .OR. NMETHD == 6) THEN
              CALL FMEQ2(MX,M36,NDSAVE,NDIG)
              DO J = -1, NDIG+1
                 MLA = M37(J)
                 M37(J) = M38(J)
                 M38(J) = MLA
              ENDDO
          ENDIF

          IF (KASHIFT > 0) THEN
              CALL FMEQ2(MA,M37,NDSAVE,NDIG)
              IF (KASHIFT <= 2000) THEN
                  KASHIFT = 9*KASHIFT
              ELSE
                  KASHIFT = NDIG
              ENDIF
              CALL FMADDI(M37,KASHIFT)
          ENDIF
          IF (KBSHIFT > 0) THEN
              CALL FMEQ2(MB,M38,NDSAVE,NDIG)
              IF (KBSHIFT <= 2000) THEN
                  KBSHIFT = 9*KBSHIFT
              ELSE
                  KBSHIFT = NDIG
              ENDIF
              CALL FMADDI(M38,KBSHIFT)
          ENDIF

!             Check to see if a retry is about to be done for
!             small a and large b.  If so, raise a by 2*NDIG to
!             reduce the potential cancellation error.

          CALL FMI2M(200,M16)
          IF (NUMTRY == 0 .AND. FMCOMP(M37,'<=',M16) .AND.  &
              FMCOMP(M38,'>=',M37)) THEN
              KASHIFT = 2*NDIG
              CALL FMADDI(M37,2*NDIG)
          ENDIF

!             Check to see if a retry is about to be done for
!             a > 100 and b < 2.  If so, raise b by 2*NDIG to
!             reduce the potential cancellation error.

          CALL FMI2M(100,M16)
          CALL FMI2M(2,M06)
          IF (NUMTRY == 0 .AND. FMCOMP(M37,'>=',M16) .AND.  &
              FMCOMP(M38,'<=',M06)) THEN
              KBSHIFT = 2*NDIG
              CALL FMADDI(M38,2*NDIG)
          ENDIF

          CALL FMI2M(40*NUMTRY,M16)
          CALL FMI2M(100,M06)
          IF (NUMTRY > 0 .AND. KASHIFT == 0 .AND. FMCOMP(M37,'<=',M16)  &
              .AND. FMCOMP(M38,'>=',M06)) THEN
              KASHIFT = 2*NDIG
              CALL FMADDI(M37,2*NDIG)
          ENDIF

          CALL FMI2M(40*NUMTRY,M16)
          CALL FMI2M(100,M06)
          IF (NUMTRY > 0 .AND. KBSHIFT == 0 .AND. FMCOMP(M37,'>=',M16)  &
              .AND. FMCOMP(M38,'<=',M06)) THEN
              KBSHIFT = 2*NDIG
              CALL FMADDI(M38,2*NDIG)
          ENDIF

          NUMTRY = NUMTRY + 1
          CALL FMEQ2(M25,MRETRY,NDOLD,NDIG)
          IF (KASHIFT == 2*NDIG .OR. KBSHIFT == 2*NDIG) THEN
              NDIG = MAX(NDIG,NDOLD+2)
          ENDIF
          GO TO 110
      ENDIF

  200 MACMAX = NINT(NDSAVE*ALOGM2)
      M25(0) = MIN(M25(0),MACCX,MACCA,MACCB,MACMAX)
      IF (KBIGAB /= 0) THEN
          IF ((M25(1) >= -MXSAVE  .AND. KBIGAB == -1) .OR.  &
              (M25(1) <= MXSAVE+1 .AND. KBIGAB ==  1) .OR.  &
              (KBIGAB == -9)) THEN
              CALL FMST2M('UNKNOWN',M25)
              KFLAG = -4
          ENDIF
      ENDIF
      CALL FMEXT2(M25,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMIBTA

      SUBROUTINE FMIBTA2(K_RETURN_CODE,MXSAVE,NTERMS,NUMTRY,NMETHD)

!  Check for various special cases in Incomplete Beta.

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MXSAVE
      INTEGER IEXTRA,J,J4,JSWITCH,K,KPT,K_RETURN_CODE,N,NDOLD,     &
              NDSAV1,NMETHD,NTERMS,NUMTRY,NUP
      INTEGER, PARAMETER :: KPRIME(8) = (/ 2, 3, 5, 7, 11, 13, 17, 19 /)
      LOGICAL FMCOMP

      K_RETURN_CODE = 0
      CALL FMI2M(0,M39)
      CALL FMBIG(M45)
      NDSAV1 = NDIG

!             If B is small, use more guard digits.

      CALL FMDPM(1.0D-10,M16)
      IF (FMCOMP(M38,'<=',M16)) THEN
          IEXTRA = NGRD52
          IF (NDIG+IEXTRA <= NDG2MX) THEN
              CALL FMEQ2_R1(M36,NDIG,NDIG+IEXTRA)
              CALL FMEQ2_R1(M37,NDIG,NDIG+IEXTRA)
              CALL FMEQ2_R1(M38,NDIG,NDIG+IEXTRA)
          ENDIF
          NDOLD = NDIG
          NDIG = NDIG + IEXTRA
          IF (NUMTRY > 0 .AND. NDIG > NDG2MX-6) NDIG = NDG2MX - 6
          IF (NDIG > NDG2MX-6) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDOLD
              CALL FMST2M('UNKNOWN',M25)
             K_RETURN_CODE = 2
             RETURN
          ENDIF
      ENDIF

      NTERMS = INT(INTMAX/10)
      NMETHD = 0

!             Check for special cases.

      IF (M36(2) == 0) THEN
          CALL FMI2M(0,M25)
          K_RETURN_CODE = 1
          RETURN
      ENDIF
      CALL FMI2M(1,M32)
      IF (FMCOMP(M32,'==',M36)) THEN
          IEXTRA = MIN(NDIG+NGRD52,NDG2MX) - NDIG
          CALL FMEQ2_R1(M36,NDIG,NDIG+IEXTRA)
          CALL FMEQ2_R1(M37,NDIG,NDIG+IEXTRA)
          CALL FMEQ2_R1(M38,NDIG,NDIG+IEXTRA)
          NDIG = NDIG + IEXTRA
          CALL FMBETA(M37,M38,M35)
          CALL FMEQ(M35,M25)
          K_RETURN_CODE = 1
          RETURN
      ELSE IF (M36(-1) < 0 .OR. FMCOMP(M36,'>',M32)) THEN
          CALL FMST2M('UNKNOWN',M25)
          KFLAG = -4
          K_RETURN_CODE = 2
          RETURN
      ENDIF
      IF (M37(-1) < 0) THEN
          CALL FMST2M('UNKNOWN',M25)
          KFLAG = -4
          K_RETURN_CODE = 2
          RETURN
      ENDIF
      IF (M38(-1) < 0) THEN
          CALL FMST2M('UNKNOWN',M25)
          KFLAG = -4
          K_RETURN_CODE = 2
          RETURN
      ENDIF
      IF (M37(1) < (-NDIG) .AND. M38(1) < (-NDIG)) THEN
          CALL FMSUB(M32,M36,M16)
          CALL FMLN(M16,M25)
          CALL FMDIV(M32,M37,M16)
          CALL FMSUB(M16,M25,M17)
          CALL FMPWR(M36,M37,M16)
          CALL FMMPY(M17,M16,M25)
          K_RETURN_CODE = 1
          RETURN
      ENDIF
      CALL FMI2M(1,M16)
      CALL FMSUB(M16,M38,M06)
      CALL FMMPY(M36,M06,M16)
      CALL FMADD(M16,M32,M06)
      IF (FMCOMP(M06,'==',M32)) THEN
          CALL FMLN(M36,M16)
          CALL FMMPY(M37,M16,M25)
          CALL FMLN(M37,M16)
          CALL FMSUB_R2(M25,M16)
          CALL FMEXP(M16,M25)
          K_RETURN_CODE = 2
          RETURN
      ENDIF

!             When A or B is large, check for an underflowed result.

      CALL FMDPM(1.0D+7,M16)
      IF (FMCOMP(M37,'>',M16) .OR. FMCOMP(M38,'>',M16)) THEN

!             If B is much larger than A, approximate BETA(A,B) and use
!             that as an upper bound.

          IF (M38(1) >= M37(1)+NDIG) THEN
              CALL FMADD(M38,M37,M16)
              CALL FMLN(M16,M27)
              CALL FMMPY_R2(M37,M27)
              CALL FMEQ(M37,M31)
              CALL FMLNGM(M31,M28)
              CALL FMSUB(M28,M27,M16)
              CALL FMEXP(M16,M25)
              IF (M25(1) <= -MXSAVE-1) THEN
                  K_RETURN_CODE = 2
                  RETURN
              ENDIF
          ENDIF

!             If A > 2 > B, use the bound
!                C = min( X , (A-2)/(A+B-2) )
!                BETA(X,A,B) < (A-1)*X/B * C**(A-2) * (1-C)**B
!
!             An alternate bound is also tried:
!                C = min( X , (A-1)/(A+B-2) )
!                BETA(X,A,B) < C**A * (1-C)**(1-B)

          CALL FMI2M(2,M16)
          IF (FMCOMP(M37,'>',M16) .AND. FMCOMP(M37,'>',M16)) THEN
              CALL FMI2M(2,M05)
              CALL FMSUB(M37,M05,M16)
              CALL FMADD(M37,M38,M06)
              CALL FMSUB_R1(M06,M05)
              CALL FMDIV_R1(M16,M06)
              CALL FMMIN(M36,M16,M27)
              CALL FMI2M(1,M16)
              CALL FMSUB_R2(M37,M16)
              CALL FMLN(M16,M31)
              CALL FMLN(M36,M16)
              CALL FMADD_R1(M31,M16)
              CALL FMLN(M38,M16)
              CALL FMSUB_R1(M31,M16)
              CALL FMI2M(2,M06)
              CALL FMSUB(M37,M06,M25)
              CALL FMLN(M27,M16)
              CALL FMMPY_R2(M25,M16)
              CALL FMADD_R1(M31,M16)
              CALL FMI2M(1,M06)
              CALL FMSUB(M06,M27,M16)
              CALL FMLN(M16,M25)
              CALL FMMPY(M38,M25,M16)
              CALL FMADD_R1(M31,M16)
              CALL FMEXP(M31,M25)
              IF (M25(1) <= -MXSAVE-1) THEN
                  K_RETURN_CODE = 2
                  RETURN
              ENDIF
              CALL FMI2M(1,M06)
              CALL FMSUB(M37,M06,M16)
              CALL FMADD(M37,M38,M06)
              CALL FMI2M(2,M05)
              CALL FMSUB_R1(M06,M05)
              CALL FMDIV_R1(M16,M06)
              CALL FMMIN(M36,M16,M27)
              CALL FMI2M(1,M06)
              CALL FMSUB(M06,M27,M16)
              CALL FMLN(M16,M31)
              CALL FMSUB(M38,M06,M05)
              CALL FMMPY_R2(M05,M31)
              CALL FMLN(M36,M16)
              CALL FMMPY_R2(M37,M16)
              CALL FMADD_R2(M16,M31)
              CALL FMEXP(M31,M25)
              IF (M25(1) <= -MXSAVE-1) THEN
                  K_RETURN_CODE = 2
                  RETURN
              ENDIF
          ENDIF

!             If A > 2 and B > 2, use the bound
!                C = min( X , (A-1)/(A+B-2) )
!                BETA(X,A,B) < X * C**(A-1) * (1-C)**(B-1)

          CALL FMI2M(2,M16)
          IF (FMCOMP(M37,'>',M16) .AND. FMCOMP(M38,'>',M16)) THEN
              CALL FMI2M(1,M06)
              CALL FMSUB(M37,M06,M16)
              CALL FMADD(M37,M38,M06)
              CALL FMI2M(2,M05)
              CALL FMSUB_R1(M06,M05)
              CALL FMDIV_R1(M16,M06)
              CALL FMMIN(M36,M16,M27)
              CALL FMI2M(1,M06)
              CALL FMSUB(M06,M27,M16)
              CALL FMLN(M16,M31)
              CALL FMSUB(M38,M06,M05)
              CALL FMMPY_R2(M05,M31)
              CALL FMLN(M27,M16)
              CALL FMSUB(M37,M06,M05)
              CALL FMMPY_R2(M05,M16)
              CALL FMADD_R2(M16,M31)
              CALL FMLN(M36,M16)
              CALL FMADD_R2(M16,M31)
              CALL FMEXP(M31,M25)
              IF (M25(1) <= -MXSAVE-1) THEN
                  K_RETURN_CODE = 2
                  RETURN
              ENDIF
          ENDIF
      ENDIF

!             Check for cases where X is large enough so that at this
!             precision, B(X,A,B) = B(A,B).  These are often unstable,
!             so it is better to use Beta.

      CALL FMI2M(1,M16)
      CALL FMI2M(2,M05)
      CALL FMADD(M37,M38,M06)
      IF (FMCOMP(M37,'>',M16) .AND. FMCOMP(M06,'>',M05)) THEN
              CALL FMI2M(1,M06)
              CALL FMSUB(M37,M06,M16)
              CALL FMADD(M37,M38,M06)
              CALL FMI2M(2,M05)
              CALL FMSUB_R1(M06,M05)
              CALL FMDIV(M16,M06,M35)
          CALL FMI2M(1,M16)
          CALL FMADD(M37,M38,M06)
          CALL FMADDI(M06,-3)
          IF (FMCOMP(M35,'<',M16) .AND. FMCOMP(M36,'>',M35) .AND.  &
              M06(2) /= 0) THEN
              CALL FMI2M(1,M06)
              CALL FMSUB(M37,M06,M05)
              CALL FMSUB(M38,M06,M16)
              CALL FMMPY_R2(M05,M16)
              CALL FMADD(M37,M38,M05)
              CALL FMI2M(3,M06)
              CALL FMSUB_R2(M05,M06)
              CALL FMDIV(M16,M06,M34)
              IF (M34(-1) >= 0) THEN
                  CALL FMI2M(1,M06)
                  CALL FMSUB_R2(M37,M06)
                  CALL FMSQRT(M34,M16)
                  CALL FMADD(M06,M16,M34)
                  CALL FMADD(M37,M38,M06)
                  CALL FMI2M(2,M05)
                  CALL FMSUB_R1(M06,M05)
                  CALL FMDIV_R1(M34,M06)
              ELSE
                  CALL FMDPM(DBLE(1.1),M34)
              ENDIF
              CALL FMI2M(1,M16)
              IF (FMCOMP(M34,'>',M35) .AND. FMCOMP(M34,'<',M16) .AND.  &
                  FMCOMP(M36,'>=',M34)) THEN

!                 Approximate B(A,B).

                  CALL FMADD(M37,M38,M16)
                  IF (FMCOMP(M16,'==',M37)) THEN
                      CALL FMLN(M38,M16)
                      CALL FMDPM(0.5D0,M06)
                      CALL FMSUB_R2(M38,M06)
                      CALL FMMPY(M06,M16,M33)
                      CALL FMSUB_R1(M33,M38)
                      CALL FMDPM(DLOGTP/2.0D0,M16)
                      CALL FMSUB_R1(M33,M16)
                      CALL FMLN(M37,M16)
                      CALL FMMPY_R2(M38,M16)
                      CALL FMSUB_R1(M33,M16)
                  ELSE IF (FMCOMP(M16,'==',M38)) THEN
                      CALL FMLN(M37,M16)
                      CALL FMDP2M(0.5D0,M06)
                      CALL FMSUB_R2(M37,M06)
                      CALL FMMPY(M06,M16,M33)
                      CALL FMSUB_R1(M33,M37)
                      CALL FMDPM(DLOGTP/2.0D0,M16)
                      CALL FMSUB_R1(M33,M16)
                      CALL FMLN(M38,M16)
                      CALL FMMPY_R2(M37,M16)
                      CALL FMSUB_R1(M33,M16)
                  ELSE
                      CALL FMLN(M37,M16)
                      CALL FMDP2M(0.5D0,M06)
                      CALL FMSUB_R2(M37,M06)
                      CALL FMMPY(M06,M16,M33)
                      CALL FMLN(M38,M16)
                      CALL FMDP2M(0.5D0,M06)
                      CALL FMSUB_R2(M38,M06)
                      CALL FMMPY_R2(M06,M16)
                      CALL FMADD_R1(M33,M16)
                      CALL FMADD(M37,M38,M16)
                      CALL FMLN(M16,M06)
                      CALL FMDP2M(0.5D0,M05)
                      CALL FMSUB_R2(M16,M05)
                      CALL FMMPY(M05,M06,M16)
                      CALL FMSUB_R1(M33,M16)
                      CALL FMDPM(DLOGTP/2.0D0,M16)
                      CALL FMSUB_R1(M33,M16)
                  ENDIF
                  CALL FMEXP(M33,M12)
                  CALL FMEQ(M12,M33)

!                 Bound the area from X to 1.

                  CALL FMI2M(1,M16)
                  CALL FMSUB(M16,M36,M06)
                  IF (FMCOMP(M06,'==',M16)) THEN
                      CALL FMLN(M36,M16)
                      CALL FMI2M(1,M05)
                      CALL FMSUB(M37,M05,M06)
                      CALL FMMPY(M06,M16,M32)
                      CALL FMSUB(M38,M05,M06)
                      CALL FMMPY(M36,M06,M16)
                      CALL FMSUB_R1(M32,M16)
                      CALL FMSUB(M05,M36,M16)
                      CALL FMDIVI_R1(M16,2)
                      CALL FMLN(M16,M17)
                      CALL FMSUB_R1(M32,M17)
                  ELSE
                      CALL FMLN(M36,M16)
                      CALL FMI2M(1,M05)
                      CALL FMSUB(M37,M05,M06)
                      CALL FMMPY(M06,M16,M32)
                      CALL FMSUB(M38,M05,M06)
                      CALL FMSUB(M05,M36,M16)
                      CALL FMLN(M16,M17)
                      CALL FMMPY_R2(M06,M17)
                      CALL FMADD_R1(M32,M17)
                      CALL FMDIVI_R1(M16,2)
                      CALL FMLN(M16,M17)
                      CALL FMADD_R1(M32,M17)
                  ENDIF
                  CALL FMEXP(M32,M12)
                  CALL FMEQ(M12,M32)
                  CALL FMSUB(M33,M32,M16)
                  IF (FMCOMP(M16,'==',M33)) THEN
                      CALL FMEQ(M32,M40)
                      CALL FMBETA(M37,M38,M35)
                      CALL FMSUB(M35,M40,M16)
                      IF (FMCOMP(M16,'==',M35)) THEN
                          M35(0) = 1.06*M35(0)
                          CALL FMEQ(M35,M25)
                          K_RETURN_CODE = 1
                          RETURN
                      ENDIF
                  ENDIF
              ENDIF
          ENDIF
      ELSE IF (M37(1) < 1 .AND. FMCOMP(M38,'>',M16)) THEN

!                 Approximate B(A,B).

          CALL FMADD(M37,M38,M16)
          IF (FMCOMP(M16,'==',M37)) THEN
              CALL FMLN(M38,M16)
              CALL FMDP2M(0.5D0,M06)
              CALL FMSUB_R2(M38,M06)
              CALL FMMPY(M06,M16,M33)
              CALL FMSUB_R1(M33,M38)
              CALL FMDPM(DLOGTP/2.0D0,M16)
              CALL FMSUB_R1(M33,M16)
              CALL FMLN(M37,M16)
              CALL FMMPY_R2(M38,M16)
              CALL FMSUB_R1(M33,M16)
          ELSE IF (FMCOMP(M16,'==',M38)) THEN
              CALL FMLN(M37,M16)
              CALL FMDP2M(0.5D0,M06)
              CALL FMSUB_R2(M37,M06)
              CALL FMMPY(M06,M16,M33)
              CALL FMSUB_R1(M33,M37)
              CALL FMDPM(DLOGTP/2.0D0,M16)
              CALL FMSUB_R1(M33,M16)
              CALL FMLN(M38,M16)
              CALL FMMPY_R2(M37,M16)
              CALL FMSUB_R1(M33,M16)
          ELSE
              CALL FMLN(M37,M16)
              CALL FMDP2M(0.5D0,M06)
              CALL FMSUB_R2(M37,M06)
              CALL FMMPY(M06,M16,M33)
              CALL FMLN(M38,M16)
              CALL FMDP2M(0.5D0,M06)
              CALL FMSUB_R2(M38,M06)
              CALL FMMPY_R2(M06,M16)
              CALL FMADD_R1(M33,M16)
              CALL FMADD(M37,M38,M16)
              CALL FMLN(M16,M06)
              CALL FMDP2M(0.5D0,M05)
              CALL FMSUB_R2(M16,M05)
              CALL FMMPY(M05,M06,M16)
              CALL FMSUB_R1(M33,M16)
              CALL FMDPM(DLOGTP/2.0D0,M16)
              CALL FMSUB_R1(M33,M16)
          ENDIF
          CALL FMEXP(M33,M12)
          CALL FMEQ(M12,M33)

!                 Bound the area from X to 1.

          CALL FMI2M(1,M16)
          CALL FMSUB(M16,M36,M06)
          IF (FMCOMP(M06,'==',M16)) THEN
              CALL FMLN(M36,M16)
              CALL FMI2M(1,M05)
              CALL FMSUB(M37,M05,M06)
              CALL FMMPY(M06,M16,M32)
              CALL FMSUB(M38,M05,M06)
              CALL FMMPY(M36,M06,M16)
              CALL FMSUB_R1(M32,M16)
              CALL FMSUB(M05,M36,M16)
              CALL FMDIVI_R1(M16,2)
              CALL FMLN(M16,M17)
              CALL FMSUB_R1(M32,M17)
              CALL FMEXP(M32,M12)
              CALL FMEQ(M12,M32)
          ELSE
              CALL FMLN(M36,M16)
              CALL FMI2M(1,M05)
              CALL FMSUB(M37,M05,M06)
              CALL FMMPY(M06,M16,M32)
              CALL FMSUB(M38,M05,M06)
              CALL FMSUB(M05,M36,M16)
              CALL FMLN(M16,M17)
              CALL FMMPY_R2(M06,M17)
              CALL FMADD_R1(M32,M17)
              CALL FMDIVI_R1(M16,2)
              CALL FMLN(M16,M17)
              CALL FMADD_R1(M32,M17)
              CALL FMEXP(M32,M12)
              CALL FMEQ(M12,M32)
          ENDIF
          CALL FMSUB(M33,M32,M16)
          IF (FMCOMP(M16,'==',M33)) THEN
              CALL FMBETA(M37,M38,M35)
              M35(0) = 1.06*M35(0)
              CALL FMEQ(M35,M25)
              K_RETURN_CODE = 1
              RETURN
          ENDIF
      ENDIF

!             If B is small enough, use one of two series or an asymptotic
!             series, depending on the size of X and A.

      CALL FMI2M(1,M05)
      CALL FMADD(M05,M38,M06)
      CALL FMADD(M37,M38,M16)
      IF ((FMCOMP(M06,'==',M05) .AND. FMCOMP(M16,'==',M37)) ) THEN
          CALL FMDP2M(0.5D0,M16)
          IF (FMCOMP(M36,'<=',M16)) THEN
              CALL FMI2M(0,M26)
              CALL FMEQ(M36,M27)
              CALL FMI2M(1,M06)
              CALL FMADD(M37,M06,M16)
              CALL FMDIV(M27,M16,M28)
              CALL FMEQ(M37,M18)
              CALL FMADDI(M18,1)
              NDSAV1 = NDIG
              DO J = 2, NTERMS
                 CALL FMADD_R1(M26,M28)
                 IF (KFLAG /= 0 .AND. J >= 3) EXIT
                 NDIG = MIN(NDSAV1,MAX(2,NDSAV1-INT(M26(1)-M28(1))+1))
                 CALL FMMPY_R1(M27,M36)
                 CALL FMADDI(M18,1)
                 CALL FMDIV(M27,M18,M28)
                 NDIG = NDSAV1
              ENDDO
              CALL FMPWR(M36,M37,M16)
              CALL FMI2M(1,M05)
              CALL FMDIV(M05,M37,M06)
              CALL FMADD(M06,M26,M05)
              CALL FMMPY(M16,M05,M26)
              CALL FMEQ(M26,M25)
              K_RETURN_CODE = 1
              RETURN
          ENDIF
          CALL FMDP2M(0.5D0,M16)
          CALL FMI2M(20,M06)
          IF ((FMCOMP(M36,'>',M16) .AND. FMCOMP(M37,'<',M06))) THEN
              CALL FMI2M(0,M26)
              CALL FMI2M(1,M16)
              CALL FMSUB(M16,M36,M29)
              CALL FMI2M(1,M06)
              CALL FMADD(M38,M06,M16)
              CALL FMPWR(M29,M16,M27)
              CALL FMI2M(1,M16)
              CALL FMSUB(M16,M37,M06)
              CALL FMMPY_R2(M06,M27)

              CALL FMEQ(M27,M28)
              NDSAV1 = NDIG
              DO J = 2, NTERMS
                 CALL FMADD_R1(M26,M28)
                 IF (KFLAG /= 0 .AND. J >= 3) EXIT
                 NDIG = MIN(NDSAV1,MAX(2,NDSAV1-INT(M26(1)-M28(1))+1))
                 CALL FMI2M(J,M06)
                 CALL FMSUB(M06,M37,M16)
                 CALL FMMPY(M27,M16,M06)
                 CALL FMMPY(M06,M29,M16)
                 CALL FMDIVI(M16,J,M27)
                 CALL FMDIVI(M27,J,M28)
                 NDIG = NDSAV1
              ENDDO
              CALL FMLN(M29,M16)
              CALL FMI2M(1,M06)
              CALL FMDIV(M06,M37,M05)
              CALL FMSUB(M05,M16,M06)
              CALL FMSUB(M06,M26,M27)
              CALL FMEULR(M28)
              CALL FMI2M(1,M16)
              CALL FMADD(M37,M16,M29)
              CALL FMPSI(M29,M14)
              CALL FMEQ(M14,M29)
              CALL FMSUB(M27,M28,M16)
              CALL FMSUB(M16,M29,M25)
              K_RETURN_CODE = 1
              RETURN
          ENDIF

          CALL FMDP2M(0.5D0,M16)
          CALL FMI2M(20,M06)
          IF ((FMCOMP(M36,'>',M16) .AND. FMCOMP(M37,'>=',M06))) THEN
              CALL FMSP2M(0.7*REAL(NDIG)*ALOGMT,M32)
              IF (FMCOMP(M37,'>=',M32)) THEN
                  NUP = 0
                  CALL FMEQ(M37,M39)
                  CALL FMI2M(0,M40)
              ELSE
                  CALL FMSUB(M32,M37,M16)
                  CALL FMADDI(M16,1)
                  CALL FMM2I(M16,NUP)
                  CALL FMI2M(NUP,M16)
                  CALL FMADD(M37,M16,M39)
                  CALL FMI2M(1,M40)
                  CALL FMEQ(M37,M27)
                  NDSAV1 = NDIG
                  DO J = 1, NUP-1
                     CALL FMMPY_R1(M27,M36)
                     CALL FMI2M(J,M16)
                     CALL FMADD(M37,M16,M06)
                     CALL FMDIV(M27,M06,M28)
                     NDIG = NDSAV1
                     CALL FMADD_R1(M40,M28)
                     NDIG = MIN(NDSAV1,  &
                             MAX(2,NDSAV1-INT(M40(1)-M28(1))+1))
                  ENDDO
                  NDIG = NDSAV1
                  CALL FMPWR(M36,M37,M16)
                  CALL FMMPY(M40,M16,M17)
                  CALL FMI2M(1,M06)
                  CALL FMSUB(M06,M36,M16)
                  CALL FMPWR(M16,M38,M40)
                  CALL FMMPY_R2(M17,M40)
                  CALL FMDIV_R1(M40,M37)
              ENDIF

              CALL FMI2M(1,M06)
              CALL FMDIVI(M06,2,M16)
              CALL FMSUB(M39,M16,M33)
              CALL FMLN(M36,M16)
              CALL FMMPY(M33,M16,M34)
              IF (M34(1) /= MUNKNO .AND. M34(2) /= 0) M34(-1) = -M34(-1)
              CALL FMIGM2(M38,M34,M35)
              CALL FMPWR(M34,M38,M16)
              CALL FMEQ(M34,M17)
              IF (M17(1) /= MUNKNO .AND. M17(2) /= 0) M17(-1) = -M17(-1)
              CALL FMEXP(M17,M06)
              CALL FMMPY(M06,M16,M17)
              CALL FMDIV_R1(M35,M17)
              CALL FMEQ(M35,M26)
              CALL FMSQR(M33,M16)
              CALL FMMPYI(M16,4,M27)
              CALL FMI2M(1,M28)
              CALL FMI2M(1,M29)
              CALL FMI2M(1,M30)
              CALL FMLN(M36,M16)
              CALL FMDIVI(M16,2,M06)
              CALL FMSQR(M06,M32)
              NDSAV1 = NDIG
              J4 = 0
              DO J = 1, NTERMS
                 JSWITCH = MAX(2,INT(NDIG*DLOGMB/(2.0D0*LOG(23.0)) + 2))
                 IF (J < JSWITCH) THEN
                     J4 = 0
                     CALL FMMPYI_R1(M29,4)
                     CALL FMMPYI(M30,2*J-1,M16)
                     CALL FMMPYI(M16,2*J,M30)
                     CALL FMI2M(2,M06)
                     CALL FMSUB(M06,M29,M16)
                     CALL FMDIV(M16,M30,M31)
                     CALL FMBERN(2*J,M31,M11)
                     CALL FMEQ(M11,M31)
                 ELSE
                     IF (J4 == 0) THEN
                         J4 = 1
                         N = 2*J
                         DO K = 1, 8
                            KPT = (K-1)*(NDSAV1+3)
                            CALL FMI2M(KPRIME(K),MJSUMS(KPT-1))
                            CALL FMIPWR(MJSUMS(KPT-1),N,M16)
                            CALL FMEQ(M16,MJSUMS(KPT-1))
                         ENDDO
                     ELSE
                         DO K = 1, 8
                            KPT = (K-1)*(NDSAV1+3)
                            CALL FMMPYI(MJSUMS(KPT-1),KPRIME(K)**2,  &
                                        MJSUMS(KPT-1))
                         ENDDO
                     ENDIF
                     CALL FMPI(M22)
                     CALL FMI2M(1,M18)
                     CALL FMI2M(1,M19)
                     DO K = 1, 8
                        KPT = (K-1)*(NDSAV1+3)
                        CALL FMEQ(MJSUMS(KPT-1),M21)
                        CALL FMI2M(KPRIME(K)**2-1,M16)
                        CALL FMSUB(M21,M18,M06)
                        CALL FMDIV_R2(M16,M06)
                        CALL FMSUB(M18,M06,M20)
                        CALL FMI2M(1,M16)
                        IF (FMCOMP(M20,'==',M16)) EXIT
                        CALL FMMPY_R1(M19,M20)
                     ENDDO
                     CALL FMEQ(MJSUMS,M21)
                     CALL FMI2M(-1,M06)
                     CALL FMSQR(M22,M17)
                     CALL FMDIV(M06,M17,M16)
                     CALL FMI2M(2,M06)
                     CALL FMSUB(M06,M21,M05)
                     CALL FMI2M(8,M06)
                     CALL FMSUB_R1(M06,M21)
                     CALL FMDIV(M05,M06,M17)
                     CALL FMMPY(M16,M17,M06)
                     CALL FMMPY(M06,M19,M20)
                     CALL FMMPY_R2(M20,M31)
                 ENDIF
                 CALL FMI2M(2*J-2,M06)
                 CALL FMADD(M38,M06,M16)
                 CALL FMMPY(M16,M35,M06)
                 CALL FMMPYI(M06,2*J-1,M35)
                 CALL FMI2M(2*J-1,M06)
                 CALL FMADD(M34,M06,M16)
                 CALL FMMPY(M28,M16,M06)
                 CALL FMADD_R1(M35,M06)
                 CALL FMDIV_R1(M35,M27)
                 CALL FMMPY_R1(M28,M32)
                 CALL FMMPY(M31,M35,M23)
                 NDIG = NDSAV1
                 CALL FMADD_R1(M26,M23)
                 IF (KFLAG /= 0 .AND. J >= 3) EXIT
                 NDIG = MIN(NDSAV1,MAX(2,NDSAV1-INT(M26(1)-M23(1))+1))
              ENDDO
              NDIG = NDSAV1
              CALL FMPWR(M36,M33,M16)
              CALL FMLN(M36,M17)
              IF (M17(1) /= MUNKNO .AND. M17(2) /= 0) M17(-1) = -M17(-1)
              CALL FMPWR(M17,M38,M25)
              CALL FMMPY(M26,M16,M06)
              CALL FMMPY_R2(M06,M25)
              CALL FMADD_R2(M40,M25)
              K_RETURN_CODE = 1
              RETURN
          ENDIF
      ENDIF

!             If A or B is large in magnitude, use more guard digits.

      IEXTRA = MIN(MAX(INT(M37(1)),INT(M38(1)),0) ,  &
                   INT(1.0+ALOGMX/ALOGMB))
      IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
          CALL FMEQ2_R1(M36,NDIG,NDIG+IEXTRA)
          CALL FMEQ2_R1(M37,NDIG,NDIG+IEXTRA)
          CALL FMEQ2_R1(M38,NDIG,NDIG+IEXTRA)
      ENDIF
      NDOLD = NDIG
      NDIG = NDIG + IEXTRA
      IF (NUMTRY > 0 .AND. NDIG > NDG2MX-6) NDIG = NDG2MX - 6
      IF (NDIG > NDG2MX-6) THEN
          KFLAG = -9
          CALL FMWRN2
          NDIG = NDOLD
          CALL FMST2M('UNKNOWN',M25)
          K_RETURN_CODE = 2
      ENDIF
      RETURN
      END SUBROUTINE FMIBTA2

      SUBROUTINE FMIGM1(MA,MB,MC)

!  MC = Incomplete Gamma(MA,MB)

!  Integral from 0 to MB of e**(-t) * t**(MA-1)  dt.

!  This is (lower case) gamma(a,x).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
      DOUBLE PRECISION FMDPLG,X,A,B,SMALL,BIG,TOL,T1,BIGJ
      REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MAXE,MODA2,MXSAVE
      INTEGER IEXTRA,INTA,INTG,J,JCHECK,JEXTRA,JTERMS,K,KASAVE,KFLAGA,   &
              KFLAGI,KFLAGX,KFLGOK,KMID,KOVUN,KRESLT,KWRNSV,KXNEG,LESS,  &
              NDGOAL,NDIG2,NDOLD,NDSAV1,NDSAVE,NGOAL,NMETHD,NMNNDG,      &
              NMXDIF,NT,NTERMS,NUMTRY
      LOGICAL FMCOMP
      REAL C,C1,C2,D,T,TLNB,Y

      CALL FMENT2('FMIGM1',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN

      KACCSW = 1
      MACCA = MA(0)
      MACCB = MB(0)
      CALL FMEQ2(MA,M31,NDSAVE,NDIG)
      M31(0) = NINT(NDIG*ALOGM2)
      CALL FMEQ2(MB,M32,NDSAVE,NDIG)
      M32(0) = NINT(NDIG*ALOGM2)
      NUMTRY = 0

  110 NTERMS = INT(INTMAX/10)

!             Check for special cases.

!             See if A is small enough so that the result is X**A/A.

      CALL FMI2M(1,M16)
      CALL FMADD(M31,M16,M06)
      IF (FMCOMP(M06,'==',M16)) THEN
          CALL FMPWR(M32,M31,M16)
          CALL FMDIV(M16,M31,M25)
          IF (M25(1) /= MUNKNO) GO TO 180
      ENDIF

!             Check to see if X is large enough so that the result
!             is Gamma(A).

      CALL FMI2M(1,M16)
      CALL FMDIV(M31,M32,M06)
      M06(-1) = 1
      CALL FMDPM(DBLE(0.001),M05)
      IF (FMCOMP(M32,'>',M16) .AND. FMCOMP(M06,'<=',M05)) THEN
          CALL FMI2M(1,M06)
          CALL FMSUB(M31,M06,M16)
          CALL FMLN(M32,M17)
          CALL FMMPY(M16,M17,M06)
          CALL FMSUB(M06,M32,M17)
          CALL FMEXP(M17,M30)
          IF (M30(1) /= MUNKNO) THEN
              CALL FMGAM(M31,M29)
              IF (M29(1) > M30(1)+NDIG .AND.  &
                  M29(1) /= MUNKNO) THEN
                  CALL FMEQ(M29,M25)
                  GO TO 180
              ENDIF
          ENDIF
      ENDIF

!             A,X are double precision approximations to the two
!                 arguments to this function.
!             INTA = A if A is a small integer.  It is used to limit
!                  the number of terms used in the asymptotic series
!                  and in the continued fraction expansion.

      INTA = NTERMS
      KWRNSV = KWARN
      KWARN = 0
      CALL FMM2I(M31,INTG)
      KFLAGI = KFLAG
      IF (KFLAG == 0) INTA = INTG
      CALL FMM2DP(M31,A)
      KFLAGA = KFLAG
      IF (KFLAG /= 0 .AND. M31(1) < 0) THEN
          A = 1.0D0/DPMAX
          IF (M31(-1) < 0) A = -A
          KFLAGA = 0
      ENDIF
      CALL FMM2DP(M32,X)
      KFLAGX = KFLAG
      IF (KFLAG /= 0 .AND. M32(1) < 0) THEN
          X = 1.0D0/DPMAX
          IF (M32(-1) < 0) X = -X
          KFLAGX = 0
      ENDIF
      KWARN = KWRNSV

!             If A or X is large in magnitude, use more guard digits.

      IEXTRA = MIN(MAX(INT(M31(1)),INT(M32(1)),0) ,  &
                   INT(1.0+ALOGMX/ALOGMB))
      IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
          CALL FMEQ2_R1(M31,NDIG,NDIG+IEXTRA)
          CALL FMEQ2_R1(M32,NDIG,NDIG+IEXTRA)
      ENDIF
      NDOLD = NDIG
      NDIG = NDIG + IEXTRA
      IF (NDIG > NDG2MX) THEN
          KFLAG = -9
          CALL FMWRN2
          NDIG = NDOLD
          CALL FMST2M('UNKNOWN',M25)
          GO TO 180
      ENDIF

!             KXNEG = 1 if X is negative and A is a positive integer.

      KXNEG = 0

!             MODA2 = MOD(A,2) when KXNEG is 1.

      MODA2 = 0

      IF (M31(1) == MEXPOV .OR. M32(1) == MEXPOV) THEN
          IF (M31(1) == MEXPOV .AND. M31(2) /= 0 .AND.  &
              M31(-1) == 1) THEN
              IF (M32(2) == 0) THEN
                  CALL FMI2M(0,M25)
                  GO TO 160
              ENDIF
              IF (M32(1) == MEXPOV .AND. M32(2) /= 0 .AND.  &
                  M32(-1) == 1) THEN
                  CALL FMST2M('OVERFLOW',M25)
                  KFLAG = -5
                  GO TO 160
              ELSE IF (M32(-1) > 0) THEN
                  CALL FMI2M(1,M25)
                  IF (FMCOMP(M32,'<=',M25)) THEN
                      CALL FMST2M('UNDERFLOW',M25)
                      KFLAG = -6
                      GO TO 160
                  ELSE
                      CALL FMST2M('OVERFLOW',M25)
                      KFLAG = -5
                      GO TO 160
                  ENDIF
              ENDIF
          ENDIF
          IF (M32(1) == MEXPOV .AND. M32(2) /= 0 .AND.  &
              M32(-1) == 1) THEN
              CALL FMGAM(M31,M30)
              CALL FMEQ(M30,M25)
              GO TO 160
          ENDIF
          IF (M32(1) == MEXPOV .AND. M32(-1) < 0 .AND.  &
              M31(-1) > 0.AND. M31(2) > 0) THEN
              IF (M31(1) /= MEXPOV) THEN
                  CALL FMINT(M31,M24)
                  IF (FMCOMP(M31,'==',M24)) THEN
                      CALL FMI2M(2,M21)
                      CALL FMMOD(M24,M21,M16)
                      CALL FMEQ(M16,M21)
                      IF (M21(2) /= 0) THEN
                          CALL FMST2M('-OVERFLOW',M25)
                          KFLAG = -5
                          GO TO 160
                      ELSE
                          CALL FMST2M('OVERFLOW',M25)
                          KFLAG = -5
                          GO TO 160
                      ENDIF
                  ENDIF
              ENDIF
          ENDIF
          CALL FMST2M('UNKNOWN',M25)
          KFLAG = -4
          GO TO 180
      ENDIF

      IF (M31(1) == MEXPUN .OR. M32(1) == MEXPUN) THEN
          CALL FMABS(M31,M06)
          CALL FMI2M(1,M16)
          IF (FMCOMP(M06,'<',M16) .AND. M32(1) == MEXPUN) THEN
              CALL FMST2M('UNKNOWN',M25)
              KFLAG = -4
              GO TO 180
          ENDIF
          CALL FMABS(M31,M06)
          CALL FMI2M(1,M16)
          IF (FMCOMP(M06,'>=',M16) .AND. M32(1) == MEXPUN .AND.  &
              M32(-1) > 0) THEN
              CALL FMST2M('UNDERFLOW',M25)
              KFLAG = -6
              GO TO 180
          ENDIF
      ENDIF

      IF (M31(-1) < 0 .OR. M31(2) == 0) THEN
          CALL FMINT(M31,M24)
          IF (FMCOMP(M31,'==',M24)) THEN
              CALL FMST2M('UNKNOWN',M25)
              KFLAG = -4
              GO TO 180
          ENDIF
      ENDIF
      IF (M32(2) == 0) THEN
          IF (M31(-1) <= 0) THEN
              CALL FMST2M('UNKNOWN',M25)
              KFLAG = -4
              GO TO 180
          ELSE
              CALL FMI2M(0,M25)
              GO TO 180
          ENDIF
      ENDIF
      IF (M32(-1) < 0) THEN
          CALL FMINT(M31,M24)
          IF (FMCOMP(M31,'==',M24)) THEN
              KXNEG = 1
              CALL FMI2M(2,M21)
              CALL FMMOD(M24,M21,M16)
              CALL FMEQ(M16,M21)
              IF (M21(2) /= 0) MODA2 = 1
          ELSE
              CALL FMST2M('UNKNOWN',M25)
              KFLAG = -4
              GO TO 180
          ENDIF
      ENDIF
      CALL FMMAX(M31,M32,M16)
      CALL FMMIN(M31,M32,M17)
      CALL FMDPM(1.0D6,M05)
      CALL FMDPM(1.0D2,M06)
      IF (FMCOMP(M16,'>=',M05) .AND. FMCOMP(M17,'>=',M06)) THEN
          CALL FMI2M(1,M16)
          CALL FMSUB(M31,M16,M18)
          CALL FMMIN(M18,M32,M20)
          CALL FMADDI(M20,-1)
          CALL FMLN(M20,M16)
          CALL FMMPY(M18,M16,M06)
          CALL FMSUB(M06,M20,M16)
          CALL FMEXP(M16,M22)
          IF ((M22(1) == MEXPOV .AND. M22(2) /= 0 .AND.   &
              M22(-1) > 0) .OR. M22(1) > MXSAVE+1) THEN
              CALL FMST2M('OVERFLOW',M25)
              KFLAG = -5
              GO TO 160
          ENDIF
      ENDIF

!             Determine which method to use.

!             NMETHD = 1 means use the convergent series,
!                    = 2 means use the asymptotic series,
!                    = 3 means use the continued fraction expansion.

      CALL FMI2M(-10000,M20)
      CALL FMI2M(10000,M21)
      CALL FMABS(M31,M23)
      CALL FMABS(M32,M24)
      CALL FMSUB(M24,M23,M22)
      IF (FMCOMP(M22,'<=',M20)) THEN
          NMETHD = 1
      ELSE IF (FMCOMP(M22,'>=',M21) .AND. M31(-1) > 0  &
               .AND. M32(-1) > 0) THEN
          NMETHD = 2
      ELSE IF (FMCOMP(M22,'>=',M21)) THEN
          NMETHD = 3
      ELSE IF (M31(-1) > 0 .AND. M32(-1) > 0) THEN
          CALL FMDP2M(SQRT(DPMAX),M20)
          IF (FMCOMP(M32,'>=',M20)) THEN
              KFLAG = -5
              CALL FMST2M('OVERFLOW',M25)
              GO TO 160
          ENDIF

          C2 = REAL(DBLE(NDSAVE)*DLOGMB)
          C1 = REAL(DBLE(C2)/10.0D0 + A + 10.0D0)
          C2 = REAL(MAX( 10.0D0 , DBLE(C2)/6.0D0 ,  &
                         A - 3.5D0*A/(SQRT(A)+1.0D0)))
          IF (X < C1) THEN
              NMETHD = 1
          ELSE
              NMETHD = 3
          ENDIF
          IF (X > C2) THEN

!             Check that the smallest term in the asymptotic series is
!             small enough to give the required accuracy.

              T1 = FMDPLG(A)
              SMALL = T1 - FMDPLG(-ABS(X)) - (A+ABS(X))*LOG(ABS(X))
              TOL = -DBLE(NDIG+2)*DLOGMB - 12.0D0
              B = 1.0D0
              IF (A > ABS(X)) B = A - ABS(X)
              BIG = T1 - FMDPLG(A-B) - B*LOG(ABS(X))
              IF (SMALL < TOL+BIG) NMETHD = 2
          ENDIF
      ELSE IF (M31(-1) < 0 .AND. M32(-1) > 0) THEN
          TLNB = REAL(NDIG)*ALOGMB
          C = 0.75/TLNB**0.35
          D = 0.80*TLNB**0.70
          IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
              T = REAL(-A) - D/C
              Y = D + C*T/2.0 + (C/2.0)*SQRT(T**2 + T + (2.0/C)**2)
              IF (X > Y) THEN
                  NMETHD = 3
              ELSE
                  NMETHD = 1
              ENDIF
          ELSE
              CALL FMDPM(DBLE(C),M16)
              CALL FMMPY(M16,M31,M20)
              M20(-1) = 1
              IF (FMCOMP(M32,'>',M20)) THEN
                  NMETHD = 3
              ELSE
                  NMETHD = 1
              ENDIF
          ENDIF
      ELSE IF (M31(-1) > 0 .AND. M32(-1) < 0) THEN
          CALL FMDPM(DBLE(-0.8),M16)
          CALL FMMPY(M16,M31,M20)
          IF (FMCOMP(M20,'<',M32)) THEN
              NMETHD = 1
          ELSE
              NMETHD = 3
          ENDIF
      ENDIF

      IF (NMETHD == 2) GO TO 130
      IF (NMETHD == 3) GO TO 150

!             Method 1.  Use the X**N/Pochhammer(A+1,N) series.

!             M25 is the current sum.
!             M21 is the current term.
!             M20 is (A+N)/X.
!             M29 is 1/X

!             Raise the precision if A is negative and near an integer,
!             to compensate for cancellation when (A+N)/X is near zero.

      IF (M31(-1) < 0) THEN
          CALL FMNINT(M31,M25)
          CALL FMSUB(M31,M25,M29)
          IEXTRA = MAX(-INT(M29(1)),0)
          IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
              CALL FMEQ2_R1(M31,NDIG,NDIG+IEXTRA)
              CALL FMEQ2_R1(M32,NDIG,NDIG+IEXTRA)
          ENDIF
          NDOLD = NDIG
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDOLD
              CALL FMST2M('UNKNOWN',M25)
              GO TO 180
          ENDIF
      ENDIF

      JEXTRA = 0

  120 CALL FMI2M(1,M25)
      CALL FMI2M(1,M18)
      CALL FMADD(M31,M18,M20)
      CALL FMDIV(M32,M20,M21)
      CALL FMDIV_R1(M20,M32)
      CALL FMDIV(M18,M32,M29)
      NDSAV1 = NDIG
      MAXE = 1

!             If A is negative and ABS(A) > ABS(X), the terms in the
!             series first decrease, then increase, then decrease.
!             Try to predict the number of extra digits required to
!             keep the precision from prematurely becoming too small.

      KFLGOK = 1
      IF (M31(-1) < 0) THEN
          IF (KFLAGA == 0) THEN
              IF (ABS(A) > 1.0D3) THEN
                  NMETHD = 3
                  GO TO 150
              ENDIF
          ELSE
              NMETHD = 3
              GO TO 150
          ENDIF
          KFLGOK = 0
          CALL FMABS(M31,M05)
          CALL FMABS(M32,M06)
          IF (FMCOMP(M05,'>',M06)) THEN
              IF (JEXTRA == 0) THEN
                  IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
                      T1 = FMDPLG(A+AINT(-ABS(X)-A)) -  &
                           FMDPLG(A+1.0D0+AINT(ABS(X)-A))
                      T1 = (T1 + 2.0D0*ABS(X)*LOG(ABS(X)+1.0D-10))/  &
                            DLOGMB
                      T1 = MAX(0.0D0,T1+1.0D0)
                      JEXTRA = INT(MIN(DBLE(NDIGMX),T1))
                  ENDIF
              ENDIF

!             If A is negative and ABS(A) is much bigger than ABS(X),
!             the later increase in the size of the terms can be
!             ignored.

              IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
                  T1 = (AINT(X-A)*LOG(ABS(X)+1.0D-10) + FMDPLG(A+1.0D0)  &
                       - FMDPLG(A+1.0D0+AINT(X-A))) / DLOGMB
                  IF (T1 < -DBLE(NDIG)) KFLGOK = 1
              ELSE
                  KFLGOK = 1
              ENDIF
          ENDIF
      ENDIF

      NMNNDG = NDSAV1
      NMXDIF = 0

!             Method 1 summation loop.

      DO J = 1, NTERMS
         NDIG = NDSAV1
         MAXE = MAX(MAXE,M21(1))
         CALL FMADD_R1(M25,M21)
         IF (KFLAG /= 0) THEN
             IF (KFLGOK == 0 .AND. KFLAGA == 0 .AND. KFLAGX == 0) THEN
                 IF (DBLE(J) > X-A) EXIT
             ELSE
                 EXIT
             ENDIF
         ENDIF

         CALL FMADD_R1(M20,M29)

         NDIG2 = MAX(2,NDSAV1-INT(M25(1)-M21(1)))
         NDIG = MIN(NDSAV1,NDIG2+JEXTRA)
         NMNNDG = MIN(NMNNDG,NDIG)
         NMXDIF = MAX(NMXDIF,NDIG-NMNNDG)
         CALL FMDIV_R1(M21,M20)
      ENDDO

      NDIG = NDSAV1
      IF (NMXDIF > JEXTRA+1) THEN
          JEXTRA = NMXDIF
          GO TO 120
      ENDIF

      CALL FMABS(M32,M16)
      CALL FMLN(M16,M17)
      CALL FMMPY(M31,M17,M06)
      CALL FMSUB(M06,M32,M29)
      CALL FMEXP(M29,M30)
      CALL FMDIV(M25,M31,M24)
      CALL FMMPY(M30,M24,M23)
      IF (M23(1) == MUNKNO) THEN
          CALL FMLN(M25,M16)
          CALL FMLN(M31,M17)
          CALL FMADD(M29,M16,M06)
          CALL FMSUB(M06,M17,M29)
          CALL FMEXP(M29,M25)
      ELSE
          CALL FMEQ(M23,M25)
      ENDIF
      IF (KXNEG == 1 .AND. MODA2 == 1 .AND. M25(1) /= MUNKNO .AND.  &
          M25(2) /= 0) THEN
          M25(-1) = -M25(-1)
      ENDIF

      GO TO 160

!             Method 2.  Use the Pochhammer(A-N,N)/X**N series.

!             M25 is the current sum.
!             M21 is the current term.
!             M20 is (A-N)/X.
!             M29 is -1/X

!             Raise the precision if A is positive and near an integer,
!             to compensate for cancellation when (A-N)/X is near zero.

  130 IF (M31(-1) > 0) THEN
          CALL FMNINT(M31,M25)
          CALL FMSUB(M31,M25,M29)
          IEXTRA = MAX(-INT(M29(1)),0)
          IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
              CALL FMEQ2_R1(M31,NDIG,NDIG+IEXTRA)
              CALL FMEQ2_R1(M32,NDIG,NDIG+IEXTRA)
          ENDIF
          NDOLD = NDIG
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDOLD
              CALL FMST2M('UNKNOWN',M25)
              GO TO 180
          ENDIF
      ENDIF

      CALL FMGAM(M31,M30)
      IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
          NT = INT(((A-1)*LOG(ABS(X)+1.0D-10) - X)/DLOGMB)
          LESS = MAX(0,INT(M30(1)) - NT - 1)
          IF (LESS > NDIG .AND. ABS(A) < ABS(X)) THEN
              CALL FMEQ(M30,M25)
              GO TO 160
          ENDIF
      ENDIF
      IF (KFLAG /= 0) THEN
          CALL FMEQ(M30,M25)
          GO TO 160
      ENDIF
      IF (KXNEG == 0) THEN
          CALL FMLN(M32,M29)
          CALL FMMPY(M31,M29,M16)
          CALL FMSUB(M16,M32,M25)
          CALL FMSUB_R2(M25,M29)
          CALL FMEXP(M29,M21)
      ELSE
          CALL FMI2M(1,M16)
          CALL FMSUB(M31,M16,M25)
          CALL FMPWR(M32,M25,M29)
          CALL FMEXP(M32,M24)
          CALL FMDIV(M29,M24,M21)
      ENDIF

!             Here M21 is X**(A-1)/EXP(X).

      M21(-1) = -M21(-1)
      CALL FMEQ(M30,M25)
      CALL FMDIV(M31,M32,M20)
      CALL FMI2M(1,M16)
      CALL FMDIV(M16,M32,M29)
      IF (M29(1) /= MUNKNO .AND. M29(2) /= 0) M29(-1) = -M29(-1)
      NDSAV1 = NDIG

!             Disable NDIG reduction until the terms in the sum
!             begin to decrease in size.

      BIGJ = 0
      IF (KFLAGA == 0 .AND. KFLAGX == 0) BIGJ = ABS(A) - ABS(X)
      JTERMS = NTERMS
      IF (KFLAGI == 0 .AND. INTA > 0) THEN
          JTERMS = INTA
      ELSE IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
          T1 = A + ABS(X)
          IF (T1 > 0 .AND. T1 < DBLE(NTERMS)) JTERMS = INT(T1) + 2
      ENDIF

!             Method 2 summation loop.

      DO J = 1, JTERMS
         NDIG = NDSAV1
         CALL FMADD_R1(M25,M21)
         IF (KFLAG /= 0 .AND. J > 1) GO TO 140
         CALL FMADD_R1(M20,M29)
         IF (REAL(J) >= BIGJ) THEN
             NDIG2 = MAX(2,NDSAV1-INT(M25(1)-M21(1)))
             NDIG = MIN(NDSAV1,NDIG2)
         ENDIF
         CALL FMMPY_R1(M21,M20)
      ENDDO

  140 NDIG = NDSAV1
      GO TO 160

!             Method 3.  Use the continued fraction expansion.

!             M29 is the current approximation.
!             M25 is the previous approximation.
!             M21, M22 are the latest numerators.
!             M23, M24 are the latest denominators.

  150 CALL FMGAM(M31,M30)
      NDSAV1 = NDIG
      IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
          NT = INT(((A-1)*LOG(ABS(X)+1.0D-10) - X)/DLOGMB)
          LESS = MAX(0,INT(M30(1)) - NT - 1)
          IF (LESS > NDIG) THEN
              CALL FMEQ(M30,M25)
              GO TO 160
          ENDIF
          NDIG = MAX(2,NDIG-LESS)
      ENDIF
      JEXTRA = INT(MAX(1.0,5.76/ALOGMB + 1.0))
      IF (NDIG+JEXTRA > NDG2MX) JEXTRA = NDG2MX - NDIG
      IF (NDIG+JEXTRA > NDSAV1) THEN
          CALL FMEQ2_R1(M31,NDSAV1,NDSAV1+JEXTRA)
          CALL FMEQ2_R1(M32,NDSAV1,NDSAV1+JEXTRA)
      ENDIF
      NDIG = NDIG + JEXTRA
      CALL FMI2M(0,M21)
      CALL FMI2M(1,M22)
      CALL FMI2M(1,M23)
      CALL FMEQ2(M32,M24,NDSAV1,NDIG)
      CALL FMI2M(0,M29)
      CALL FMEQ2(M31,M20,NDSAV1,NDIG)
      IF (M20(1) /= MUNKNO .AND. M20(2) /= 0) M20(-1) = -M20(-1)
      CALL FMI2M(1,M19)

      JCHECK = 10
      IF (INTA == 1) CALL FMDIV(M22,M32,M29)

!             Method 3 continued fraction loop.

      METHOD3:    DO J = 1, MIN(NTERMS,INTA-1)
         CALL FMADD_R1(M20,M19)
         CALL FMMPY_R2(M20,M21)
         CALL FMADD_R2(M22,M21)
         CALL FMMPY_R2(M20,M23)
         CALL FMADD_R2(M24,M23)
         CALL FMMPY(M32,M21,M18)
         CALL FMMPYI_R1(M22,J)
         CALL FMADD_R2(M18,M22)
         CALL FMMPY(M32,M23,M18)
         CALL FMMPYI_R1(M24,J)
         CALL FMADD_R2(M18,M24)

!             Normalize to make overflow or underflow less likely.

         KMID = INT((MAX(M21(1),M22(1),M23(1),M24(1)) +  &
                     MIN(M21(1),M22(1),M23(1),M24(1))) / 2)
         M21(1) = M21(1) - KMID
         M22(1) = M22(1) - KMID
         M23(1) = M23(1) - KMID
         M24(1) = M24(1) - KMID

!             Form the quotient and check for convergence.

         IF (MOD(J,JCHECK) == 0 .OR. J == INTA-1) THEN
             CALL FMEQ(M29,M25)
             CALL FMDIV(M22,M24,M29)
             DO K = NDIG-JEXTRA, 1, -1
                IF (M25(K) /= M29(K)) CYCLE METHOD3
             ENDDO
             EXIT
         ENDIF
      ENDDO METHOD3

      CALL FMEQ2_R1(M29,NDIG,NDSAV1)
      NDIG = NDSAV1
      IF (M32(-1) > 0) THEN
          CALL FMLN(M32,M16)
          CALL FMMPY(M31,M16,M06)
          CALL FMSUB(M06,M32,M16)
          CALL FMEXP(M16,M24)
      ELSE IF (KFLAGI == 0) THEN
          CALL FMEXP(M32,M25)
          CALL FMIPWR(M32,INTA,M16)
          CALL FMDIV(M16,M25,M24)
      ELSE
          CALL FMABS(M32,M16)
          CALL FMLN(M16,M17)
          CALL FMMPY(M31,M17,M06)
          CALL FMSUB(M06,M32,M16)
          CALL FMEXP(M16,M24)
          IF (MODA2 == 1) M24(-1) = -1
      ENDIF

      IF (M24(1) /= MEXPOV) THEN
          CALL FMMPY(M24,M29,M25)
      ELSE IF (M24(1)+M29(1) >= MXEXP2/2) THEN
          CALL FMEQ(M24,M25)
          IF (M29(-1) < 0 .AND. M25(1) /= MUNKNO .AND.  &
              M25(2) /= 0) M25(-1) = -M25(-1)
      ELSE
          CALL FMMPY(M24,M29,M25)
      ENDIF
      CALL FMSUB_R2(M30,M25)

!             Check for too much cancellation.

  160 IF (NCALL <= 1) THEN
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
      ELSE
          NGOAL = INT(-MXEXP2)
      ENDIF
      IF (M25(0) <= NGOAL) THEN
          IF (NUMTRY > 0) THEN
              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
              DO J = 1, NDGOAL+1
                 IF (MRETRY(J) /= M25(J)) GO TO 170
              ENDDO
              GO TO 180
          ENDIF
  170     IEXTRA = INT(REAL(NGOAL-M25(0))/ALOGM2 + 23.03/ALOGMB) + 1
          NDOLD = NDIG
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDOLD
              CALL FMST2M('UNKNOWN',M25)
              GO TO 180
          ENDIF
          CALL FMEQ2_R1(M31,NDSAVE,NDIG)
          CALL FMEQ2_R1(M32,NDSAVE,NDIG)
          NUMTRY = NUMTRY + 1
          CALL FMEQ2(M25,MRETRY,NDOLD,NDIG)
          GO TO 110
      ENDIF

  180 MACMAX = NINT(NDSAVE*ALOGM2)
      M25(0) = MIN(M25(0),MACCA,MACCB,MACMAX)
      CALL FMEXT2(M25,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMIGM1

      SUBROUTINE FMIGM2(MA,MB,MC)

!  MC = Incomplete Gamma(MA,MB)

!  Integral from MB to infinity of e**(-t) * t**(MA-1)  dt.

!  This is (upper case) Gamma(a,x).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
      DOUBLE PRECISION FMDPLG,X,A,B,SMALL,BIG,TOL,T1,T2,BIGJ,C1,C2
      REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MAS,MAXM09,MBS,MODA2,MXSAVE
      INTEGER IEXTRA,INTA,INTG,J,JCHECK,JEXTRA,JTERMS,K,KABIGR,KASAVE,  &
              KFLAGA,KFLAGI,KFLAGX,KFLGOK,KMETH4,KMID,KOVUN,KRESLT,     &
              KWRNSV,KXNEG,N,NDGOAL,NDIG2,NDOLD,NDSAV1,NDSAVE,NGOAL,    &
              NMETHD,NMNNDG,NMXDIF,NTERMS,NUMTRY
      LOGICAL FMCOMP

      CALL FMENT2('FMIGM2',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN

      KACCSW = 1
      MAS = MA(-1)
      MBS = MB(-1)
      MACCA = MA(0)
      MACCB = MB(0)
      CALL FMEQ2(MA,M31,NDSAVE,NDIG)
      M31(0) = NINT(NDIG*ALOGM2)
      CALL FMEQ2(MB,M32,NDSAVE,NDIG)
      M32(0) = NINT(NDIG*ALOGM2)
      KMETH4 = 0
      NUMTRY = 0

  110 NTERMS = INT(INTMAX/10)

!             A,X are double precision approximations to the two
!                 arguments to this function.
!             INTA = A if A is a small integer.  It is used to limit
!                  the number of terms used in the asymptotic series
!                  and in the continued fraction expansion.

      INTA = NTERMS
      KWRNSV = KWARN
      KWARN = 0
      CALL FMM2I(M31,INTG)
      KFLAGI = KFLAG
      IF (KFLAG == 0) INTA = INTG
      CALL FMM2DP(M31,A)
      KFLAGA = KFLAG
      IF (KFLAG /= 0 .AND. M31(1) < 0) THEN
          A = 1.0D0/DPMAX
          IF (M31(-1) < 0) A = -A
          KFLAGA = 0
      ENDIF
      CALL FMM2DP(M32,X)
      KFLAGX = KFLAG
      IF (KFLAG /= 0 .AND. M32(1) < 0) THEN
          X = 1.0D0/DPMAX
          IF (M32(-1) < 0) X = -X
          KFLAGX = 0
      ENDIF
      KWARN = KWRNSV

!             If A or X is large in magnitude use more guard digits.

      IEXTRA = MIN(MAX(INT(M31(1)),INT(M32(1)),0) ,  &
                   INT(1.0+ALOGMX/ALOGMB))
      IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
          CALL FMEQ2_R1(M31,NDIG,NDIG+IEXTRA)
          CALL FMEQ2_R1(M32,NDIG,NDIG+IEXTRA)
      ENDIF
      NDIG = NDIG + IEXTRA
      IF (NDIG > NDG2MX) THEN
          KFLAG = -9
          CALL FMWRN2
          NDIG = NDIG - IEXTRA
          CALL FMST2M('UNKNOWN',M25)
          GO TO 190
      ENDIF

!             KXNEG = 1 if X is negative and A is a positive integer.

      KXNEG = 0

!             MODA2 = MOD(A,2) when KXNEG is 1.

      MODA2 = 0

!             Check for special cases.

      IF (M31(1) == MEXPOV .OR. M32(1) == MEXPOV) THEN
          IF (M31(1) == MEXPOV .AND. M31(2) /= 0 .AND.  &
              M31(-1) > 0) THEN
              IF (M32(1) /= MEXPOV) THEN
                  CALL FMST2M('OVERFLOW',M25)
                  KFLAG = -5
                  GO TO 170
              ENDIF
          ENDIF
          IF (M32(1) == MEXPOV .AND. M32(2) /= 0 .AND.  &
              M32(-1) > 0) THEN
              CALL FMBIG(M26)
              M26(1) = MXSAVE + 1
              CALL FMLN(M26,M16)
              CALL FMDIV(M26,M16,M27)
              IF (FMCOMP(M31,'<=',M27)) THEN
                  CALL FMST2M('UNDERFLOW',M25)
                  KFLAG = -6
                  GO TO 170
              ELSE
                  CALL FMST2M('UNKNOWN',M25)
                  KFLAG = -4
                  GO TO 190
              ENDIF
          ENDIF
          IF (M32(1) == MEXPOV .AND. M32(-1) < 0 .AND.  &
              M31(-1) > 0 .AND. M31(2) /= 0) THEN
              IF (M31(1) /= MEXPOV) THEN
                  CALL FMINT(M31,M24)
                  IF (FMCOMP(M31,'==',M24)) THEN
                      CALL FMI2M(2,M21)
                      CALL FMMOD(M24,M21,M16)
                      CALL FMEQ(M16,M21)
                      IF (M21(2) /= 0) THEN
                          CALL FMST2M('OVERFLOW',M25)
                          KFLAG = -5
                          GO TO 170
                      ELSE
                          CALL FMST2M('-OVERFLOW',M25)
                          KFLAG = -5
                          GO TO 170
                      ENDIF
                  ENDIF
              ENDIF
          ENDIF
          IF (M31(1) == MEXPOV .AND. M31(-1) < 0 .AND.  &
              M31(2) /= 0) THEN
              IF (M32(1) /= MEXPOV .AND. M32(-1) > 0 .AND.  &
                  M32(2) /= 0) THEN
                  CALL FMI2M(1,M16)
                  IF (FMCOMP(M32,'<',M16)) THEN
                      CALL FMST2M('OVERFLOW',M25)
                      KFLAG = -5
                      GO TO 170
                  ELSE
                      CALL FMST2M('UNDERFLOW',M25)
                      KFLAG = -6
                      GO TO 170
                  ENDIF
              ENDIF
          ENDIF
          CALL FMST2M('UNKNOWN',M25)
          KFLAG = -4
          GO TO 190
      ENDIF

      IF (M31(1) == MEXPUN .OR. M32(1) == MEXPUN) THEN
          IF (M31(1) == MEXPUN .AND. M32(1) == MEXPUN) THEN
              CALL FMST2M('UNKNOWN',M25)
              KFLAG = -4
              GO TO 190
          ENDIF
          IF (M32(1) == MEXPUN .AND. M32(-1) > 0 .AND.  &
              M32(2) /= 0) THEN
              IF (M31(1) >= 1) THEN
                  CALL FMGAM(M31,M30)
                  CALL FMEQ(M30,M25)
                  GO TO 170
              ELSE
                  CALL FMST2M('UNKNOWN',M25)
                  KFLAG = -4
                  GO TO 190
              ENDIF
          ENDIF
      ENDIF

      IF (M32(2) == 0) THEN
          IF (M31(-1) < 0 .OR. M31(2) == 0) THEN
              CALL FMST2M('UNKNOWN',M25)
              KFLAG = -4
              GO TO 190
          ELSE
              CALL FMGAM(M31,M30)
              CALL FMEQ(M30,M25)
              GO TO 170
          ENDIF
      ENDIF
      IF (M32(-1) < 0) THEN
          CALL FMINT(M31,M24)
          IF (FMCOMP(M31,'==',M24) .AND. M31(-1)*M31(2) > 0) THEN
              KXNEG = 1
              CALL FMI2M(2,M21)
              CALL FMMOD(M24,M21,M16)
              CALL FMEQ(M16,M21)
              IF (M21(2) /= 0) MODA2 = 1
          ELSE
              CALL FMST2M('UNKNOWN',M25)
              KFLAG = -4
              GO TO 190
          ENDIF
      ENDIF
      IF (M32(1) == MEXPUN) THEN
          CALL FMGAM(M31,M30)
          CALL FMEQ(M30,M25)
          GO TO 170
      ENDIF
      IF (M31(1) == MEXPUN) THEN
          CALL FMI2M(0,M31)
          MAS = 1
      ENDIF
      CALL FMMAX(M31,M32,M16)
      CALL FMMIN(M31,M32,M17)
      CALL FMDPM(1.0D6,M05)
      CALL FMDPM(1.0D2,M06)
      IF (FMCOMP(M16,'>=',M05) .AND. FMCOMP(M17,'>=',M06)) THEN
          CALL FMI2M(1,M16)
          CALL FMSUB(M31,M16,M18)
          CALL FMMAX(M18,M32,M20)
          CALL FMADDI(M20,1)
          CALL FMLN(M20,M16)
          CALL FMMPY(M18,M16,M06)
          CALL FMSUB(M06,M20,M16)
          CALL FMEXP(M16,M22)
          IF ((M22(1) == MEXPOV .AND. M22(-1) > 0 .AND.  &
              M22(2) /= 0) .OR. M22(1) > MXSAVE+1) THEN
              CALL FMST2M('OVERFLOW',M25)
              KFLAG = -5
              GO TO 170
          ENDIF
      ENDIF
!             Determine which method to use.

!             NMETHD = 1 means use the convergent series,
!                    = 2 means use the asymptotic series,
!                    = 3 means use the continued fraction expansion,
!                    = 4 means use an O(A**2) formula.

      CALL FMI2M(-10000,M20)
      CALL FMI2M(10000,M21)
      CALL FMABS(M31,M23)
      CALL FMABS(M32,M24)
      CALL FMSUB(M24,M23,M22)
      KABIGR = 1
      IF (M22(2) >= 0 .AND. M22(-1) > 0) KABIGR = 0
      NMETHD = 0
      IF (FMCOMP(M22,'<=',M20)) THEN
          IF (M31(-1) > 0 .AND. M31(2) /= 0) THEN
              NMETHD = 1
          ELSE
              NMETHD = 3
          ENDIF
      ELSE IF (FMCOMP(M22,'>=',M21) .AND. M31(-1) > 0 .AND.     &
               M31(2) > 0 .AND. M32(-1) > 0 .AND.  &
               M32(2) > 0) THEN
          NMETHD = 2
      ELSE IF (FMCOMP(M22,'>=',M21)) THEN
          NMETHD = 3
      ELSE IF (M31(-1) > 0 .AND. M32(-1) > 0 .AND.  &
               M32(2) > 0) THEN
          CALL FMDP2M(SQRT(DPMAX),M20)
          IF (FMCOMP(M32,'>=',M20)) THEN
              KFLAG = -5
              CALL FMST2M('OVERFLOW',M25)
              GO TO 170
          ENDIF

          IF (M31(-1) > 0 .AND. M31(2) /= 0) THEN
              C2 = DBLE(NDSAVE)*DLOGMB/6.0D0
              C1 = MAX( 10.0D0 , C2 , A )
              C2 = MAX( 10.0D0 , C2 , A - 6.5D0*A/(SQRT(A)+1.0D0) )
          ELSE
              C1 = MAX( 15.0D0 , DBLE(NDSAVE)*DLOGMB/5.0D0 )
              C2 = C1
          ENDIF
          IF (X < MIN(C1,C2)) THEN
              IF (-2*M31(1) > NDIG .OR. M31(2) == 0) THEN
                  NMETHD = 4
              ELSE
                  NMETHD = 1
              ENDIF
          ELSE IF (X > C2) THEN

!             Check that the smallest term in the asymptotic series is
!             small enough to give the required accuracy.

              T1 = FMDPLG(A)
              SMALL = T1 - FMDPLG(-ABS(X)) - (A+ABS(X))*LOG(ABS(X))
              TOL = -DBLE(NDIG+2)*DLOGMB - 12.0D0
              B = 1.0D0
              IF (A > ABS(X)) B = A - ABS(X)
              BIG = T1 - FMDPLG(A-B) - B*LOG(ABS(X))
              IF (SMALL < TOL+BIG) NMETHD = 2
          ENDIF
          IF (NMETHD == 0 .AND. X > C1) NMETHD = 3
          IF (NMETHD == 0) NMETHD = 1
      ELSE IF (M31(-1) < 0 .AND. M32(-1) > 0 .AND.  &
          M32(2) > 0) THEN
          CALL FMDP2M(SQRT(DPMAX),M20)
          IF (FMCOMP(M32,'>=',M20)) THEN
              KFLAG = -6
              CALL FMST2M('UNDERFLOW',M25)
              GO TO 170
          ENDIF

          C1 = MAX( 10.0D0 , DBLE(NDSAVE)*DLOGMB/7.0D0 )
          C2 = -2.0D0*A
          IF (X < C1) THEN
              IF (-2*M31(1) > NDIG) THEN
                  NMETHD = 4
              ELSE
                  NMETHD = 1
              ENDIF
          ELSE IF (X > C2) THEN
              T1 = FMDPLG(A)
              SMALL = T1 - FMDPLG(-ABS(X)) - (A+ABS(X))*LOG(ABS(X))
              TOL = -DBLE(NDIG+2)*DLOGMB - 12.0D0
              B = 1.0D0
              IF (A > ABS(X)) B = A - ABS(X)
              BIG = T1 - FMDPLG(A-B) - B*LOG(ABS(X))
              IF (SMALL < TOL+BIG) NMETHD = 2
          ENDIF
          IF (NMETHD == 0 .AND. X > C1) NMETHD = 3
          IF (NMETHD == 0) NMETHD = 1
      ELSE IF (M31(-1) > 0 .AND. M31(2) > 0 .AND.  &
          M32(-1) < 0) THEN
          CALL FMEQ(M32,M20)
          IF (M20(1) /= MUNKNO .AND. M20(2) /= 0) M20(-1) = -M20(-1)
          CALL FMMPYI(M31,2,M21)
          IF (FMCOMP(M20,'<',M31)) THEN
              NMETHD = 1
          ELSE IF (FMCOMP(M20,'<',M21)) THEN
              NMETHD = 3
          ELSE
              NMETHD = 2
          ENDIF
      ENDIF

      IF (NMETHD == 2) GO TO 130
      IF (NMETHD == 3) GO TO 150
      IF (NMETHD == 4) GO TO 160

!             Method 1.  Use the X**N/Pochhammer(A+1,N) series.

!             M25 is the current sum.
!             M21 is the current term.
!             M20 is (A+N)/X.
!             M29 is 1/X

!             Raise the precision if A is negative and near an integer,
!             to compensate for cancellation when (A+N)/X is near zero.
!             Raise the precision if A is positive and near zero, since
!             there will be cancellation in subtracting the sum from
!             Gamma(A).
!             If A is a negative integer use method 3 or 4.

      IEXTRA = 0
      IF (M31(-1) < 0) THEN
          IF (KFLAGA == 0) THEN
              IF (ABS(A) > 1.0D3) THEN
                  NMETHD = 3
                  GO TO 150
              ENDIF
          ELSE
              NMETHD = 3
              GO TO 150
          ENDIF
          CALL FMNINT(M31,M25)
          IF (FMCOMP(M25,'==',M31)) THEN
              IF (KFLAGI == 0) THEN
                  IF (KFLAGX /= 0) THEN
                      GO TO 150
                  ELSE
                      IF (ABS(X) <= 20.0D0) THEN
                          C1 = 0.7D0*(DBLE(NDSAVE)*DLOGMB*  &
                                      (20.0D0-X))**0.75D0
                          IF (ABS(A) > C1) THEN
                              GO TO 150
                          ELSE
                              GO TO 160
                          ENDIF
                      ELSE
                          GO TO 150
                      ENDIF
                  ENDIF
              ELSE
                  GO TO 150
              ENDIF
          ENDIF
          CALL FMSUB(M31,M25,M29)
          IEXTRA = MAX(-2*INT(M29(1)),-INT(M31(1))+1,0)
      ELSE
          IEXTRA = MAX(-INT(M31(1))+1,0)
      ENDIF

!             Raise the precision further as X increases in magnitude.

      IF (KFLAGX == 0 .AND. KFLAGA == 0) THEN
          T1 = (0.92D0 + (X-A) + (A-0.5D0)*LOG(ABS(A)+1.0D-10) -  &
               (A-1.0D0)*LOG(ABS(X)+1.0D-10))/DLOGMB
          IF (T1 > 0 .AND. ABS(X) > 1.0D0) THEN
              IF (A < 0.0D0 .OR. X >= A) THEN
                  IEXTRA = IEXTRA + MAX(0,INT(T1)+1)
              ENDIF
          ENDIF
      ENDIF

      IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
          CALL FMEQ2_R1(M31,NDIG,NDIG+IEXTRA)
          CALL FMEQ2_R1(M32,NDIG,NDIG+IEXTRA)
      ENDIF
      NDIG = NDIG + IEXTRA
      IF (NDIG > NDG2MX) THEN
          KFLAG = -9
          CALL FMWRN2
          NDIG = NDIG - IEXTRA
          CALL FMST2M('UNKNOWN',M25)
          GO TO 190
      ENDIF

      JEXTRA = 0

  120 IF (KABIGR == 1) THEN
          CALL FMGAM(M31,M30)
          IF (KFLAG /= 0) THEN
              CALL FMEQ(M30,M25)
              GO TO 170
          ENDIF
          CALL FMEQ(M30,M25)
      ELSE
          CALL FMI2M(0,M25)
      ENDIF

      MAXM09 = M25(1)

      CALL FMABS(M32,M29)
      CALL FMLN(M29,M13)
      CALL FMEQ(M13,M29)
      CALL FMMPY_R2(M31,M29)
      CALL FMSUB_R1(M29,M32)
      CALL FMEXP(M29,M30)
      CALL FMDIV(M30,M31,M21)
      IF (M21(1) == MUNKNO) THEN
          CALL FMLN(M31,M24)
          CALL FMSUB_R1(M29,M24)
          CALL FMEXP(M29,M21)
      ENDIF
      IF (KXNEG == 1 .AND. MODA2 == 1 .AND. M21(1) /= MUNKNO .AND.  &
          M21(2) /= 0) THEN
          M21(-1) = -M21(-1)
      ENDIF

      IF (M21(1) /= MUNKNO .AND. M21(2) /= 0) THEN
          M21(-1) = -M21(-1)
      ENDIF
      CALL FMADD_R1(M25,M21)
      MAXM09 = MAX(MAXM09,M25(1))

      CALL FMI2M(1,M18)
      CALL FMADD(M31,M18,M20)
      CALL FMDIV_R1(M21,M20)
      CALL FMMPY_R1(M21,M32)
      CALL FMDIV_R1(M20,M32)
      CALL FMDIV(M18,M32,M29)
      NDSAV1 = NDIG

!             If A is negative and ABS(A) > ABS(X), the terms in the
!             series first decrease, then increase, then decrease.
!             Try to predict the number of extra digits required to
!             keep the precision from prematurely becoming too small.

      KFLGOK = 1
      IF (M31(-1) < 0) THEN
          KFLGOK = 0
          M31(-1) = 1
          M32(-1) = 1
          IF (FMCOMP(M31,'>',M32)) THEN
              IF (JEXTRA == 0) THEN
                  IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
                      T1 = FMDPLG(A+AINT(-ABS(X)-A)) -  &
                           FMDPLG(A+1.0D0+AINT(ABS(X)-A))
                      T1 = (T1 + 2.0D0*ABS(X)*LOG(ABS(X)+1.0D-10))/  &
                            DLOGMB
                      T1 = MAX(0.0D0,T1+1.0D0)
                      JEXTRA = INT(MIN(DBLE(NDIGMX),T1))
                  ENDIF
              ENDIF

!             If A is negative and ABS(A) is much bigger than ABS(X),
!             then the later increase in the size of the terms can be
!             ignored.

              IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
                  T1 = (AINT(X-A)*LOG(ABS(X)+1.0D-10) + FMDPLG(A+1.0D0)  &
                       - FMDPLG(A+1.0D0+AINT(X-A))) / DLOGMB
                  IF (T1 < -DBLE(NDIG)) KFLGOK = 1
              ELSE
                  KFLGOK = 1
              ENDIF
          ENDIF
          M31(-1) = MAS
          M32(-1) = MBS
      ENDIF

      NMNNDG = NDSAV1
      NMXDIF = 0

!             Method 1 summation loop.

      DO J = 1, NTERMS
         NDIG = NDSAV1
         CALL FMADD_R1(M25,M21)
         MAXM09 = MAX(MAXM09,M25(1))
         IF (KFLAG /= 0) THEN
             IF (KFLGOK == 0 .AND. KFLAGA == 0 .AND. KFLAGX == 0) THEN
                 IF (DBLE(J) > X-A) EXIT
             ELSE
                 EXIT
             ENDIF
         ENDIF

         CALL FMADD_R1(M20,M29)

         NDIG2 = MAX(2,NDSAV1-INT(M25(1)-M21(1)))
         NDIG = MIN(NDSAV1,NDIG2+JEXTRA)
         NMNNDG = MIN(NMNNDG,NDIG)
         NMXDIF = MAX(NMXDIF,NDIG-NMNNDG)
         CALL FMDIV_R1(M21,M20)
      ENDDO

      NDIG = NDSAV1
      IF (KABIGR == 0) THEN
          CALL FMEQ(M25,M29)
          CALL FMGAM(M31,M30)
          IF (KFLAG /= 0) THEN
              CALL FMEQ(M30,M25)
              GO TO 170
          ENDIF
          CALL FMADD(M30,M29,M25)
      ENDIF

!             If too much cancellation occurred, raise the precision
!             and do the calculation again.

      IEXTRA = NDIG - NDSAVE
      IF (INT(MAXM09-M25(1)) >= IEXTRA-NGRD52/2) THEN
          IEXTRA = IEXTRA + NGRD52
          IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
              CALL FMEQ2_R1(M31,NDIG,NDIG+IEXTRA)
              CALL FMEQ2_R1(M32,NDIG,NDIG+IEXTRA)
          ENDIF
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDIG - IEXTRA
              CALL FMST2M('UNKNOWN',M25)
              GO TO 190
          ENDIF
          GO TO 120
      ENDIF

      GO TO 170

!             Method 2.  Use the Pochhammer(A-N,N)/X**N series.

!             M25 is the current sum.
!             M21 is the current term.
!             M20 is (A-N)/X.
!             M29 is -1/X

  130 CALL FMABS(M32,M29)
      CALL FMLN(M29,M13)
      CALL FMEQ(M13,M29)
      CALL FMMPY(M31,M29,M25)
      CALL FMSUB_R2(M25,M29)
      CALL FMSUB_R1(M29,M32)
      CALL FMEXP(M29,M21)
      IF (KXNEG == 1 .AND. MODA2 == 0 .AND. M21(1) /= MUNKNO .AND.  &
          M21(2) /= 0) M21(-1) = -M21(-1)
      IF (ABS(M21(1)) >= MXEXP2) THEN
          CALL FMEQ(M21,M25)
          GO TO 170
      ENDIF

!             Here M21 is X**(A-1)/EXP(X).

      CALL FMI2M(0,M25)
      CALL FMEQ(M31,M20)
      CALL FMDIV_R1(M20,M32)
      CALL FMI2M(1,M18)
      CALL FMDIV(M18,M32,M29)
      IF (M29(1) /= MUNKNO .AND. M29(2) /= 0) M29(-1) = -M29(-1)
      NDSAV1 = NDIG

!             Disable NDIG reduction until the terms in the sum
!             begin to decrease in size.

      BIGJ = 0
      IF (KFLAGA == 0 .AND. KFLAGX == 0) BIGJ = ABS(A) - ABS(X)
      JTERMS = NTERMS
      IF (KFLAGI == 0 .AND. INTA > 0) THEN
          JTERMS = INTA
      ELSE IF (KFLAGX == 0) THEN
          IF (KFLAGA == 0) THEN
              T1 = A + ABS(X)
              IF (T1 > 0 .AND. T1 < DBLE(NTERMS)) JTERMS = INT(T1) + 2
          ELSE IF (M31(1) < 0) THEN
              T1 = ABS(X)
              IF (T1 > 0 .AND. T1 < DBLE(NTERMS)) JTERMS = INT(T1) + 2
          ENDIF
      ENDIF

!             Method 2 summation loop.

      DO J = 1, JTERMS
         NDIG = NDSAV1
         CALL FMADD_R1(M25,M21)
         IF (KFLAG /= 0 .AND. J > 1) GO TO 140
         CALL FMADD_R1(M20,M29)
         IF (REAL(J) >= BIGJ) THEN
             NDIG2 = MAX(2,NDSAV1-INT(M25(1)-M21(1)))
             NDIG = MIN(NDSAV1,NDIG2)
         ENDIF
         CALL FMMPY_R1(M21,M20)
      ENDDO

  140 NDIG = NDSAV1
      GO TO 170

!             Method 3.  Use the continued fraction expansion.

!             M29 is the current approximation.
!             M25 is the previous approximation.
!             M21, M22 are the latest numerators.
!             M23, M24 are the latest denominators.

!             Raise the precision so that convergence of the
!             continued fraction expansion is easier to detect.

  150 JEXTRA = INT(MAX(1.0,5.76/ALOGMB + 1.0))

!             Raise the precision further for small X if A is positive.

      IF (KFLAGX == 0 .AND. KFLAGA == 0) THEN
          T1 = (0.92D0 + (ABS(X)-A) + (A-0.5D0)*LOG(ABS(A)+1.0D-10) -  &
               (A-1.0D0)*LOG(ABS(X)+1.0D-10))/DLOGMB
          IF (T1 > 0.0D0 .AND. A > 0.0D0) THEN
              IF (ABS(X) < A) THEN
                  JEXTRA = JEXTRA + MAX(0,INT(1.5D0*T1)+1)
                  IF (NDIG+JEXTRA > NDG2MX) THEN
                      NDIG = NDIG + JEXTRA
                      KFLAG = -9
                      CALL FMWRN2
                      NDIG = NDIG - JEXTRA
                      CALL FMST2M('UNKNOWN',M25)
                      GO TO 190
                  ENDIF
              ENDIF
          ENDIF
      ENDIF
      NDSAV1 = NDIG
      IF (NDIG+JEXTRA > NDG2MX) JEXTRA = NDG2MX - NDIG
      IF (NDIG+JEXTRA > NDSAV1) THEN
          CALL FMEQ2_R1(M31,NDSAV1,NDSAV1+JEXTRA)
          CALL FMEQ2_R1(M32,NDSAV1,NDSAV1+JEXTRA)
      ENDIF
      NDIG = NDIG + JEXTRA
      CALL FMI2M(0,M21)
      CALL FMI2M(1,M22)
      CALL FMI2M(1,M23)
      CALL FMEQ2(M32,M24,NDSAV1,NDIG)
      CALL FMI2M(0,M29)
      CALL FMEQ2(M31,M20,NDSAV1,NDIG)
      IF (M20(1) /= MUNKNO .AND. M20(2) /= 0) M20(-1) = -M20(-1)
      CALL FMI2M(1,M19)

      JTERMS = NTERMS
      JCHECK = 10
      IF (INTA == 1) CALL FMDIV(M22,M32,M29)
      IF (INTA > 0) JTERMS = INTA - 1

!             Method 3 continued fraction loop.

      METHOD3:    DO J = 1, JTERMS
         CALL FMADD_R1(M20,M19)
         CALL FMMPY_R2(M20,M21)
         CALL FMADD_R2(M22,M21)
         CALL FMMPY_R2(M20,M23)
         CALL FMADD_R2(M24,M23)
         CALL FMMPYI_R1(M22,J)
         CALL FMMPY(M32,M21,M30)
         CALL FMADD_R2(M30,M22)
         CALL FMMPYI_R1(M24,J)
         CALL FMMPY(M32,M23,M30)
         CALL FMADD_R2(M30,M24)

!             Normalize to make overflow or underflow less likely.

         KMID = INT((MAX(M21(1),M22(1),M23(1),M24(1)) +  &
                     MIN(M21(1),M22(1),M23(1),M24(1))) / 2)
         M21(1) = M21(1) - KMID
         M22(1) = M22(1) - KMID
         M23(1) = M23(1) - KMID
         M24(1) = M24(1) - KMID

!             Form the quotient and check for convergence.

         IF (MOD(J,JCHECK) == 0 .OR. J == INTA-1) THEN
             CALL FMEQ(M29,M25)
             CALL FMDIV(M22,M24,M29)
             DO K = NDIG-JEXTRA, 1, -1
                IF (M25(K) /= M29(K)) CYCLE METHOD3
             ENDDO
             EXIT
         ENDIF
      ENDDO METHOD3

      CALL FMEQ2_R1(M29,NDIG,NDSAV1)
      NDIG = NDSAV1
      CALL FMABS(M32,M24)
      CALL FMLN(M24,M13)
      CALL FMEQ(M13,M24)
      CALL FMMPY_R2(M31,M24)
      CALL FMSUB_R1(M24,M32)
      CALL FMEXP(M24,M12)
      CALL FMEQ(M12,M24)
      IF (KXNEG == 1 .AND. MODA2 == 1 .AND. M24(1) /= MUNKNO .AND.  &
          M24(2) /= 0) M24(-1) = -M24(-1)
      IF (ABS(M24(1)) >= MXEXP2) THEN
          CALL FMEQ(M24,M25)
          IF (M29(-1) < 0 .AND. M25(1) /= MUNKNO .AND.  &
              M25(2) /= 0) M25(-1) = -M25(-1)
          GO TO 170
      ENDIF

      CALL FMMPY(M24,M29,M25)
      GO TO 170

!             Method 4.  Use the O(A**2) formula when A is small.

!             M25 is the current term.
!             M29 is the current sum.

!             Raise the precision if X is larger than A
!             in magnitude.  The terms initially increase in size,
!             and the final sum is small.

  160 IEXTRA = 0

!             If A is a negative integer, replace it by zero and later
!             use a recurrence to recover the original function value.

      IF (KFLAGI == 0 .AND. INTA < 0) THEN
          CALL FMI2M(0,M31)
          A = 0.0D0
          KMETH4 = 1
      ENDIF

      IF (KFLAGX == 0) THEN
          IF (KFLAGA == 0) THEN
              T1 = ABS(X) - ABS(A)
          ELSE
              T1 = ABS(X)
          ENDIF
          IF (T1 > 0) THEN
              T2 = (T1 + LOG(T1))/DLOGMB
              IF (T2 > DBLE(MXEXP2/10)) T2 = DBLE(MXEXP2/10)
              IEXTRA = INT(MAX(0.0D0,T2))
          ENDIF
          T1 = ABS(X)+1.0D-10
          T2 = (T1 - 0.5D0*LOG(6.2831853D0*T1))/DLOGMB
          IF (T2 > DBLE(MXEXP2/10)) T2 = DBLE(MXEXP2/10)
          IEXTRA = IEXTRA + INT(MAX(0.0D0,T2))
      ENDIF

      IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
          CALL FMEQ2_R1(M31,NDIG,NDIG+IEXTRA)
          CALL FMEQ2_R1(M32,NDIG,NDIG+IEXTRA)
      ENDIF
      NDIG = NDIG + IEXTRA
      IF (NDIG > NDG2MX) THEN
          KFLAG = -9
          CALL FMWRN2
          NDIG = NDIG - IEXTRA
          CALL FMST2M('UNKNOWN',M25)
          GO TO 190
      ENDIF

      CALL FMEULR(M29)
      CALL FMEQ(M29,M30)
      M29(-1) = -1
      CALL FMABS(M32,M25)
      CALL FMLN(M25,M24)
      CALL FMSUB_R1(M29,M24)
      IF (M31(2) /= 0 .AND. M31(1) >= -NDIG-1) THEN
          CALL FMSQR(M24,M16)
          CALL FMMPY(M16,M31,M06)
          CALL FMDIVI(M06,2,M25)
          CALL FMSUB_R1(M29,M25)
          CALL FMSQR(M30,M23)
          CALL FMPI(M22)
          CALL FMSQR(M22,M16)
          CALL FMDIVI(M16,6,M22)
          CALL FMADD(M22,M23,M16)
          CALL FMMPY(M16,M31,M06)
          CALL FMDIVI(M06,2,M23)
          CALL FMADD_R1(M29,M23)
      ENDIF

      NDSAV1 = NDIG
      CALL FMI2M(1,M23)
      CALL FMADD(M31,M23,M22)
      IF (FMCOMP(M23,'==',M22)) THEN
          CALL FMI2M(-1,M25)
          DO J = 1, NTERMS
             NDIG2 = MAX(2,NDSAV1-INT(M29(1)-M25(1)))
             NDIG = MIN(NDSAV1,NDIG2)
             CALL FMMPY_R1(M25,M32)
             IF (M25(1) /= MUNKNO .AND. M25(2) /= 0) M25(-1) = -M25(-1)
             CALL FMDIVI_R1(M25,J)
             CALL FMDIVI(M25,J,M24)
             NDIG = NDSAV1
             CALL FMADD_R1(M29,M24)
             IF (KFLAG /= 0) EXIT
          ENDDO
      ELSE
          CALL FMPWR(M32,M31,M25)
          IF (M25(1) /= MUNKNO .AND. M25(2) /= 0) M25(-1) = -M25(-1)
          CALL FMEQ(M31,M30)
          DO J = 1, NTERMS
             NDIG2 = MAX(2,NDSAV1-INT(M29(1)-M25(1)))
             NDIG = MIN(NDSAV1,NDIG2)
             CALL FMMPY_R1(M25,M32)
             IF (M25(1) /= MUNKNO .AND. M25(2) /= 0) M25(-1) = -M25(-1)
             CALL FMDIVI_R1(M25,J)
             NDIG = NDSAV1
             CALL FMADD_R1(M30,M23)
             NDIG = MIN(NDSAV1,NDIG2)
             CALL FMDIV(M25,M30,M24)
             NDIG = NDSAV1
             CALL FMADD_R1(M29,M24)
             IF (KFLAG /= 0) EXIT
          ENDDO
      ENDIF
      CALL FMEQ(M29,M25)

!             Use the recurrence relation if A was a negative integer.

      IF (KFLAGI == 0 .AND. INTA < 0) THEN
          N = -INTA
          CALL FMI2M(1,M29)
          CALL FMDIV_R1(M29,M32)
          CALL FMEQ(M29,M24)
          CALL FMEQ(M29,M23)
          DO J = 1, N-1
             CALL FMMPYI_R1(M24,J)
             CALL FMMPY_R1(M24,M23)
             IF (M24(1) /= MUNKNO .AND. M24(2) /= 0) M24(-1) = -M24(-1)
             CALL FMADD_R1(M29,M24)
          ENDDO
          CALL FMEXP(M32,M23)
          CALL FMDIV_R1(M29,M23)
          CALL FMSUB_R1(M25,M29)
          CALL FMFCTI(N,M23)
          CALL FMDIV_R1(M25,M23)
          IF (MOD(N,2) == 1 .AND. M25(1) /= MUNKNO .AND.  &
              M25(2) /= 0) M25(-1) = -M25(-1)
      ENDIF

!             Check for too much cancellation.

  170 IF (NCALL <= 1) THEN
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
      ELSE
          NGOAL = INT(-MXEXP2)
      ENDIF
      IF (M25(0) <= NGOAL) THEN
          IF (NUMTRY > 0) THEN
              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
              DO J = 1, NDGOAL+1
                 IF (MRETRY(J) /= M25(J)) GO TO 180
              ENDDO
              GO TO 190
          ENDIF
  180     IEXTRA = INT(REAL(NGOAL-M25(0))/ALOGM2 + 23.03/ALOGMB) + 1
          NDOLD = NDIG
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDIG - IEXTRA
              CALL FMST2M('UNKNOWN',M25)
              GO TO 190
          ENDIF
          CALL FMEQ2_R1(M31,NDSAVE,NDIG)
          IF (KMETH4 == 1) THEN
              CALL FMI2M(INTA,M31)
          ENDIF
          CALL FMEQ2_R1(M32,NDSAVE,NDIG)
          NUMTRY = NUMTRY + 1
          CALL FMEQ2(M25,MRETRY,NDOLD,NDIG)
          GO TO 110
      ENDIF

  190 MACMAX = NINT(NDSAVE*ALOGM2)
      M25(0) = MIN(M25(0),MACCA,MACCB,MACMAX)
      CALL FMEXT2(M25,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMIGM2

      SUBROUTINE FMLNGM(MA,MB)

!  MB = LN(GAMMA(MA))

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
      INTEGER IEXTRA,INTA,J,J2,K,K0,K1,K2,KASAVE,KFL,KOVUN,KPT,KRESLT,    &
              KRSAVE,KSIGN,KWRNSV,LSHIFT,NDENOM,NDGOAL,NDIG2,NDMB,NDOLD,  &
              NDSAV1,NDSAVE,NDSV,NGOAL,NMXDIF,NTERM,NUMTRY
      LOGICAL FMCOMP
      CHARACTER(155) :: STRING

      CALL FMENT2('FMLNGM',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      MAS = MA(-1)
      KACCSW = 1
      MACCA = MA(0)
      CALL FMEQ2(MA,M25,NDSAVE,NDIG)
      M25(0) = NINT(NDIG*ALOGM2)
      CALL FMEQ(M25,M26)
      NUMTRY = 0

!             Near zero Gamma(x) is about 1/x.

  110 IF (M26(1) < (-NDIG-3)) THEN
          CALL FMLN(M26,M22)
          IF (M22(1) /= MUNKNO .AND. M22(2) /= 0) M22(-1) = -M22(-1)
          GO TO 140
      ENDIF

!             Check for special cases.

      IF (MAS < 0) THEN
          KFL = 0
          IF (M25(1) <= NDSAVE) THEN
              CALL FMINT(M26,M21)
              IF (FMCOMP(M26,'==',M21)) KFL = -4
              CALL FMI2M(2,M22)
              M21(-1) = 1
              CALL FMMOD(M21,M22,M16)
              CALL FMEQ(M16,M22)
              IF (M22(2) == 0) KFL = -4
          ELSE
              KFL = -4
          ENDIF
          IF (KFL /= 0) THEN
              CALL FMST2M('UNKNOWN',M22)
              KFLAG = -4
              GO TO 160
          ELSE
              CALL FMI2M(1,M16)
              CALL FMSUB_R2(M16,M26)
          ENDIF
      ENDIF

!             To speed the asymptotic series calculation, increase
!             the argument by LSHIFT.

      IEXTRA = 0
      KWRNSV = KWARN
      KWARN = 0
      CALL FMM2I(M26,INTA)
      KWARN = KWRNSV

      IF (KFLAG == -4) THEN
          LSHIFT = 0
      ELSE
          LSHIFT = INT(MAX(0.0,REAL(NDIG)*ALOGMB/4.46-REAL(INTA)))
      ENDIF
      IF (LSHIFT > 0) LSHIFT = 4*(LSHIFT/4 + 1)
      IF (KFLAG == 0) THEN
          IF (LSHIFT > 0 .OR. INTA <= 10) THEN
              IF (INTA <= 2) THEN
                  CALL FMI2M(0,M22)
                  GO TO 140
              ENDIF
              INTA = INTA - 1
              CALL FMFCTI(INTA,M26)
              CALL FMLN(M26,M22)
              GO TO 140
          ENDIF
      ENDIF

      IF (LSHIFT /= 0) THEN
          CALL FMI2M(LSHIFT,M16)
          CALL FMADD(M26,M16,M24)
      ELSE
          CALL FMEQ(M26,M24)
      ENDIF

!             Sum the asymptotic series.

!       M26 is Z
!       M24 is Z + LSHIFT
!       M21 is X**J2 = (1/(Z+LSHIFT)**2)**J2
!       M22 is the current power of X
!       M23 is the current term in the sum
!       MJSUMS is the partial sum

      J2 = INT(0.3*ALOGMB + 0.2*SQRT(REAL(NDIG)))
      J2 = MAX(1,MIN(LJSUMS/(LUNPCK+3),J2))
      NDSAV1 = NDIG
      CALL FMI2M(1,M22)
      J = -2*J2
      CALL FMIPWR(M24,J,M21)
      IF (ABS(M21(1)) >= MEXPAB) THEN
          J2 = 1
          CALL FMIPWR(M24,-2,M21)
      ENDIF
      DO J = 1, J2
         NTERM = 2*J
         CALL FMBERN(NTERM,M22,M23)
         IF (KFLAG == -11) THEN
             CALL FMST2M('UNKNOWN',M22)
             KFLAG = -4
             GO TO 160
         ENDIF
         NDENOM = NTERM*(NTERM-1)
         KPT = (J-1)*(NDSAV1+3)
         CALL FMDIVI(M23,NDENOM,MJSUMS(KPT-1))
      ENDDO

      NDIG2 = NDIG
  120 CALL FMMPY_R1(M22,M21)
      NMXDIF = 2
      DO J = 1, J2
         NTERM = NTERM + 2
         CALL FMBERN(NTERM,M22,M23)
         IF (KFLAG == -11) THEN
             CALL FMST2M('UNKNOWN',M22)
             KFLAG = -4
             GO TO 160
         ENDIF
         NDENOM = NTERM*(NTERM-1)
         IF (NDENOM <= MXBASE) THEN
             CALL FMDIVI_R1(M23,NDENOM)
         ELSE
             CALL FMDIVI_R1(M23,NTERM)
             NDENOM = NTERM - 1
             CALL FMDIVI_R1(M23,NDENOM)
         ENDIF
         NDIG = NDSAV1
         KPT = (J-1)*(NDSAV1+3)
         CALL FMADD_R1(MJSUMS(KPT-1),M23)
         NMXDIF = MAX(NMXDIF,NDSAV1-INT(MJSUMS(KPT+1)-M23(1)))
         NDIG = NDIG2
         IF (KFLAG /= 0) GO TO 130
      ENDDO
      NDIG2 = NMXDIF
      NDIG = NDIG2
      GO TO 120

!             Put the J2 concurrent sums back together.

  130 NDIG = NDSAV1
      IF (J2 > 1) THEN
          KPT = (J2-1)*(NDSAV1+3)
          CALL FMSQR(M24,M23)
          CALL FMI2M(1,M16)
          CALL FMDIV_R2(M16,M23)
          CALL FMEQ(MJSUMS(KPT-1),M21)
          DO J = J2-1, 1, -1
             CALL FMMPY_R1(M21,M23)
             KPT = (J-1)*(NDSAV1+3)
             CALL FMADD_R1(M21,MJSUMS(KPT-1))
          ENDDO
          CALL FMEQ(M21,MJSUMS)
      ENDIF

!             Add the log terms to the asymptotic series.

!       M22 is the current sum as the log terms are added
!       M23 is now LN(Z+LSHIFT)

      CALL FMDIV(MJSUMS,M24,M22)
      CALL FMLN(M24,M23)
      IF (MBASE /= MBS2PI .OR. NDIG > NDG2PI) THEN
          NDMB = INT(150.0*2.302585/ALOGMB)
          IF (NDMB >= NDIG) THEN
              NDSV = NDIG
              NDIG = MIN(NDMB,NDG2MX)
              STRING = '1.837877066409345483560659472811235279722794'//  &
              '94727556682563430308096553139185452079538948659727190'//  &
              '8395244011293249268674892733725763681587144311751830445'
              CALL FMST2M(STRING,M_LN_2PI)
              M_LN_2PI(0) = NINT(NDIG*ALOGM2)
              MBS2PI = MBASE
              NDG2PI = NDIG
              IF (ABS(M_LN_2PI(1)) > 10) NDG2PI = 0
              NDIG = NDSV
          ELSE
              NDSV = NDIG
              NDIG = MIN(NDIG+2,NDG2MX)
              CALL FMPI(M21)
              CALL FMMPYI(M21,2,M16)
              CALL FMLN(M16,M_LN_2PI)
              MBS2PI = MBASE
              NDG2PI = NDIG
              IF (ABS(M_LN_2PI(1)) > 10) NDG2PI = 0
              NDIG = NDSV
          ENDIF
      ENDIF
      CALL FMSUB(M_LN_2PI,M23,M16)
      CALL FMDIVI(M16,2,M21)
      CALL FMADD_R1(M22,M21)
      CALL FMSUB_R1(M22,M24)
      CALL FMMPY(M23,M24,M21)
      CALL FMADD_R1(M22,M21)

!             Now the log of gamma of the shifted argument has been
!             computed.  Reverse the shifting.
!             The product MA*(MA+1)*...*(MA+LSHIFT-1) is computed
!             four terms at a time to reduce the number of FMMPY calls.

!             M26 is Z
!             M17 is Z**2
!             M18 is Z**3
!             M19 is (Z+K)*...*(Z+K+3)
!             M23 is the current product

      IF (LSHIFT > 0) THEN
          CALL FMSQR(M26,M17)
          CALL FMMPY(M26,M17,M18)
          CALL FMSQR(M17,M19)
          CALL FMMPYI(M18,6,M24)
          CALL FMADD_R1(M19,M24)
          CALL FMMPYI(M17,11,M24)
          CALL FMADD_R1(M19,M24)
          CALL FMMPYI(M26,6,M24)
          CALL FMADD_R1(M19,M24)
          CALL FMEQ(M19,M23)
          CALL FMMPYI_R1(M18,16)
          DO K = 0, LSHIFT-8, 4
             CALL FMADD_R1(M19,M18)
             K2 = 24*(2*K + 7)
             CALL FMMPYI(M17,K2,M24)
             CALL FMADD_R1(M19,M24)
             IF (K <= SQRT(REAL(INTMAX)/49.0)) THEN
                 K1 = 8*(6*K*K + 42*K + 79)
                 CALL FMMPYI(M26,K1,M24)
                 CALL FMADD_R1(M19,M24)
             ELSE
                 K1 = 48*K
                 CALL FMMPYI(M26,K1,M24)
                 CALL FMMPYI_R1(M24,K)
                 CALL FMADD_R1(M19,M24)
                 K1 = 336*K + 632
                 CALL FMMPYI(M26,K1,M24)
                 CALL FMADD_R1(M19,M24)
             ENDIF
             IF (K <= (REAL(INTMAX)/17.0)**0.3333) THEN
                 K0 = 8*(2*K + 7)*(K*K + 7*K + 15)
                 CALL FMADDI(M19,K0)
             ELSE IF (K <= SQRT(REAL(INTMAX)*0.9)) THEN
                 K0 = 8*(2*K + 7)
                 CALL FMI2M(K0,M24)
                 K0 = K*K + 7*K + 15
                 CALL FMMPYI_R1(M24,K0)
                 CALL FMADD_R1(M19,M24)
             ELSE
                 K0 = 8*(2*K + 7)
                 CALL FMI2M(K0,M24)
                 CALL FMMPYI(M24,K,M21)
                 CALL FMMPYI_R1(M21,K)
                 CALL FMADD_R1(M19,M21)
                 K0 = 7*K + 15
                 CALL FMMPYI_R1(M24,K0)
                 CALL FMADD_R1(M19,M24)
             ENDIF
             CALL FMMPY_R1(M23,M19)
          ENDDO
          CALL FMLN(M23,M13)
          CALL FMEQ(M13,M23)
          CALL FMSUB_R1(M22,M23)
      ENDIF

!             Use the reflection formula if MA was negative.

      IF (MAS < 0) THEN

!             Reduce the argument before multiplying by Pi.

          CALL FMNINT(M26,M17)
          CALL FMDIVI(M17,2,M18)
          CALL FMINT(M18,M08)
          CALL FMEQ(M08,M18)
          CALL FMMPYI(M18,2,M19)
          KSIGN = -1
          IF (FMCOMP(M17,'==',M19)) KSIGN = 1
          CALL FMSUB(M26,M17,M21)
          M21(0) = M26(0)
          CALL FMPI(M23)
          CALL FMMPY_R1(M23,M21)
          KRSAVE = KRAD
          KRAD = 1
          CALL FMSIN(M23,M12)
          CALL FMEQ(M12,M23)
          M23(-1) = KSIGN*M23(-1)
          KRAD = KRSAVE
          CALL FMDIV_R2(MPISAV,M23)
          CALL FMLN(M23,M13)
          CALL FMEQ(M13,M23)
          CALL FMSUB_R2(M23,M22)
      ENDIF

!             Check for too much cancellation.

  140 IF (NCALL <= 1) THEN
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
      ELSE
          NGOAL = INT(-MXEXP2)
      ENDIF
      IF (M22(0) <= NGOAL) THEN
          IF (NUMTRY > 0) THEN
              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
              DO J = 1, NDGOAL+1
                 IF (MRETRY(J) /= M22(J)) GO TO 150
              ENDDO
              GO TO 160
          ENDIF
  150     IEXTRA = INT(REAL(NGOAL-M22(0))/ALOGM2 + 23.03/ALOGMB) + 1
          NDOLD = NDIG
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDIG - IEXTRA
              CALL FMST2M('UNKNOWN',M22)
              GO TO 160
          ENDIF
          CALL FMEQ2_R1(M25,NDSAVE,NDIG)
          CALL FMEQ(M25,M26)
          NUMTRY = NUMTRY + 1
          CALL FMEQ2(M22,MRETRY,NDOLD,NDIG)
          GO TO 110
      ENDIF

  160 MACMAX = NINT(NDSAVE*ALOGM2)
      M22(0) = MIN(M22(0),MACCA,MACMAX)
      CALL FMEXT2(M22,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMLNGM

      SUBROUTINE FMPGAM(N,MA,MB)

!  MB = POLYGAMMA(N,MA)      (Nth Derivative of PSI)

      USE FMVALS
      IMPLICIT NONE

      INTEGER N
      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
      INTEGER IEXTRA,INTA,J,J2,JN,JNC,JPT,JSTART,K,KASAVE,KFL,KOVUN,KPT,  &
              KPT1,KPT2,KRESLT,KRFLCT,KRSAVE,KWRNSV,LSHIFT,N1,NBOT,NC,    &
              NDGOAL,NDIG2,NDOLD,NDSAV1,NDSAVE,NDSV2,NGOAL,NMXDIF,NTERM,  &
              NTOP,NUMTRY

!             Set the coefficients used in computing various
!             derivatives of COT(Pi*X) for the reflection formula.

      INTEGER :: KGCD(14) =  &
              (/ 1, 2, 2, 8, 8, 16, 16, 128, 128, 256, 256, 1024,  &
                  1024, 2048 /)
      INTEGER :: KCOEFF(56) = (/  &
                    1,          1,              3, 1,     3, 2,           &
                    15, 15, 2,                  45, 60, 17,               &
                    315, 525, 231, 17,          315, 630, 378, 62,        &
                    2835, 6615, 5040, 1320, 62,                           &
                    14175, 37800, 34965, 12720, 1382,                     &
                    155925, 467775, 509355, 238425, 42306, 1382,          &
                    467775, 1559250, 1954260, 1121670, 280731, 21844,     &
                    6081075, 22297275, 31621590, 21531510, 7012005,       &
                             907725, 21844,                               &
                    42567525, 170270100, 269594325, 212612400, 85630545,  &
                             15839460, 929569 /)
      LOGICAL FMCOMP

      IF (NTRACE /= 0) THEN
          NCALL = NCALL + 1
          NAMEST(NCALL) = 'FMPGAM'
          CALL FMNTRI(2,N,1)
          NCALL = NCALL - 1
      ENDIF
      CALL FMENT2('FMPGAM',MA,MA,1,0,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      KACCSW = 1
      MACCA = MA(0)
      CALL FMEQ2(MA,M28,NDSAVE,NDIG)
      M28(0) = NINT(NDIG*ALOGM2)
      CALL FMEQ(M28,M27)
      NUMTRY = 0

  110 IF (N == 0) THEN
          CALL FMPSI(M28,M14)
          CALL FMEQ(M14,M28)
          CALL FMEQ(M28,M24)
          GO TO 150
      ENDIF
      IF (N < 0 .OR. MA(2) == 0) THEN
          CALL FMST2M('UNKNOWN',M24)
          KFLAG = -4
          GO TO 170
      ENDIF

!             Near zero PGAM(x) is about n!/(-x)**(n+1).

      IF (M27(1) < (-NDIG-1)) THEN
          CALL FMFCTI(N,M26)
          IF (M27(1) /= MUNKNO .AND. M27(2) /= 0) M27(-1) = -M27(-1)
          CALL FMIPWR(M27,N+1,M25)
          CALL FMDIV(M26,M25,M24)
          GO TO 150
      ENDIF

!             Check for special cases.

      KRFLCT = 0
      CALL FMDP2M(-0.5D0,M18)
      IF (FMCOMP(M27,'<=',M18)) THEN
          KRFLCT = 1
          KFL = 0
          IF (MA(1) <= NDSAVE) THEN
              CALL FMINT(M27,M23)
              IF (FMCOMP(M27,'==',M23)) KFL = -4
          ELSE
              KFL = -4
          ENDIF
          IF (KFL /= 0) THEN
              CALL FMST2M('UNKNOWN',M24)
              KFLAG = -4
              GO TO 170
          ELSE
              CALL FMI2M(1,M16)
              CALL FMSUB_R2(M16,M27)
          ENDIF
      ENDIF
      IF (MA(1) > NDIG+3) THEN
          CALL FMIPWR(M27,-N,M24)
          IF (M24(1) /= MEXPUN) THEN
              CALL FMFCTI(N-1,M23)
              CALL FMMPY_R1(M24,M23)
          ENDIF
          IF (MOD(N-1,2) == 1 .AND. M24(1) /= MUNKNO .AND.  &
              M24(2) /= 0) M24(-1) = -M24(-1)
          GO TO 150
      ENDIF

!             To speed the asymptotic series calculation, increase
!             the argument by LSHIFT.

      IEXTRA = 0
      KWRNSV = KWARN
      KWARN = 0
      CALL FMM2I(M27,INTA)
      KWARN = KWRNSV

      IF (KFLAG == -4) THEN
          LSHIFT = 0
      ELSE
          LSHIFT = INT(MAX(0.0,REAL(NDIG)*ALOGMB/4.46-REAL(INTA)))
          LSHIFT = LSHIFT + (7*N)/20
      ENDIF
      IF (LSHIFT > 0) LSHIFT = 4*(LSHIFT/4 + 1)

      IF (LSHIFT /= 0) THEN
          CALL FMI2M(LSHIFT,M16)
          CALL FMADD(M27,M16,M26)
      ELSE
          CALL FMEQ(M27,M26)
      ENDIF

!             Sum the asymptotic series.

      J2 = INT(0.3*ALOGMB + 0.2*SQRT(REAL(NDIG)))
      J2 = MAX(1,MIN(LJSUMS/(LUNPCK+3),J2))

!             M27 is Z
!             M26 is Z + LSHIFT
!             M23 is X**J2 = (1/(Z+LSHIFT)**2)**J2
!             M24 is the current power of X times the quotient of
!                 factorials in each term
!             M25 is the current term in the sum
!             M22 is (N+1)!
!             MJSUMS holds the partial sums

      NDSAV1 = NDIG
      CALL FMFCTI(N+1,M22)
      CALL FMDIVI(M22,2,M24)
      J = -2*J2
      CALL FMIPWR(M26,J,M23)
      IF (ABS(M23(1)) >= MEXPAB) THEN
          J2 = 1
          CALL FMIPWR(M26,-2,M23)
      ENDIF
      DO J = 1, J2
         NTERM = 2*J
         KPT = (J-1)*(NDSAV1+3)
         CALL FMBERN(NTERM,M24,MJSUMS(KPT-1))
         IF (KFLAG == -11) THEN
             CALL FMST2M('UNKNOWN',M24)
             KFLAG = -4
             GO TO 170
         ENDIF
         NTOP = (N+NTERM)*(N+NTERM+1)
         CALL FMMPYI_R1(M24,NTOP)
         NBOT = (NTERM+1)*(NTERM+2)
         CALL FMDIVI_R1(M24,NBOT)
      ENDDO

      NDIG2 = NDIG
  120 CALL FMMPY_R1(M24,M23)
      NMXDIF = 2
      DO J = 1, J2
         NTERM = NTERM + 2
         CALL FMBERN(NTERM,M24,M25)
         IF (KFLAG == -11) THEN
             CALL FMST2M('UNKNOWN',M24)
             KFLAG = -4
             GO TO 170
         ENDIF
         NDIG = NDSAV1
         KPT = (J-1)*(NDSAV1+3)
         CALL FMADD_R1(MJSUMS(KPT-1),M25)
         IF (KFLAG /= 0) THEN
             GO TO 130
         ELSE
             NMXDIF = MAX(NMXDIF,NDSAV1-INT(MJSUMS(KPT+1)-M25(1)))
             NDIG = NDIG2
             NTOP = (N+NTERM)*(N+NTERM+1)
             CALL FMMPYI_R1(M24,NTOP)
             NBOT = (NTERM+1)*(NTERM+2)
             CALL FMDIVI_R1(M24,NBOT)
         ENDIF
      ENDDO
      NDIG2 = NMXDIF
      NDIG = NDIG2
      GO TO 120

!             Put the J2 concurrent sums back together.

  130 NDIG = NDSAV1
      IF (J2 > 1) THEN
          KPT = (J2-1)*(NDSAV1+3)
          CALL FMI2M(1,M23)
          CALL FMSQR(M26,M25)
          CALL FMDIV_R2(M23,M25)
          CALL FMEQ(MJSUMS(KPT-1),M23)
          DO J = J2-1, 1, -1
             CALL FMMPY_R1(M23,M25)
             KPT = (J-1)*(NDSAV1+3)
             CALL FMADD_R1(M23,MJSUMS(KPT-1))
          ENDDO
          CALL FMEQ(M23,MJSUMS)
      ENDIF
      CALL FMIPWR(M26,N+2,M19)
      CALL FMDIV_R1(MJSUMS,M19)

!             Add the initial terms to the asymptotic series.

      CALL FMDIVI(M22,N+1,M23)
      CALL FMDIVI(M23,N,M22)
      CALL FMMPYI(M26,2,M20)
      CALL FMI2M(N,M24)
      CALL FMADD_R1(M20,M24)
      CALL FMMPY_R1(M20,M22)
      CALL FMMPYI_R1(M19,2)
      CALL FMDIV_R1(M19,M26)
      CALL FMDIV(M20,M19,M24)
      CALL FMADD_R2(MJSUMS,M24)
      IF (MOD(N-1,2) == 1 .AND. M24(1) /= MUNKNO .AND.  &
          M24(2) /= 0) M24(-1) = -M24(-1)

!             Now PGAM of the shifted argument has been
!             computed.  Reverse the shifting.
!             The sum 1/(MA)**(N+1) + ... + 1/(MA+LSHIFT-1)**(N+1)
!             is computed.

!             M27 is Z
!             M23 is N!
!             M24 is the sum of the asymptotic series
!             M25 is the sum 1/(MA)**(N+1) + ... +
!                            1/(MA+LSHIFT-1)**(N+1)

      IF (LSHIFT > 0) THEN
          CALL FMI2M(1,M19)
          CALL FMEQ(M27,M20)
          N1 = -(N + 1)
          CALL FMIPWR(M20,N1,M25)
          DO K = 1, LSHIFT-1
             CALL FMADD_R1(M20,M19)
             CALL FMIPWR(M20,N1,M26)
             CALL FMADD_R1(M25,M26)
          ENDDO
          CALL FMMPY_R2(M23,M25)
          IF (MOD(N+1,2) == 1 .AND. M25(1) /= MUNKNO .AND.  &
              M25(2) /= 0) M25(-1) = -M25(-1)
          CALL FMADD_R1(M24,M25)
      ENDIF

!             Use the reflection formula if MA was less than -1/2.

      IF (KRFLCT == 1) THEN

!             M25 is COT(Pi*Z)
!             M23 is M25**2

!             Reduce the argument before multiplying by Pi.

          CALL FMMPYI(M27,2,M18)
          CALL FMINT(M18,M23)
          IF (FMCOMP(M18,'==',M23)) THEN
              CALL FMI2M(0,M25)
              CALL FMEQ(M25,M23)
          ELSE
              CALL FMNINT(M27,M18)
              CALL FMSUB(M27,M18,M23)
              NDSV2 = NDIG
  140         CALL FMPI(M25)
              CALL FMMPY_R1(M25,M23)
              KRSAVE = KRAD
              KRAD = 1
              CALL FMTAN(M25,M12)
              CALL FMEQ(M12,M25)
              KRAD = KRSAVE
              IF ((M25(1) < 0 .OR. M25(1) > 1) .AND.  &
                  NDSV2 == NDIG) THEN
                  IEXTRA = INT(MAX(-M25(1),M25(1)))
                  IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
                      CALL FMEQ2_R1(M23,NDIG,NDIG+IEXTRA)
                  ENDIF
                  NDIG = NDIG + IEXTRA
                  IF (NDIG > NDG2MX) THEN
                      KFLAG = -9
                      CALL FMWRN2
                      NDIG = NDIG - IEXTRA
                      CALL FMST2M('UNKNOWN',M24)
                      GO TO 170
                  ENDIF
                  GO TO 140
              ENDIF

              NDIG = NDSV2
              CALL FMI2M(1,M18)
              CALL FMDIV_R2(M18,M25)
              CALL FMSQR(M25,M23)
          ENDIF
          NC = (N+1)/2

!             For N up to 14, use the stored coefficients to compute
!             the Nth derivative of Cot(Pi*Z).
!             For larger N, the coefficients are generated from a
!             recurrence relation and stored as FM numbers.

          IF (N <= 14) THEN
              JSTART = (N*N + 4 - MOD(N,2))/4
              IF (N <= 2) THEN
                  CALL FMI2M(1,M19)
              ELSE
                  CALL FMMPYI(M23,KCOEFF(JSTART),M19)
              ENDIF
              DO J = 2, NC
                 CALL FMI2M(KCOEFF(JSTART+J-1),M20)
                 CALL FMADD_R1(M19,M20)
                 IF (J < NC) CALL FMMPY_R1(M19,M23)
              ENDDO
              IF (MOD(N,2) == 0) CALL FMMPY_R1(M19,M25)
              IF (N > 1) CALL FMMPYI_R1(M19,KGCD(N))
          ELSE
              IF (NC*(NDIG+3) > LJSUMS) THEN
                  KFLAG = -12
                  CALL FMWRN2
                  WRITE (KW,  &
                         "(' For PGAM(',I5,',*) with NDIG =',I5,',',I7,"  //  &
                         "' words are needed'/' in array MJSUMS.',"       //  &
                         "'  The current dimension of MJSUMS IS',I7/)"        &
                        ) N,NDIG,NC*(NDIG+3),LJSUMS
                  MXEXP = MXSAVE
                  NDIG = NDSAVE
                  CALL FMST2M('UNKNOWN',MB)
                  IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
                  NCALL = NCALL - 1
                  KACCSW = KASAVE
                  RETURN
              ENDIF

              DO J = 1, 7
                 JPT = (J-1)*(NDIG+3)
                 CALL FMI2M(KCOEFF(J+49),MJSUMS(JPT-1))
                 CALL FMMPYI_R1(MJSUMS(JPT-1),KGCD(14))
              ENDDO
              DO JN = 15, N
                 JNC = (JN+1)/2
                 DO K = JNC, 2, -1
                    KPT1 = (K-2)*(NDIG+3)
                    KPT2 = (K-1)*(NDIG+3)
                    IF (K == JNC .AND. MOD(JN,2) == 1) THEN
                        CALL FMEQ(MJSUMS(KPT1-1),MJSUMS(KPT2-1))
                    ELSE
                        CALL FMADD(MJSUMS(KPT1-1),MJSUMS(KPT2-1),  &
                                   MJSUMS(KPT2-1))
                        CALL FMMPYI(MJSUMS(KPT2-1),JN-2*(K-1),  &
                                    MJSUMS(KPT2-1))
                    ENDIF
                 ENDDO
                 CALL FMMPYI_R1(MJSUMS,JN)
              ENDDO

!             MJSUMS now has the coefficients needed for the polynomial
!             in Cot**2 that defines the Nth derivative of Cot.

              CALL FMEQ(MJSUMS,M19)
              DO J = 2, NC
                 CALL FMMPY_R1(M19,M23)
                 KPT = (J-1)*(NDIG+3)
                 CALL FMADD_R1(M19,MJSUMS(KPT-1))
              ENDDO
              IF (MOD(N,2) == 0) CALL FMMPY_R1(M19,M25)
          ENDIF

!             To complete the calculation of the Nth derivative of
!             Cot, multiply the polynomial in Cot**2 by Csc**2.

          CALL FMADD(M23,M18,M20)
          CALL FMMPY_R1(M19,M20)

          CALL FMIPWR(MPISAV,N+1,M20)
          CALL FMMPY_R1(M19,M20)
          IF (MOD(N,2) == 1 .AND. M24(1) /= MUNKNO .AND.  &
              M24(2) /= 0) M24(-1) = -M24(-1)
          CALL FMADD_R1(M24,M19)
      ENDIF

!             Check for too much cancellation.

  150 IF (NCALL <= 1) THEN
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
      ELSE
          NGOAL = INT(-MXEXP2)
      ENDIF
      IF (M24(0) <= NGOAL) THEN
          IF (NUMTRY > 0) THEN
              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
              DO J = 1, NDGOAL+1
                 IF (MRETRY(J) /= M24(J)) GO TO 160
              ENDDO
              GO TO 170
          ENDIF
  160     IEXTRA = INT(REAL(NGOAL-M24(0))/ALOGM2 + 23.03/ALOGMB) + 1
          NDOLD = NDIG
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDIG - IEXTRA
              CALL FMST2M('UNKNOWN',M24)
              GO TO 170
          ENDIF
          CALL FMEQ2_R1(M28,NDSAVE,NDIG)
          CALL FMEQ(M28,M27)
          NUMTRY = NUMTRY + 1
          CALL FMEQ2(M24,MRETRY,NDOLD,NDIG)
          GO TO 110
      ENDIF

  170 MACMAX = NINT(NDSAVE*ALOGM2)
      M24(0) = MIN(M24(0),MACCA,MACMAX)
      CALL FMEXT2(M24,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMPGAM

      SUBROUTINE FMPOCH(MA,N,MB)

!  MB = MA*(MA+1)*(MA+2)*...*(MA+N-1)       (Pochhammer's symbol)

!  MB = Gamma(MA+N)/Gamma(MA)

!  For negative N, Pochhammer(MA,N) = 1/Pochhammer(MA+N,-N).

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      INTEGER N
      REAL (KIND(1.0D0)) :: MA2,MAS,MACCA,MACMAX,MBSIGN,MXSAVE
      INTEGER IEXTRA,J,K,K0,K1,K2,KASAVE,KLAST,KM08,KMB,KOVUN,KRESLT,  &
              LT,NDGOAL,NDOLD,NDSAVE,NGOAL,NT,NUMTRY
      LOGICAL FMCOMP
      REAL T

      CALL FMENT2('FMPOCH',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      CALL FMNTRI(2,N,0)
      IF (KRESLT /= 0) RETURN

      MA2 = MA(2)
      MAS = MA(-1)
      NT = N
      KACCSW = 1
      MACCA = MA(0)
      CALL FMEQ2(MA,M30,NDSAVE,NDIG)
      M30(0) = NINT(NDIG*ALOGM2)
      CALL FMEQ(M30,M27)
      NUMTRY = 0

!             Check for special cases.

  110 IEXTRA = 0
      IF (NT < 0) THEN
          CALL FMADDI(M30,NT)
          CALL FMEQ(M30,M27)
          NT = -NT
          MA2 = M30(2)
          MAS = M30(-1)
      ENDIF
      IF (MA2 == 0) THEN
          IF (NT > 0) THEN
              CALL FMI2M(0,M23)
              GO TO 130
          ELSE
              CALL FMST2M('UNKNOWN',M23)
              KFLAG = -4
              GO TO 150
          ENDIF
      ENDIF
      IF (NT == 0) THEN
          CALL FMI2M(1,M23)
          GO TO 130
      ELSE IF (NT == 1) THEN
          CALL FMEQ2(M30,M23,NDSAVE,NDIG)
          GO TO 130
      ENDIF
      CALL FMI2M(1,M16)
      CALL FMADD(M30,M16,M17)
      IF (M30(1) == MEXPOV) THEN
          CALL FMST2M('OVERFLOW',M23)
          IF (MAS < 0) M23(-1) = (-1)**NT
          GO TO 130
      ELSE IF (M30(1) == MEXPUN) THEN
          IF (NT == 2) THEN
              CALL FMST2M('UNDERFLOW',M23)
              IF (MAS < 0) M23(-1) = -1
          ELSE
              CALL FMST2M('UNKNOWN',M23)
              KFLAG = -4
          ENDIF
          GO TO 150
      ELSE IF (FMCOMP(M17,'==',M16)) THEN
          T = NDIG
          J = INT(15.21*SQRT(T)*ALOGMT + 42.87*SQRT(T) + 30.0)
          IF (NT <= J) THEN
              K1 = NT - 1
              CALL FMFCTI(K1,M23)
              CALL FMMPY_R2(M30,M23)
              GO TO 130
          ENDIF
      ENDIF

!             Look for cases where overflow is easy to detect.

      CALL FMI2M(NT,M21)
      CALL FMABS(M27,M19)
      IF (M27(1) > 0 .AND. FMCOMP(M21,'<',M19)) THEN
          CALL FMADD(M27,M21,M20)
          M20(-1) = 1
          CALL FMMIN(M19,M20,M22)
          IF (INT(M22(1))-1 > INTMAX/NT) THEN
              CALL FMST2M('OVERFLOW',M23)
              IF (M27(-1) > 0) THEN
                  M23(-1) = 1
              ELSE
                  M23(-1) = (-1)**MOD(NT,2)
              ENDIF
              KFLAG = -5
              GO TO 130
          ENDIF
      ENDIF

!             For large values of MA, the result is MA**NT.

      LT = NDIG + 3 + INT(2.0D0*LOG(DBLE(NT))/DLOGMB)
      IF (M30(1) > LT) THEN
          CALL FMIPWR(M27,NT,M23)
          GO TO 130
      ENDIF

      MBSIGN = 1
      IF (MAS < 0) THEN
          CALL FMINT(M27,M20)
          CALL FMI2M(NT,M21)
          CALL FMADD(M27,M21,M22)
          IF (FMCOMP(M27,'==',M20)) THEN

!                  If MA is a negative integer and MA+NT is positive,
!                  then the result is zero.

              IF (M22(-1)*M22(2) > 0) THEN
                  CALL FMI2M(0,M23)
                  GO TO 130
              ENDIF
          ENDIF

!                  If MA is negative and MA+NT-1 is negative,
!                  then use the reflection formula Pochhammer(MA,NT) =
!                  (-1)**NT*Pochhammer(-MA-(NT-1),NT).

          CALL FMI2M(1,M23)
          IF (FMCOMP(M22,'<',M23)) THEN

!                 Extra guard digits may be required to insure the
!                 reflection formula is accurate.

              IEXTRA = MAX(INT(M27(1)),IEXTRA)
              IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
                  CALL FMEQ2_R1(M27,NDIG,NDIG+IEXTRA)
              ENDIF
              NDIG = NDIG + IEXTRA
              IF (NDIG > NDG2MX) THEN
                  KFLAG = -9
                  CALL FMWRN2
                  NDIG = NDIG - IEXTRA
                  CALL FMST2M('UNKNOWN',M23)
                  GO TO 150
              ENDIF
              CALL FMI2M(NT-1,M23)
              IF (M27(1) /= MUNKNO .AND. M27(2) /= 0) M27(-1) = -M27(-1)
              CALL FMSUB_R1(M27,M23)
              IF (MOD(NT,2) == 1) MBSIGN = -1
          ENDIF
      ENDIF

!             If NT is large enough, it is faster to use two
!             calls to FMLNGM.  The formula below gives a rough
!             approximation of where to change methods.

      T = NDIG
      J = INT(15.21*SQRT(T)*ALOGMT + 42.87*SQRT(T) + 25.03)
      IF (NT > J) THEN
          CALL FMI2M(NT,M16)
          CALL FMADD(M27,M16,M28)

!             Compute IEXTRA, the number of extra digits required
!             to compensate for cancellation error.

          IF (MAX(M27(1),M28(1)) > IEXTRA) THEN
              IEXTRA = INT(MAX(M27(1),M28(1)))
          ENDIF
          IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
              CALL FMEQ2_R1(M27,NDIG,NDIG+IEXTRA)
          ENDIF
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDIG - IEXTRA
              CALL FMST2M('UNKNOWN',M23)
              GO TO 150
          ENDIF

          CALL FMI2M(-1,M29)
          IF (IEXTRA > 0) THEN
              CALL FMI2M(NT,M16)
              CALL FMADD(M27,M16,M28)
          ENDIF
          CALL FMI2M(2,M21)
          KMB = 0
          IF (M27(-1) < 0) THEN
              CALL FMMOD(M27,M21,M20)
              IF (FMCOMP(M20,'>',M29)) KMB = 1
          ENDIF
          KM08 = 0
          IF (M28(-1) < 0) THEN
              CALL FMMOD(M28,M21,M20)
              IF (FMCOMP(M20,'>',M29)) KM08 = 1
          ENDIF
          CALL FMI2M(1,M29)
          IF (M27(-1) < 0 .AND. KMB == 1) THEN
              CALL FMEQ(M27,M29)
              CALL FMI2M(1,M16)
              CALL FMADD_R1(M27,M16)
              CALL FMLNGM(M27,M14)
              CALL FMEQ(M14,M27)
          ELSE
              CALL FMLNGM(M27,M14)
              CALL FMEQ(M14,M27)
          ENDIF
          IF (M28(-1) < 0 .AND. KM08 == 1) THEN
              CALL FMI2M(-1,M19)
              CALL FMADD_R1(M28,M19)
              CALL FMMPY_R1(M29,M28)
              CALL FMLNGM(M28,M14)
              CALL FMEQ(M14,M28)
          ELSE
              CALL FMLNGM(M28,M14)
              CALL FMEQ(M14,M28)
          ENDIF

          CALL FMSUB(M28,M27,M23)
          CALL FMEXP(M23,M12)
          CALL FMEQ(M12,M23)
          CALL FMMPY_R1(M23,M29)
          GO TO 120
      ENDIF

!             Compute the product Z*(Z+1)*...*(Z+NT-1)
!             four terms at a time to reduce the number of FMMPY calls.

!             M27 is Z
!             M18 is Z**2
!             M19 is Z**3
!             M20 is (Z+K)*...*(Z+K+3)
!             M23 is the current product

!             If M27 is negative and M27+NT is positive, extra
!             digits are required when M27 is close to an integer.

      IF (M27(-1) < 0) THEN
          CALL FMI2M(NT,M20)
          CALL FMADD(M27,M20,M21)
          IF (M21(-1)*M21(2) > 0) THEN
              CALL FMNINT(M27,M22)
              IF (M22(2) /= 0) THEN
                  CALL FMSUB(M27,M22,M21)
                  IEXTRA = MAX(IEXTRA,NDIG-NDSAVE)
                  IF (MAX(M27(1),M21(1)) > IEXTRA) THEN
                      IEXTRA = INT(MAX(M27(1),M21(1)))
                  ENDIF
                  IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
                      CALL FMEQ2_R1(M27,NDIG,NDIG+IEXTRA)
                  ENDIF
                  NDIG = NDIG + IEXTRA
                  IF (NDIG > NDG2MX) THEN
                      KFLAG = -9
                      CALL FMWRN2
                      NDIG = NDIG - IEXTRA
                      CALL FMST2M('UNKNOWN',M23)
                      GO TO 150
                  ENDIF
              ENDIF
          ENDIF
      ENDIF

      CALL FMI2M(1,M23)
      IF (NT >= 4) THEN
          CALL FMSQR(M27,M18)
          CALL FMMPY(M27,M18,M19)
          CALL FMSQR(M18,M20)
          CALL FMMPYI(M19,6,M24)
          CALL FMADD_R1(M20,M24)
          CALL FMMPYI(M18,11,M24)
          CALL FMADD_R1(M20,M24)
          CALL FMMPYI(M27,6,M24)
          CALL FMADD_R1(M20,M24)
          CALL FMEQ(M20,M23)
          CALL FMMPYI_R1(M19,16)
          DO K = 0, NT-8, 4
             CALL FMADD_R1(M20,M19)
             K2 = 24*(2*K + 7)
             CALL FMMPYI(M18,K2,M24)
             CALL FMADD_R1(M20,M24)
             IF (K <= SQRT(REAL(INTMAX)/49.0)) THEN
                 K1 = 8*(6*K*K + 42*K + 79)
                 CALL FMMPYI(M27,K1,M24)
                 CALL FMADD_R1(M20,M24)
             ELSE
                 K1 = 48*K
                 CALL FMMPYI(M27,K1,M24)
                 CALL FMMPYI_R1(M24,K)
                 CALL FMADD_R1(M20,M24)
                 K1 = 336*K + 632
                 CALL FMMPYI(M27,K1,M24)
                 CALL FMADD_R1(M20,M24)
             ENDIF
             IF (K <= (REAL(INTMAX)/17.0)**0.3333) THEN
                 K0 = 8*(2*K + 7)*(K*K + 7*K + 15)
                 CALL FMADDI(M20,K0)
             ELSE IF (K <= SQRT(REAL(INTMAX)*0.9)) THEN
                 K0 = 8*(2*K + 7)
                 CALL FMI2M(K0,M24)
                 K0 = K*K + 7*K + 15
                 CALL FMMPYI_R1(M24,K0)
                 CALL FMADD_R1(M20,M24)
             ELSE
                 K0 = 8*(2*K + 7)
                 CALL FMI2M(K0,M24)
                 CALL FMMPYI(M24,K,M21)
                 CALL FMMPYI_R1(M21,K)
                 CALL FMADD_R1(M20,M21)
                 K0 = 7*K + 15
                 CALL FMMPYI_R1(M24,K0)
                 CALL FMADD_R1(M20,M24)
             ENDIF
             CALL FMMPY_R1(M23,M20)
          ENDDO
      ENDIF

      KLAST = (NT/4)*4
      DO J = KLAST, NT-1
         CALL FMI2M(J,M21)
         CALL FMADD_R2(M27,M21)
         CALL FMMPY_R1(M23,M21)
      ENDDO

!             If the reflection formula was used, multiply by (-1)**NT.

  120 M23(-1) = MBSIGN*M23(-1)

!             Check for too much cancellation.

  130 IF (NCALL <= 1) THEN
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
      ELSE
          NGOAL = INT(-MXEXP2)
      ENDIF
      IF (M23(0) <= NGOAL) THEN
          IF (NUMTRY > 0) THEN
              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
              DO J = 1, NDGOAL+1
                 IF (MRETRY(J) /= M23(J)) GO TO 140
              ENDDO
              GO TO 150
          ENDIF
  140     IEXTRA = INT(REAL(NGOAL-M23(0))/ALOGM2 + 23.03/ALOGMB) + 1
          NDOLD = NDIG
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDIG - IEXTRA
              CALL FMST2M('UNKNOWN',M23)
              GO TO 150
          ENDIF
          CALL FMEQ2_R1(M30,NDSAVE,NDIG)
          CALL FMEQ(M30,M27)
          NUMTRY = NUMTRY + 1
          CALL FMEQ2(M23,MRETRY,NDOLD,NDIG)
          GO TO 110
      ENDIF

  150 MACMAX = NINT(NDSAVE*ALOGM2)
      IF (N < 0) THEN
          CALL FMI2M(1,M18)
          CALL FMDIV_R2(M18,M23)
      ENDIF
      M23(0) = MIN(M23(0),MACCA,MACMAX)
      CALL FMEXT2(M23,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMPOCH

      SUBROUTINE FMPSI(MA,MB)

!  MB = PSI(MA)      (Derivative of Ln(Gamma(MA))

      USE FMVALS
      IMPLICIT NONE

      REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
      REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
      INTEGER IEXTRA,INTA,J,J2,K,K0,K0B,K1,K1B,K2,KASAVE,KFL,KOVUN,KPT,  &
              KRESLT,KRFLCT,KRSAVE,KWRNSV,LSHIFT,NDENOM,NDGOAL,NDIG2,    &
              NDOLD,NDSAV1,NDSAVE,NGOAL,NMXDIF,NTERM,NUMTRY
      LOGICAL FMCOMP

      CALL FMENT2('FMPSI ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &
                  KOVUN)
      IF (KRESLT /= 0) RETURN
      KACCSW = 1
      MACCA = MA(0)
      CALL FMEQ2(MA,M25,NDSAVE,NDIG)
      M25(0) = NINT(NDIG*ALOGM2)
      CALL FMEQ(M25,M26)
      NUMTRY = 0

!             Near zero Psi(x) is about -1/x.

  110 IF (M26(1) < (-NDIG-1)) THEN
          CALL FMI2M(-1,M16)
          CALL FMDIV(M16,M26,M22)
          GO TO 140
      ENDIF

!             Check for special cases.

      KRFLCT = 0
      CALL FMDPM(DBLE(-0.5),M18)
      IF (FMCOMP(M26,'<=',M18)) THEN
          KRFLCT = 1
          KFL = 0
          IF (MA(1) <= NDSAVE) THEN
              CALL FMINT(M26,M21)
              IF (FMCOMP(M26,'==',M21)) KFL = -4
          ELSE
              KFL = -4
          ENDIF
          IF (KFL /= 0) THEN
              CALL FMST2M('UNKNOWN',M22)
              KFLAG = -4
              GO TO 160
          ELSE
              CALL FMI2M(1,M16)
              CALL FMSUB_R2(M16,M26)
          ENDIF
      ENDIF

!             To speed the asymptotic series calculation, increase
!             the argument by LSHIFT.

      IEXTRA = 0
      KWRNSV = KWARN
      KWARN = 0
      CALL FMM2I(M26,INTA)
      KWARN = KWRNSV

      IF (KFLAG == -4) THEN
          LSHIFT = 0
      ELSE
          LSHIFT = INT(MAX(0.0,REAL(NDIG)*ALOGMB/4.46-REAL(INTA)))
      ENDIF
      IF (LSHIFT > 0) LSHIFT = 4*(LSHIFT/4 + 1)

      IF (LSHIFT /= 0) THEN
          CALL FMI2M(LSHIFT,M16)
          CALL FMADD(M26,M16,M24)
      ELSE
          CALL FMEQ(M26,M24)
      ENDIF

!             Sum the asymptotic series.

      J2 = INT(0.3*ALOGMB + 0.2*SQRT(REAL(NDIG)))
      J2 = MAX(1,MIN(LJSUMS/(LUNPCK+3),J2))

!             M26 is Z
!             M24 is Z + LSHIFT
!             M21 is X**J2 = (1/(Z+LSHIFT)**2)**J2
!             M22 is the current power of X
!             M23 is the current term in the sum
!             MJSUMS is the partial sum

      NDSAV1 = NDIG
      CALL FMI2M(1,M22)
      J = -2*J2
      CALL FMIPWR(M24,J,M21)
      IF (ABS(M21(1)) >= MEXPAB) THEN
          J2 = 1
          CALL FMIPWR(M24,-2,M21)
      ENDIF
      DO J = 1, J2
         NTERM = 2*J
         CALL FMBERN(NTERM,M22,M23)
         IF (KFLAG == -11) THEN
             CALL FMST2M('UNKNOWN',M22)
             KFLAG = -4
             GO TO 160
         ENDIF
         NDENOM = NTERM
         KPT = (J-1)*(NDSAV1+3)
         CALL FMDIVI(M23,NDENOM,MJSUMS(KPT-1))
      ENDDO

      NDIG2 = NDIG
  120 CALL FMMPY_R1(M22,M21)
      NMXDIF = 2
      DO J = 1, J2
         NTERM = NTERM + 2
         CALL FMBERN(NTERM,M22,M23)
         IF (KFLAG == -11) THEN
             CALL FMST2M('UNKNOWN',M22)
             KFLAG = -4
             GO TO 160
         ENDIF
         NDENOM = NTERM
         CALL FMDIVI_R1(M23,NDENOM)
         NDIG = NDSAV1
         KPT = (J-1)*(NDSAV1+3)
         CALL FMADD_R1(MJSUMS(KPT-1),M23)
         NMXDIF = MAX(NMXDIF,NDSAV1-INT(MJSUMS(KPT+1)-M23(1)))
         NDIG = NDIG2
         IF (KFLAG /= 0) GO TO 130
      ENDDO
      NDIG2 = NMXDIF
      NDIG = NDIG2
      GO TO 120

!             Put the J2 concurrent sums back together.

  130 NDIG = NDSAV1
      CALL FMI2M(1,M21)
      CALL FMSQR(M24,M23)
      CALL FMDIV_R2(M21,M23)
      IF (J2 > 1) THEN
          KPT = (J2-1)*(NDSAV1+3)
          CALL FMEQ(MJSUMS(KPT-1),M21)
          DO J = J2-1, 1, -1
             CALL FMMPY_R1(M21,M23)
             KPT = (J-1)*(NDSAV1+3)
             CALL FMADD_R1(M21,MJSUMS(KPT-1))
          ENDDO
          CALL FMEQ(M21,MJSUMS)
      ENDIF

!             Add the log term to the asymptotic series.

!             M22 is the current sum as the log terms are added
!             M23 is now LN(Z+LSHIFT)

      CALL FMMPY(MJSUMS,M23,M22)
      CALL FMLN(M24,M23)
      CALL FMI2M(1,M18)
      CALL FMDIV(M18,M24,M19)
      CALL FMDIVI_R1(M19,2)
      CALL FMSUB_R2(M23,M19)
      CALL FMSUB_R2(M19,M22)

!             Now Psi of the shifted argument has been
!             computed.  Reverse the shifting.
!             The sum 1/(MA) + ... + 1/(MA+LSHIFT-1) is computed.

!             M26 is Z
!             M18 is X**2
!             M19 is 16*Z**3
!             M20 is the current four-term numerator
!             M21 is the current four-term denominator
!             M23 is the current sum

      IF (LSHIFT > 0) THEN
          CALL FMSQR(M26,M18)
          CALL FMMPY(M26,M18,M19)
          CALL FMSQR(M18,M20)
          CALL FMMPYI(M19,6,M24)
          CALL FMADD_R1(M20,M24)
          CALL FMMPYI(M18,11,M24)
          CALL FMADD_R1(M20,M24)
          CALL FMMPYI(M26,6,M24)
          CALL FMADD(M20,M24,M21)
          CALL FMMPYI(M19,4,M20)
          CALL FMMPYI(M18,18,M24)
          CALL FMADD_R1(M20,M24)
          CALL FMMPYI(M26,22,M24)
          CALL FMADD_R1(M20,M24)
          CALL FMI2M(6,M24)
          CALL FMADD_R1(M20,M24)
          CALL FMDIV(M20,M21,M23)
          CALL FMMPYI_R1(M19,16)
          DO K = 4, LSHIFT-4, 4
             CALL FMADD_R1(M21,M19)

             CALL FMMPYI(M18,48,M24)
             CALL FMADD_R1(M20,M24)

             K2 = 8*(6*K - 3)
             CALL FMMPYI(M18,K2,M24)
             CALL FMADD_R1(M21,M24)

             K1 = 16*(6*K - 3)
             CALL FMMPYI(M26,K1,M24)
             CALL FMADD_R1(M20,M24)

             IF (K <= SQRT(REAL(INTMAX)/49.0)) THEN
                 K1 = 8*(6*K*K - 6*K + 7)
                 CALL FMMPYI(M26,K1,M24)
                 CALL FMADD_R1(M21,M24)

                 CALL FMI2M(K1,M24)
                 CALL FMADD_R1(M20,M24)
             ELSE
                 K1 = 48*K
                 CALL FMMPYI(M26,K1,M24)
                 CALL FMMPYI_R1(M24,K)
                 CALL FMADD_R1(M21,M24)
                 K1B = 8*(-6*K + 7)
                 CALL FMMPYI(M26,K1B,M24)
                 CALL FMADD_R1(M21,M24)

                 CALL FMI2M(K1,M24)
                 CALL FMMPYI_R1(M24,K)
                 CALL FMADD_R1(M20,M24)
                 CALL FMI2M(K1B,M24)
                 CALL FMADD_R1(M20,M24)
             ENDIF
             IF (K <= (REAL(INTMAX)/17.0)**0.3333) THEN
                 K0 = 8*(2*K - 1)*(K*K - K + 3)
                 CALL FMI2M(K0,M24)
                 CALL FMADD_R1(M21,M24)
             ELSE IF (K <= SQRT(REAL(INTMAX)*0.9)) THEN
                 K0 = 8*(2*K - 1)
                 CALL FMI2M(K0,M24)
                 K0B = K*K - K + 3
                 CALL FMMPYI_R1(M24,K0B)
                 CALL FMADD_R1(M21,M24)
             ELSE
                 K0 = 8*(2*K - 1)
                 CALL FMI2M(K0,M24)
                 CALL FMMPYI_R1(M24,K)
                 CALL FMMPYI_R1(M24,K)
                 CALL FMADD_R1(M21,M24)
                 K0B = -K + 3
                 CALL FMI2M(K0,M24)
                 CALL FMMPYI_R1(M24,K0B)
                 CALL FMADD_R1(M21,M24)
             ENDIF
             CALL FMDIV(M20,M21,M24)
             CALL FMADD_R1(M23,M24)
          ENDDO
          CALL FMSUB_R1(M22,M23)
      ENDIF

!             Use the reflection formula if MA was less than -1/2.

      IF (KRFLCT == 1) THEN

!             Reduce the argument before multiplying by Pi.

          CALL FMNINT(M26,M18)
          CALL FMSUB(M26,M18,M21)
          M21(0) = M26(0)
          CALL FMPI(M23)
          CALL FMMPY_R1(M23,M21)
          KRSAVE = KRAD
          KRAD = 1
          CALL FMTAN(M23,M12)
          CALL FMEQ(M12,M23)
          KRAD = KRSAVE
          CALL FMDIV_R2(MPISAV,M23)
          CALL FMADD_R1(M22,M23)
      ENDIF

!             Check for too much cancellation.

  140 IF (NCALL <= 1) THEN
          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
      ELSE
          NGOAL = INT(-MXEXP2)
      ENDIF
      IF (M22(0) <= NGOAL) THEN
          IF (NUMTRY > 0) THEN
              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
              DO J = 1, NDGOAL+1
                 IF (MRETRY(J) /= M22(J)) GO TO 150
              ENDDO
              GO TO 160
          ENDIF
  150     IEXTRA = INT(REAL(NGOAL-M22(0))/ALOGM2 + 23.03/ALOGMB) + 1
          NDOLD = NDIG
          NDIG = NDIG + IEXTRA
          IF (NDIG > NDG2MX) THEN
              KFLAG = -9
              CALL FMWRN2
              NDIG = NDIG - IEXTRA
              CALL FMST2M('UNKNOWN',M22)
              GO TO 160
          ENDIF
          CALL FMEQ2_R1(M25,NDSAVE,NDIG)
          CALL FMEQ(M25,M26)
          NUMTRY = NUMTRY + 1
          CALL FMEQ2(M22,MRETRY,NDOLD,NDIG)
          GO TO 110
      ENDIF

  160 MACMAX = NINT(NDSAVE*ALOGM2)
      M22(0) = MIN(M22(0),MACCA,MACMAX)
      CALL FMEXT2(M22,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
      RETURN
      END SUBROUTINE FMPSI

      SUBROUTINE FMWRN2

!  Called by one of the FM routines to print a warning message
!  if any error condition arises in that routine.

      USE FMVALS
      IMPLICIT NONE

      CHARACTER(6) :: NAME

      INTEGER NCS

      IF (KFLAG >= 0 .OR. NCALL /= 1 .OR. KWARN <= 0) RETURN
      NCS = NCALL
      NAME = NAMEST(NCALL)
      WRITE (KW,  &
             "(/' Error of type KFLAG =',I3,"  //  &
             "' in FM package in routine ',A6/)"   &
            ) KFLAG,NAME

  110 NCALL = NCALL - 1
      IF (NCALL > 0) THEN
          NAME = NAMEST(NCALL)
          WRITE (KW,"( ' called from ',A6)") NAME
          GO TO 110
      ENDIF

      IF (KFLAG == -1) THEN
          WRITE (KW,"(' NDIG must be between 2 and',I10/)") NDIGMX
      ELSE IF (KFLAG == -2) THEN
          WRITE (KW,"(' MBASE must be between 2 and',I10/)") INT(MXBASE)
      ELSE IF (KFLAG == -3) THEN
          WRITE (KW,  &
                 "(' An input argument is not a valid FM number.',"  //  &
                 "'  Its exponent is out of range.'/)"                   &
                )
          WRITE (KW,"(' UNKNOWN has been returned.'/)")
      ELSE IF (KFLAG == -4 .OR. KFLAG == -7) THEN
          WRITE (KW,"(' Invalid input argument for this routine.'/)")
          WRITE (KW,"(' UNKNOWN has been returned.'/)")
      ELSE IF (KFLAG == -5) THEN
          WRITE (KW,"(' The result has overflowed.'/)")
      ELSE IF (KFLAG == -6) THEN
          WRITE (KW,"(' The result has underflowed.'/)")
      ELSE IF (KFLAG == -8) THEN
          WRITE (KW,  &
                 "(' The result array is not big enough to hold the',"    //  &
                 "' output character string'/' in the current format.'/"  //  &
                 "' The result ''***...***'' has been returned.'/)"           &
                )
      ELSE IF (KFLAG == -9) THEN
          WRITE (KW,  &
                 "(' Precision could not be raised enough to'"  //  &
                 ",' provide all requested guard digits.'/)"        &
                )
          WRITE (KW,  &
                 "(I23,' digits were requested (NDIG).'/"            //  &
                 "' Maximum number of digits currently available',"  //  &
                 "' (NDG2MX) is',I7,'.'/)"                               &
                ) NDIG,NDG2MX
          WRITE (KW,"(' UNKNOWN has been returned.'/)")
      ELSE IF (KFLAG == -10) THEN
          IF (NAMEST(NCS) == 'FMM2SP') THEN
              WRITE (KW,  &
                     "(' An FM number was too small in magnitude to ',"  //  &
                     "'convert to single precision.'/)"                      &
                    )
          ELSE
              WRITE (KW,  &
                     "(' An FM number was too small in magnitude to ',"  //  &
                     "'convert to double precision.'/)"                      &
                    )
          ENDIF
          WRITE (KW,"(' Zero has been returned.'/)")
      ELSE IF (KFLAG == -11) THEN
          WRITE (KW,"(' Array MBERN is not large enough.')")
      ELSE IF (KFLAG == -12) THEN
          WRITE (KW,"(' Array MJSUMS is not large enough.')")
      ENDIF

      NCALL = NCS
      IF (KWARN >= 2) THEN
          STOP
      ENDIF
      RETURN
      END SUBROUTINE FMWRN2

!             Packed versions of routines for special functions.

      SUBROUTINE FPBERN(INT,MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      INTEGER INT
      CALL FMUNPK(MA,MPA)
      CALL FMBERN(INT,MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPBERN

      SUBROUTINE FPBETA(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMBETA(MPA,MPB,MPC)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPBETA

      SUBROUTINE FPCMBI(N,K,MA)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      INTEGER K,N
      CALL FMCMBI(N,K,MPA)
      CALL FMPACK(MPA,MA)
      RETURN
      END SUBROUTINE FPCMBI

      SUBROUTINE FPCOMB(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMCOMB(MPA,MPB,MPC)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPCOMB

      SUBROUTINE FPEULR(MA)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK)
      CALL FMEULR(MPA)
      CALL FMPACK(MPA,MA)
      RETURN
      END SUBROUTINE FPEULR

      SUBROUTINE FPFACT(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMFACT(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPFACT

      SUBROUTINE FPGAM(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMGAM(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPGAM

      SUBROUTINE FPIBTA(MA,MB,MC,MD)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK),MD(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMUNPK(MC,MPC)
      CALL FMIBTA(MPA,MPB,MPC,MPD)
      CALL FMPACK(MPD,MD)
      RETURN
      END SUBROUTINE FPIBTA

      SUBROUTINE FPIGM1(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMIGM1(MPA,MPB,MPC)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPIGM1

      SUBROUTINE FPIGM2(MA,MB,MC)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMUNPK(MB,MPB)
      CALL FMIGM2(MPA,MPB,MPC)
      CALL FMPACK(MPC,MC)
      RETURN
      END SUBROUTINE FPIGM2

      SUBROUTINE FPLNGM(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMLNGM(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPLNGM

      SUBROUTINE FPPGAM(N,MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      INTEGER N
      CALL FMUNPK(MA,MPA)
      CALL FMPGAM(N,MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPPGAM

      SUBROUTINE FPPOCH(MA,N,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      INTEGER N
      CALL FMUNPK(MA,MPA)
      CALL FMPOCH(MPA,N,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPPOCH

      SUBROUTINE FPPSI(MA,MB)
      USE FMVALS
      IMPLICIT NONE
      REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
      CALL FMUNPK(MA,MPA)
      CALL FMPSI(MPA,MPB)
      CALL FMPACK(MPB,MB)
      RETURN
      END SUBROUTINE FPPSI

! Interface routines for calling with the FM, IM, and ZM derived types.

   SUBROUTINE FM_ABS(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMABS(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_ACOS(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMACOS(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_ADD(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMADD(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_ADD_R1(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMADD_R1(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_ADD_R2(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMADD_R2(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_ADDI(MA,IVAL)
      USE FMZM
      TYPE ( FM ) MA
      INTEGER IVAL
      CALL FMADDI(MA%MFM,IVAL)
   END SUBROUTINE

   SUBROUTINE FM_ASIN(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMASIN(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_ATAN(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMATAN(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_ATN2(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMATN2(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_BIG(MA)
      USE FMZM
      TYPE ( FM ) MA
      CALL FMBIG(MA%MFM)
   END SUBROUTINE

   SUBROUTINE FM_CHSH(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMCHSH(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   FUNCTION FM_COMP(MA,LREL,MB)
      USE FMZM
      LOGICAL FM_COMP,FMCOMP
      TYPE ( FM ) MA,MB
      CHARACTER(*) :: LREL
      FM_COMP = FMCOMP(MA%MFM,LREL,MB%MFM)
   END FUNCTION

   SUBROUTINE FM_COS(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMCOS(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_COSH(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMCOSH(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_CSSN(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMCSSN(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_DIM(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMDIM(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_DIV(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMDIV(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_DIV_R1(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMDIV_R1(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_DIV_R2(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMDIV_R2(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_DIVI(MA,IVAL,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      INTEGER IVAL
      CALL FMDIVI(MA%MFM,IVAL,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_DIVI_R1(MA,IVAL)
      USE FMZM
      TYPE ( FM ) MA
      INTEGER IVAL
      CALL FMDIVI_R1(MA%MFM,IVAL)
   END SUBROUTINE

   SUBROUTINE FM_DP2M(X,MA)
      USE FMZM
      TYPE ( FM ) MA
      DOUBLE PRECISION X
      CALL FMDP2M(X,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FM_DPM(X,MA)
      USE FMZM
      TYPE ( FM ) MA
      DOUBLE PRECISION X
      CALL FMDPM(X,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FM_EQ(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMEQ(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_EQU(MA,MB,NA,NB)
      USE FMZM
      INTEGER NA,NB
      TYPE ( FM ) MA,MB
      CALL FMEQU(MA%MFM,MB%MFM,NA,NB)
   END SUBROUTINE

   SUBROUTINE FM_EXP(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMEXP(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_FORM(FORM,MA,STRING)
      USE FMZM
      CHARACTER(*) :: FORM,STRING
      TYPE ( FM ) MA
      CALL FMFORM(FORM,MA%MFM,STRING)
   END SUBROUTINE

   SUBROUTINE FM_FPRT(FORM,MA)
      USE FMZM
      CHARACTER(*) :: FORM
      TYPE ( FM ) MA
      CALL FMFPRT(FORM,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FM_I2M(IVAL,MA)
      USE FMZM
      TYPE ( FM ) MA
      INTEGER IVAL
      CALL FMI2M(IVAL,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FM_INP(LINE,MA,LA,LB)
      USE FMZM
      INTEGER LA,LB
      CHARACTER LINE(LB)
      TYPE ( FM ) MA
      CALL FMINP(LINE,MA%MFM,LA,LB)
   END SUBROUTINE

   SUBROUTINE FM_INT(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMINT(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_IPWR(MA,IVAL,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      INTEGER IVAL
      CALL FMIPWR(MA%MFM,IVAL,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_LG10(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMLG10(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_LN(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMLN(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_LNI(IVAL,MA)
      USE FMZM
      TYPE ( FM ) MA
      INTEGER IVAL
      CALL FMLNI(IVAL,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FM_M2DP(MA,X)
      USE FMZM
      TYPE ( FM ) MA
      DOUBLE PRECISION X
      CALL FMM2DP(MA%MFM,X)
   END SUBROUTINE

   SUBROUTINE FM_M2I(MA,IVAL)
      USE FMZM
      TYPE ( FM ) MA
      INTEGER IVAL
      CALL FMM2I(MA%MFM,IVAL)
   END SUBROUTINE

   SUBROUTINE FM_M2SP(MA,X)
      USE FMZM
      TYPE ( FM ) MA
      REAL X
      CALL FMM2SP(MA%MFM,X)
   END SUBROUTINE

   SUBROUTINE FM_MAX(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMMAX(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_MIN(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMMIN(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_MOD(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMMOD(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_MPY(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMMPY(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_MPY_R1(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMMPY_R1(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_MPY_R2(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMMPY_R2(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_MPYI(MA,IVAL,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      INTEGER IVAL
      CALL FMMPYI(MA%MFM,IVAL,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_MPYI_R1(MA,IVAL)
      USE FMZM
      TYPE ( FM ) MA
      INTEGER IVAL
      CALL FMMPYI_R1(MA%MFM,IVAL)
   END SUBROUTINE

   SUBROUTINE FM_NINT(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMNINT(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_OUT(MA,LINE,LB)
      USE FMZM
      INTEGER LB
      CHARACTER LINE(LB)
      TYPE ( FM ) MA
      CALL FMOUT(MA%MFM,LINE,LB)
   END SUBROUTINE

   SUBROUTINE FM_PI(MA)
      USE FMZM
      TYPE ( FM ) MA
      CALL FMPI(MA%MFM)
   END SUBROUTINE

   SUBROUTINE FM_PRNT(MA)
      USE FMZM
      TYPE ( FM ) MA
      CALL FMPRNT(MA%MFM)
   END SUBROUTINE

   SUBROUTINE FM_PWR(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMPWR(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_READ(KREAD,MA)
      USE FMZM
      INTEGER KREAD
      TYPE ( FM ) MA
      CALL FMREAD(KREAD,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FM_RPWR(MA,IVAL,JVAL,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      INTEGER IVAL,JVAL
      CALL FMRPWR(MA%MFM,IVAL,JVAL,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_SET(NPREC)
      INTEGER NPREC
      CALL FMSET(NPREC)
   END SUBROUTINE

   SUBROUTINE FM_SIGN(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMSIGN(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_SIN(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMSIN(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_SINH(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMSINH(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_SP2M(X,MA)
      USE FMZM
      TYPE ( FM ) MA
      REAL X
      CALL FMSP2M(X,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FM_SQR(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMSQR(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_SQR_R1(MA)
      USE FMZM
      TYPE ( FM ) MA
      CALL FMSQR_R1(MA%MFM)
   END SUBROUTINE

   SUBROUTINE FM_SQRT(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMSQRT(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_SQRT_R1(MA)
      USE FMZM
      TYPE ( FM ) MA
      CALL FMSQRT_R1(MA%MFM)
   END SUBROUTINE

   SUBROUTINE FM_ST2M(STRING,MA)
      USE FMZM
      TYPE ( FM ) MA
      CHARACTER(*) :: STRING
      CALL FMST2M(STRING,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FM_SUB(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMSUB(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_SUB_R1(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMSUB_R1(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_SUB_R2(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMSUB_R2(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_TAN(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMTAN(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_TANH(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMTANH(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_ULP(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMULP(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_WRIT(KWRITE,MA)
      USE FMZM
      INTEGER KWRITE
      TYPE ( FM ) MA
      CALL FMWRIT(KWRITE,MA%MFM)
   END SUBROUTINE

   SUBROUTINE IM_ABS(MA,MB)
      USE FMZM
      TYPE ( IM ) MA,MB
      CALL IMABS(MA%MIM,MB%MIM)
   END SUBROUTINE

   SUBROUTINE IM_ADD(MA,MB,MC)
      USE FMZM
      TYPE ( IM ) MA,MB,MC
      CALL IMADD(MA%MIM,MB%MIM,MC%MIM)
   END SUBROUTINE

   SUBROUTINE IM_BIG(MA)
      USE FMZM
      TYPE ( IM ) MA
      CALL IMBIG(MA%MIM)
   END SUBROUTINE

   FUNCTION IM_COMP(MA,LREL,MB)
      USE FMZM
      LOGICAL IM_COMP,IMCOMP
      TYPE ( IM ) MA,MB
      CHARACTER(*) :: LREL
      IM_COMP = IMCOMP(MA%MIM,LREL,MB%MIM)
   END FUNCTION

   SUBROUTINE IM_DIM(MA,MB,MC)
      USE FMZM
      TYPE ( IM ) MA,MB,MC
      CALL IMDIM(MA%MIM,MB%MIM,MC%MIM)
   END SUBROUTINE

   SUBROUTINE IM_DIV(MA,MB,MC)
      USE FMZM
      TYPE ( IM ) MA,MB,MC
      CALL IMDIV(MA%MIM,MB%MIM,MC%MIM)
   END SUBROUTINE

   SUBROUTINE IM_DIVI(MA,IVAL,MB)
      USE FMZM
      TYPE ( IM ) MA,MB
      INTEGER IVAL
      CALL IMDIVI(MA%MIM,IVAL,MB%MIM)
   END SUBROUTINE

   SUBROUTINE IM_DIVR(MA,MB,MC,MD)
      USE FMZM
      TYPE ( IM ) MA,MB,MC,MD
      CALL IMDIVR(MA%MIM,MB%MIM,MC%MIM,MD%MIM)
   END SUBROUTINE

   SUBROUTINE IM_DVIR(MA,IVAL,MB,IREM)
      USE FMZM
      TYPE ( IM ) MA,MB
      INTEGER IVAL,IREM
      CALL IMDVIR(MA%MIM,IVAL,MB%MIM,IREM)
   END SUBROUTINE

   SUBROUTINE IM_EQ(MA,MB)
      USE FMZM
      TYPE ( IM ) MA,MB
      CALL IMEQ(MA%MIM,MB%MIM)
   END SUBROUTINE

   SUBROUTINE IM_FM2I(MA,MB)
      USE FMZM
      TYPE ( FM ) MA
      TYPE ( IM ) MB
      CALL IMFM2I(MA%MFM,MB%MIM)
   END SUBROUTINE

   SUBROUTINE IM_FORM(FORM,MA,STRING)
      USE FMZM
      CHARACTER(*) :: FORM,STRING
      TYPE ( IM ) MA
      CALL IMFORM(FORM,MA%MIM,STRING)
   END SUBROUTINE

   SUBROUTINE IM_FPRT(FORM,MA)
      USE FMZM
      CHARACTER(*) :: FORM
      TYPE ( IM ) MA
      CALL IMFPRT(FORM,MA%MIM)
   END SUBROUTINE

   SUBROUTINE IM_GCD(MA,MB,MC)
      USE FMZM
      TYPE ( IM ) MA,MB,MC
      CALL IMGCD(MA%MIM,MB%MIM,MC%MIM)
   END SUBROUTINE

   SUBROUTINE IM_I2FM(MA,MB)
      USE FMZM
      TYPE ( IM ) MA
      TYPE ( FM ) MB
      CALL IMI2FM(MA%MIM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE IM_I2M(IVAL,MA)
      USE FMZM
      TYPE ( IM ) MA
      INTEGER IVAL
      CALL IMI2M(IVAL,MA%MIM)
   END SUBROUTINE

   SUBROUTINE IM_INP(LINE,MA,LA,LB)
      USE FMZM
      INTEGER LA,LB
      CHARACTER LINE(LB)
      TYPE ( IM ) MA
      CALL IMINP(LINE,MA%MIM,LA,LB)
   END SUBROUTINE

   SUBROUTINE IM_M2DP(MA,X)
      USE FMZM
      TYPE ( IM ) MA
      DOUBLE PRECISION X
      CALL IMM2DP(MA%MIM,X)
   END SUBROUTINE

   SUBROUTINE IM_M2I(MA,IVAL)
      USE FMZM
      TYPE ( IM ) MA
      INTEGER IVAL
      CALL IMM2I(MA%MIM,IVAL)
   END SUBROUTINE

   SUBROUTINE IM_MAX(MA,MB,MC)
      USE FMZM
      TYPE ( IM ) MA,MB,MC
      CALL IMMAX(MA%MIM,MB%MIM,MC%MIM)
   END SUBROUTINE

   SUBROUTINE IM_MIN(MA,MB,MC)
      USE FMZM
      TYPE ( IM ) MA,MB,MC
      CALL IMMIN(MA%MIM,MB%MIM,MC%MIM)
   END SUBROUTINE

   SUBROUTINE IM_MOD(MA,MB,MC)
      USE FMZM
      TYPE ( IM ) MA,MB,MC
      CALL IMMOD(MA%MIM,MB%MIM,MC%MIM)
   END SUBROUTINE

   SUBROUTINE IM_MPY(MA,MB,MC)
      USE FMZM
      TYPE ( IM ) MA,MB,MC
      CALL IMMPY(MA%MIM,MB%MIM,MC%MIM)
   END SUBROUTINE

   SUBROUTINE IM_MPYI(MA,IVAL,MB)
      USE FMZM
      TYPE ( IM ) MA,MB
      INTEGER IVAL
      CALL IMMPYI(MA%MIM,IVAL,MB%MIM)
   END SUBROUTINE

   SUBROUTINE IM_MPYM(MA,MB,MC,MD)
      USE FMZM
      TYPE ( IM ) MA,MB,MC,MD
      CALL IMMPYM(MA%MIM,MB%MIM,MC%MIM,MD%MIM)
   END SUBROUTINE

   SUBROUTINE IM_OUT(MA,LINE,LB)
      USE FMZM
      INTEGER LB
      CHARACTER LINE(LB)
      TYPE ( IM ) MA
      CALL IMOUT(MA%MIM,LINE,LB)
   END SUBROUTINE

   SUBROUTINE IM_PMOD(MA,MB,MC,MD)
      USE FMZM
      TYPE ( IM ) MA,MB,MC,MD
      CALL IMPMOD(MA%MIM,MB%MIM,MC%MIM,MD%MIM)
   END SUBROUTINE

   SUBROUTINE IM_PRNT(MA)
      USE FMZM
      TYPE ( IM ) MA
      CALL IMPRNT(MA%MIM)
   END SUBROUTINE

   SUBROUTINE IM_PWR(MA,MB,MC)
      USE FMZM
      TYPE ( IM ) MA,MB,MC
      CALL IMPWR(MA%MIM,MB%MIM,MC%MIM)
   END SUBROUTINE

   SUBROUTINE IM_READ(KREAD,MA)
      USE FMZM
      INTEGER KREAD
      TYPE ( IM ) MA
      CALL IMREAD(KREAD,MA%MIM)
   END SUBROUTINE

   SUBROUTINE IM_SET(NPREC)
      INTEGER NPREC
      CALL FMSET(NPREC)
   END SUBROUTINE

   SUBROUTINE IM_SIGN(MA,MB,MC)
      USE FMZM
      TYPE ( IM ) MA,MB,MC
      CALL IMSIGN(MA%MIM,MB%MIM,MC%MIM)
   END SUBROUTINE

   SUBROUTINE IM_SQR(MA,MB)
      USE FMZM
      TYPE ( IM ) MA,MB
      CALL IMSQR(MA%MIM,MB%MIM)
   END SUBROUTINE

   SUBROUTINE IM_ST2M(STRING,MA)
      USE FMZM
      TYPE ( IM ) MA
      CHARACTER(*) :: STRING
      CALL IMST2M(STRING,MA%MIM)
   END SUBROUTINE

   SUBROUTINE IM_SUB(MA,MB,MC)
      USE FMZM
      TYPE ( IM ) MA,MB,MC
      CALL IMSUB(MA%MIM,MB%MIM,MC%MIM)
   END SUBROUTINE

   SUBROUTINE IM_WRIT(KWRITE,MA)
      USE FMZM
      INTEGER KWRITE
      TYPE ( IM ) MA
      CALL IMWRIT(KWRITE,MA%MIM)
   END SUBROUTINE

   SUBROUTINE ZM_ABS(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA
      TYPE ( FM ) MB
      CALL ZMABS(MA%MZM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE ZM_ACOS(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMACOS(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_ADD(MA,MB,MC)
      USE FMZM
      TYPE ( ZM ) MA,MB,MC
      CALL ZMADD(MA%MZM,MB%MZM,MC%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_ADDI(MA,IVAL)
      USE FMZM
      TYPE ( ZM ) MA
      INTEGER IVAL
      CALL ZMADDI(MA%MZM,IVAL)
   END SUBROUTINE

   SUBROUTINE ZM_ARG(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA
      TYPE ( FM ) MB
      CALL ZMARG(MA%MZM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE ZM_ASIN(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMASIN(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_ATAN(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMATAN(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_CHSH(MA,MB,MC)
      USE FMZM
      TYPE ( ZM ) MA,MB,MC
      CALL ZMCHSH(MA%MZM,MB%MZM,MC%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_CMPX(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB
      TYPE ( ZM ) MC
      CALL ZMCMPX(MA%MFM,MB%MFM,MC%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_CONJ(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMCONJ(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_COS(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMCOS(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_COSH(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMCOSH(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_CSSN(MA,MB,MC)
      USE FMZM
      TYPE ( ZM ) MA,MB,MC
      CALL ZMCSSN(MA%MZM,MB%MZM,MC%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_DIV(MA,MB,MC)
      USE FMZM
      TYPE ( ZM ) MA,MB,MC
      CALL ZMDIV(MA%MZM,MB%MZM,MC%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_DIVI(MA,IVAL,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      INTEGER IVAL
      CALL ZMDIVI(MA%MZM,IVAL,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_EQ(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMEQ(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_EQU(MA,MB,NA,NB)
      USE FMZM
      INTEGER NA,NB
      TYPE ( ZM ) MA,MB
      CALL ZMEQU(MA%MZM,MB%MZM,NA,NB)
   END SUBROUTINE

   SUBROUTINE ZM_EXP(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMEXP(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_FORM(FORM1,FORM2,MA,STRING)
      USE FMZM
      CHARACTER(*) :: FORM1,FORM2,STRING
      TYPE ( ZM ) MA
      CALL ZMFORM(FORM1,FORM2,MA%MZM,STRING)
   END SUBROUTINE

   SUBROUTINE ZM_FPRT(FORM1,FORM2,MA)
      USE FMZM
      CHARACTER(*) :: FORM1,FORM2
      TYPE ( ZM ) MA
      CALL ZMFPRT(FORM1,FORM2,MA%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_I2M(IVAL,MA)
      USE FMZM
      TYPE ( ZM ) MA
      INTEGER IVAL
      CALL ZMI2M(IVAL,MA%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_2I2M(IVAL1,IVAL2,MA)
      USE FMZM
      TYPE ( ZM ) MA
      INTEGER IVAL1,IVAL2
      CALL ZM2I2M(IVAL1,IVAL2,MA%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_IMAG(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA
      TYPE ( FM ) MB
      CALL ZMIMAG(MA%MZM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE ZM_INP(LINE,MA,LA,LB)
      USE FMZM
      INTEGER LA,LB
      CHARACTER LINE(LB)
      TYPE ( ZM ) MA
      CALL ZMINP(LINE,MA%MZM,LA,LB)
   END SUBROUTINE

   SUBROUTINE ZM_INT(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMINT(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_IPWR(MA,IVAL,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      INTEGER IVAL
      CALL ZMIPWR(MA%MZM,IVAL,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_LG10(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMLG10(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_LN(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMLN(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_M2I(MA,IVAL)
      USE FMZM
      TYPE ( ZM ) MA
      INTEGER IVAL
      CALL ZMM2I(MA%MZM,IVAL)
   END SUBROUTINE

   SUBROUTINE ZM_M2Z(MA,ZVAL)
      USE FMZM
      TYPE ( ZM ) MA
      COMPLEX ZVAL
      CALL ZMM2Z(MA%MZM,ZVAL)
   END SUBROUTINE

   SUBROUTINE ZM_MPY(MA,MB,MC)
      USE FMZM
      TYPE ( ZM ) MA,MB,MC
      CALL ZMMPY(MA%MZM,MB%MZM,MC%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_MPYI(MA,IVAL,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      INTEGER IVAL
      CALL ZMMPYI(MA%MZM,IVAL,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_NINT(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMNINT(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_OUT(MA,LINE,LB,LAST1,LAST2)
      USE FMZM
      INTEGER LB,LAST1,LAST2
      CHARACTER LINE(LB)
      TYPE ( ZM ) MA
      CALL ZMOUT(MA%MZM,LINE,LB,LAST1,LAST2)
   END SUBROUTINE

   SUBROUTINE ZM_PRNT(MA)
      USE FMZM
      TYPE ( ZM ) MA
      CALL ZMPRNT(MA%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_PWR(MA,MB,MC)
      USE FMZM
      TYPE ( ZM ) MA,MB,MC
      CALL ZMPWR(MA%MZM,MB%MZM,MC%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_READ(KREAD,MA)
      USE FMZM
      INTEGER KREAD
      TYPE ( ZM ) MA
      CALL ZMREAD(KREAD,MA%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_REAL(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA
      TYPE ( FM ) MB
      CALL ZMREAL(MA%MZM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE ZM_RPWR(MA,IVAL,JVAL,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      INTEGER IVAL,JVAL
      CALL ZMRPWR(MA%MZM,IVAL,JVAL,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_SET(NPREC)
      INTEGER NPREC
      CALL ZMSET(NPREC)
   END SUBROUTINE

   SUBROUTINE ZM_SIN(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMSIN(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_SINH(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMSINH(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_SQR(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMSQR(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_SQRT(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMSQRT(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_ST2M(STRING,MA)
      USE FMZM
      TYPE ( ZM ) MA
      CHARACTER(*) :: STRING
      CALL ZMST2M(STRING,MA%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_SUB(MA,MB,MC)
      USE FMZM
      TYPE ( ZM ) MA,MB,MC
      CALL ZMSUB(MA%MZM,MB%MZM,MC%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_TAN(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMTAN(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_TANH(MA,MB)
      USE FMZM
      TYPE ( ZM ) MA,MB
      CALL ZMTANH(MA%MZM,MB%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_WRIT(KWRITE,MA)
      USE FMZM
      INTEGER KWRITE
      TYPE ( ZM ) MA
      CALL ZMWRIT(KWRITE,MA%MZM)
   END SUBROUTINE

   SUBROUTINE ZM_Z2M(ZVAL,MA)
      USE FMZM
      TYPE ( ZM ) MA
      COMPLEX ZVAL
      CALL ZMZ2M(ZVAL,MA%MZM)
   END SUBROUTINE

   SUBROUTINE FM_BERN(N,MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      INTEGER N
      CALL FMBERN(N,MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_BETA(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMBETA(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_COMB(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMCOMB(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_EULR(MA)
      USE FMZM
      TYPE ( FM ) MA
      CALL FMEULR(MA%MFM)
   END SUBROUTINE

   SUBROUTINE FM_FACT(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMFACT(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_GAM(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMGAM(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_IBTA(MA,MB,MC,MD)
      USE FMZM
      TYPE ( FM ) MA,MB,MC,MD
      CALL FMIBTA(MA%MFM,MB%MFM,MC%MFM,MD%MFM)
   END SUBROUTINE

   SUBROUTINE FM_IGM1(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMIGM1(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_IGM2(MA,MB,MC)
      USE FMZM
      TYPE ( FM ) MA,MB,MC
      CALL FMIGM2(MA%MFM,MB%MFM,MC%MFM)
   END SUBROUTINE

   SUBROUTINE FM_LNGM(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMLNGM(MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_PGAM(N,MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      INTEGER N
      CALL FMPGAM(N,MA%MFM,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_POCH(MA,N,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      INTEGER N
      CALL FMPOCH(MA%MFM,N,MB%MFM)
   END SUBROUTINE

   SUBROUTINE FM_PSI(MA,MB)
      USE FMZM
      TYPE ( FM ) MA,MB
      CALL FMPSI(MA%MFM,MB%MFM)
   END SUBROUTINE
SHAR_EOF
fi # end of overwriting check
if test -f 'FMSAVE.f90'
then
	echo shar: will not over-write existing file "'FMSAVE.f90'"
else
cat << "SHAR_EOF" > 'FMSAVE.f90'
   MODULE FMVALS

!  These are the global and saved variables used by the FM and ZM packages.
!  See the User's Manual in the ReadMe file for further description of some
!  of these variables.

!  They are initialized assuming the program will run on a 32-bit computer
!  with variables in FM.f having names beginning with 'M' being declared
!  as having 64-bit representations (DOUBLE PRECISION).

!  For a machine with a different architecture, or for setting the precision
!  level to a different value, CALL FMSET(NPREC) before doing any multiple
!  precision operations.  FMSET tries to initialize the variables to the
!  best values for the given machine.  To have the values chosen by FMSET
!  written on unit KW, CALL FMVARS.

!  Base and precision will be set to give slightly more than 50 decimal
!  digits of precision, giving the user 50 significant digits of precision
!  along with several base ten guard digits.

!  MBASE is set to 10**7.
!  JFORM1 and JFORM2 are set to 1PE format displaying 50 significant digits.

!  The trace option is set off.
!  The mode for angles in trig functions is set to radians.
!  The rounding mode is set to symmetric rounding (to nearest), with the
!  option for perfect rounding off.
!  Warning error message level is set to 1.
!  Cancellation error monitor is set off.
!  Screen width for output is set to 80 columns.
!  The exponent character for FM output is set to 'M'.
!  Debug error checking is set off.

!  KW, the unit number for all FM output, is set to 6.

!  The size of all arrays is controlled by defining two parameters:
!  NDIGMX is the maximum value the user can set NDIG,
!  NBITS  is an upper bound for the number of bits used to represent
!         integers in an M-variable word.

      INTEGER, PARAMETER :: NDIGMX = 55
! Integer initialization
!      INTEGER, PARAMETER :: NDIGMX = 80
      INTEGER, PARAMETER :: NBITS  = 64

      INTEGER, PARAMETER :: LPACK  = (NDIGMX+1)/2 + 1
      INTEGER, PARAMETER :: LUNPCK = (11*NDIGMX)/5 + 30
      INTEGER, PARAMETER :: LMWA   = 2*LUNPCK
      INTEGER, PARAMETER :: LJSUMS = 8*(LUNPCK+3)
      INTEGER, PARAMETER :: LMBUFF = ((LUNPCK+4)*(NBITS-1)*301)/2000 + 6

!             KW is the unit number for standard output from the
!                FM package.  This includes trace output and error
!                messages.

      INTEGER, SAVE :: KW = 6

!             MAXINT should be set to a very large integer, possibly
!                    the largest representable integer for the current
!                    machine.  For most 32-bit machines, MAXINT is set
!                    to  2**53 - 1 = 9.007D+15  when double precision
!                    arithmetic is used for M-variables.  Using integer
!                    M-variables usually gives MAXINT = 2**31 - 1 =
!                    2147483647.
!                    Setting MAXINT to a smaller number is ok, but this
!                    unnecessarily restricts the permissible range of
!                    MBASE and MXEXP.

      REAL (KIND(1.0D0)), SAVE :: MAXINT = 9007199254740991.0D0
! Integer initialization
!      INTEGER, SAVE :: MAXINT = 2147483647

!             INTMAX is a large value close to the overflow threshold
!                    for integer variables.  It is usually 2**31 - 1
!                    for machines with 32-bit integer arithmetic.

      INTEGER, SAVE :: INTMAX = 2147483647

!             DPMAX should be set to a value near the machine's double
!                   precision overflow threshold, so that DPMAX and
!                   1.0D0/DPMAX are both representable in double
!                   precision.

      DOUBLE PRECISION, SAVE :: DPMAX = 1.797D+308/5.0D0

!             SPMAX should be set to a value near the machine's single
!                   precision overflow threshold, so that 1.01*SPMAX
!                   and 1.0/SPMAX are both representable in single
!                   precision.

      REAL, SAVE :: SPMAX = 3.40E+38/5.0

!             NDG2MX is the maximum value for NDIG that can be used
!                    internally.  FM routines may raise NDIG above
!                    NDIGMX temporarily, to compute correctly
!                    rounded results.
!                    In the definition of LUNPCK, the '11/5' condition
!                    allows for carrying at least NDIG guard digits
!                    when the option for perfect rounding is selected.
!                    The '+ 30' condition allows for the need to carry
!                    many guard digits when using a small base like 2.

      INTEGER, PARAMETER :: NDG2MX = LUNPCK - 2

!             MXBASE is the maximum value for MBASE.

      REAL (KIND(1.0D0)), SAVE :: MXBASE = 94906265.0D0
! Integer initialization
!      INTEGER, SAVE :: MXBASE = 46340

!             MBASE is the currently used base for arithmetic.

      REAL (KIND(1.0D0)), SAVE :: MBASE = 1.0D7
! Integer initialization
!      INTEGER, SAVE :: MBASE = 10000

!             NDIG is the number of digits currently being carried.

      INTEGER, SAVE :: NDIG = 9
! Integer initialization
!      INTEGER, SAVE :: NDIG = 14

!             KFLAG is the flag for error conditions.

      INTEGER, SAVE :: KFLAG = 0

!             NTRACE is the trace switch.  Default is no printing.

      INTEGER, SAVE :: NTRACE = 0

!             LVLTRC is the trace level.  Default is to trace only
!                    routines called directly by the user.

      INTEGER, SAVE :: LVLTRC = 1

!             NCALL is the call stack pointer.

      INTEGER, SAVE :: NCALL = 0

!             NAMEST is the call stack.

      INTEGER, PRIVATE :: I
      CHARACTER(6), SAVE :: NAMEST(0:50) = (/ ('MAIN  ' , I = 0, 50) /)

!             Some constants that are often needed are stored with the
!             maximum precision to which they have been computed in the
!             currently used base.  This speeds up the trig, log, power,
!             and exponential functions.

!             NDIGPI is the number of digits available in the currently
!                    stored value of pi (MPISAV).

      INTEGER, SAVE :: NDIGPI = 0

!             MBSPI is the value of MBASE for the currently stored
!                   value of pi.

      REAL (KIND(1.0D0)), SAVE :: MBSPI = 0.0D0
! Integer initialization
!      INTEGER, SAVE :: MBSPI = 0

!             NDIGE is the number of digits available in the currently
!                   stored value of e (MESAV).

      INTEGER, SAVE :: NDIGE = 0

!             MBSE is the value of MBASE for the currently stored
!                  value of e.

      REAL (KIND(1.0D0)), SAVE :: MBSE = 0.0D0
! Integer initialization
!      INTEGER, SAVE :: MBSE = 0

!             NDIGLB is the number of digits available in the currently
!                    stored value of LN(MBASE) (MLBSAV).

      INTEGER, SAVE :: NDIGLB = 0

!             MBSLB is the value of MBASE for the currently stored
!                   value of LN(MBASE).

      REAL (KIND(1.0D0)), SAVE :: MBSLB = 0.0D0
! Integer initialization
!      INTEGER, SAVE :: MBSLB = 0

!             NDIGLI is the number of digits available in the currently
!                    stored values of the four logarithms used by FMLNI
!                    MLN1 - MLN4.

      INTEGER, SAVE :: NDIGLI = 0

!             MBSLI is the value of MBASE for the currently stored
!                   values of MLN1 - MLN4.

      REAL (KIND(1.0D0)), SAVE :: MBSLI = 0.0D0
! Integer initialization
!      INTEGER, SAVE :: MBSLI = 0

!             MXEXP  is the current maximum exponent.
!             MXEXP2 is the internal maximum exponent.  This is used to
!                    define the overflow and underflow thresholds.
!
!             These values are chosen so that FM routines can raise the
!             overflow/underflow limit temporarily while computing
!             intermediate results, and so that EXP(INTMAX) is greater
!             than MXBASE**(MXEXP2+1).
!
!             The overflow threshold is MBASE**(MXEXP+1), and the
!             underflow threshold is MBASE**(-MXEXP-1).
!             This means the valid exponents in the first word of an FM
!             number can range from -MXEXP to MXEXP+1 (inclusive).

      REAL (KIND(1.0D0)), SAVE :: MXEXP  =  58455923.0D0
! Integer initialization
!      INTEGER, SAVE :: MXEXP = 99940964

      REAL (KIND(1.0D0)), SAVE :: MXEXP2 = 117496405.0D0
! Integer initialization
!      INTEGER, SAVE :: MXEXP2 = 200881337

!             KACCSW is a switch used to enable cancellation error
!                    monitoring.  Routines where cancellation is
!                    not a problem run faster by skipping the
!                    cancellation monitor calculations.
!                    KACCSW = 0 means no error monitoring,
!                           = 1 means error monitoring is done.

      INTEGER, SAVE :: KACCSW = 0

!             MEXPUN is the exponent used as a special symbol for
!                    underflowed results.

      REAL (KIND(1.0D0)), SAVE :: MEXPUN = -118671369.0D0
! Integer initialization
!      INTEGER, SAVE :: MEXPUN = -202890150

!             MEXPOV is the exponent used as a special symbol for
!                    overflowed results.

      REAL (KIND(1.0D0)), SAVE :: MEXPOV = 118671369.0D0
! Integer initialization
!      INTEGER, SAVE :: MEXPOV = 202890150

!             MUNKNO is the exponent used as a special symbol for
!                    unknown FM results (1/0, SQRT(-3.0), ...).

      REAL (KIND(1.0D0)), SAVE :: MUNKNO = 119858082.0D0
! Integer initialization
!      INTEGER, SAVE :: MUNKNO = 204919051

!             RUNKNO is returned from FM to real or double conversion
!                    routines when no valid result can be expressed in
!                    real or double precision.  On systems that provide
!                    a value for undefined results (e.g., Not A Number)
!                    setting RUNKNO to that value is reasonable.  On
!                    other systems set it to a value that is likely to
!                    make any subsequent results obviously wrong that
!                    use it.  In either case a KFLAG = -4 condition is
!                    also returned.

      REAL, SAVE :: RUNKNO = -1.01*(3.40E+38/3.0)

!             IUNKNO is returned from FM to integer conversion routines
!                    when no valid result can be expressed as a one word
!                    integer.  KFLAG = -4 is also set.

      INTEGER, SAVE :: IUNKNO = -117496405

!             JFORM1 indicates the format used by FMOUT.

      INTEGER, SAVE :: JFORM1 = 1

!             JFORM2 indicates the number of digits used in FMOUT.

      INTEGER, SAVE :: JFORM2 = 50

!             KRAD = 1 indicates that trig functions use radians,
!                  = 0 means use degrees.

      INTEGER, SAVE :: KRAD = 1

!             KWARN = 0 indicates that no warning message is printed
!                       and execution continues when UNKNOWN or another
!                       exception is produced.
!                   = 1 means print a warning message and continue.
!                   = 2 means print a warning message and stop.

      INTEGER, SAVE :: KWARN = 1

!             KROUND =  1  causes all results to be rounded to the
!                          nearest FM number, or to the value with
!                          an even last digit if the result is halfway
!                          between two FM numbers.
!                    =  0  causes all results to be rounded toward zero
!                          (chopped).
!                    = -1  causes all results to be rounded toward minus
!                          infinity.
!                    =  2  causes all results to be rounded toward plus
!                          infinity.
!                    Regardless of KROUND, when an FM function is called
!                    all intermediate operations are rounded to nearest.
!                    Only the final result returned to the user is rounded
!                    according to KROUND.

      INTEGER, SAVE :: KROUND = 1

!             KRPERF = 1  causes more guard digits to be used, to get
!                         perfect rounding in the mode set by KROUND.
!                         This slows execution speed.
!                    = 0  causes a smaller number of guard digits used,
!                         to give nearly perfect rounding.  This number
!                         is chosen so that the last intermediate result
!                         should have error less than 0.001 unit in the
!                         last place of the final rounded result.

      INTEGER, SAVE :: KRPERF = 0

!             KSWIDE defines the maximum screen width to be used for
!                    all unit KW output.

      INTEGER, SAVE :: KSWIDE = 80

!             KESWCH = 1   causes input to FMINP with no digits before
!                          the exponent letter to be treated as if there
!                          were a leading '1'.  This is sometimes better
!                          for interactive input:  'E7' converts to
!                          10.0**7.
!                    = 0   causes a leading zero to be assumed.  This
!                          gives compatibility with Fortran:  'E7'
!                          converts to 0.0.

      INTEGER, SAVE :: KESWCH = 1

!             CMCHAR defines the exponent letter to be used for
!                    FM variable output from FMOUT, as in 1.2345M+678.
!                    Change it to 'E' for output to be read by a
!                    non-FM program.

      CHARACTER, SAVE :: CMCHAR = 'M'

!             KSUB is an internal flag set during subtraction so that
!                  the addition routine will negate its second argument.

      INTEGER, SAVE :: KSUB = 0

!             JRSIGN is an internal flag set during arithmetic operations
!                    so that the rounding routine will know the sign of the
!                    final result.

      INTEGER, SAVE :: JRSIGN = 0

!             KDEBUG = 0   Error checking is not done for valid input
!                          arguments and parameters like NDIG and MBASE
!                          upon entry to each routine.
!                    = 1   Error checking is done.

      INTEGER, SAVE :: KDEBUG = 0

!             LHASH is a flag variable used to indicate when to initialize
!                   two hash tables that are used for character look-up
!                   during input conversion.  LHASH = 1 means that the tables
!                   have been built.
!             LHASH1 and LHASH2 are the array dimensions of the tables.
!             KHASHT and KHASHV are the two tables.

      INTEGER, SAVE :: LHASH = 0
      INTEGER, PARAMETER :: LHASH1 =   0
      INTEGER, PARAMETER :: LHASH2 = 256
      INTEGER, SAVE :: KHASHT(LHASH1:LHASH2),KHASHV(LHASH1:LHASH2)

!             DPEPS is the approximate machine precision.

      DOUBLE PRECISION, SAVE :: DPEPS = 2.220446049250313D-16

!             Saved constants that depend on MBASE.

      REAL (KIND(1.0D0)), SAVE :: MBLOGS = 1.0D7
! Integer initialization
!      INTEGER, SAVE :: MBLOGS = 0
!             (Setting MBLOGS to zero here will cause the other variables that
!              depend on MBASE to automatically be defined when the first FM
!              operation is done.)

      REAL, SAVE :: ALOGMB = 1.611810E+1
      REAL, SAVE :: ALOGM2 = 2.325350E+1
      REAL, SAVE :: ALOGMX = 3.673680E+1
      REAL, SAVE :: ALOGMT = 7.0E0

      INTEGER, SAVE :: NGRD21 = 1
      INTEGER, SAVE :: NGRD52 = 2
      INTEGER, SAVE :: NGRD22 = 2
      REAL (KIND(1.0D0)), SAVE :: MEXPAB = 2.3499281D+7
! Integer initialization
!      INTEGER, SAVE :: MEXPAB = 23499281

      DOUBLE PRECISION, SAVE :: DLOGMB = 1.611809565095832D+1
      DOUBLE PRECISION, SAVE :: DLOGTN = 2.302585092994046D+0
      DOUBLE PRECISION, SAVE :: DLOGTW = 6.931471805599453D-1
      DOUBLE PRECISION, SAVE :: DPPI   = 3.141592653589793D+0
      DOUBLE PRECISION, SAVE :: DLOGTP = 1.837877066409345D+0
      DOUBLE PRECISION, SAVE :: DLOGPI = 1.144729885849400D+0
      DOUBLE PRECISION, SAVE :: DLOGEB = 2.236222824932432D+0

      REAL (KIND(1.0D0)), SAVE :: MBASEL = 0.0D0
! Integer initialization
!      INTEGER, SAVE :: MBASEL = 0
      REAL (KIND(1.0D0)), SAVE :: MBASEN = 0.0D0
! Integer initialization
!      INTEGER, SAVE :: MBASEN = 0

      INTEGER, SAVE :: NDIGL = 0
      INTEGER, SAVE :: NDIGN = 0
      INTEGER, SAVE :: NGUARL = 0
      INTEGER, SAVE :: N21
      INTEGER, SAVE :: NGRDN

!             These variables are used by FM_RANDOM_NUMBER.
!             MBRAND is the base used for the random number arithmetic.
!                    It needs to remain the same even if the user changes MBASE.

      REAL (KIND(1.0D0)), SAVE :: MBRAND = 1.0D7
! Integer initialization
!      INTEGER, SAVE :: MBRAND = 10000

      REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPCK) :: MRNX,MRNA,MRNM,MRNC
      INTEGER, SAVE :: START_RANDOM_SEQUENCE = -1

!             Work areas for temporary FM calculations.

      REAL (KIND(1.0D0)), SAVE, DIMENSION(1:LMWA) :: MWA,MWD,MWE
      REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPCK) ::           &
                        MPA,MPB,MPC,MPD,MPMA,MPMB,                &
                        MLV2,MLV3,MLV4,MLV5,                      &
                        M01,M02,M03,M04,M05,M06,M07,M08,M09,M10,  &
                        M11,M12,M13,M14,M15,M16,M17,M18,M19,M20,  &
                        M21,M22,M23,M24,M25,M26,M27,M28,M29,M30,  &
                        M31,M32,M33,M34,M35,M36,M37,M38,M39,M40,  &
                        M41,M42,M43,M44,M45
      REAL (KIND(1.0D0)), SAVE :: MJSUMS(-1:LJSUMS)
      INTEGER, SAVE :: NDIGMX_BASE = 0
      CHARACTER, SAVE :: CMBUFF(LMBUFF)

!             Saved FM constants.

      REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPCK) :: MPISAV,MESAV,  &
                          MLBSAV,MLN1,MLN2,MLN3,MLN4

!             Set JFORMZ to ' 1.23 + 4.56 i ' format.

      INTEGER, SAVE :: JFORMZ = 1

!             Set JPRNTZ to print real and imaginary parts on one
!             line whenever possible.

      INTEGER, SAVE :: JPRNTZ = 1

!             These arrays are work areas for temporary ZM calculations.

      INTEGER, PARAMETER :: LPACKZ = 2*LPACK+2
      INTEGER, PARAMETER :: LUNPKZ = 2*LUNPCK+2
      INTEGER, PARAMETER :: KPTIMP = LPACK+1
      INTEGER, PARAMETER :: KPTIMU = LUNPCK+1
      REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPKZ) :: MZ01,MZ02,  &
                          MZ03,MZ04,MZ05,MZ06,MZ07,MZ08,MPX,MPY,MPZ
      INTEGER, PARAMETER :: LMBUFZ = 2*LMBUFF+10
      CHARACTER, SAVE, DIMENSION(LMBUFZ) :: CMBUFZ

!             MBERN  is the array used to save Bernoulli numbers so they
!                    do not have to be re-computed on subsequent calls.
!             MBSBRN is the value of MBASE for the currently saved
!                    Bernoulli numbers.

      REAL (KIND(1.0D0)), SAVE :: MBSBRN = 0.0D0
! Integer initialization
!      INTEGER, SAVE :: MBSBRN = 0

!             NWDBRN is the total number of words used for the saved
!                    Bernoulli numbers.

      INTEGER, SAVE :: NWDBRN = 0

!             NUMBRN is the number of the largest Bernoulli number
!                    saved using base MBSBRN.

      INTEGER, SAVE :: NUMBRN = 0

!  LMBERN is the size of the array MBERN for saving Bernoulli numbers.

      INTEGER, PARAMETER :: LMBERN = 250000
      REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LMBERN) :: MBERN

!             B(2N) starts in MBERN(NPTBRN(N)) for 2N >= 28.
!             NPTBRN(N) is -1 if B(2N) has not been computed
!             previously.

      INTEGER, SAVE :: NPTBRN(LMBERN/10) = (/ (-1 , I = 1, LMBERN/10) /)

!             M_EULER     is the saved value of Euler's constant.
!             M_GAMMA_MA  is the last input value to FMGAM, and
!             M_GAMMA_MB  is the corresponding output value.
!             M_LN_2PI    holds the saved value of LN(2*pi).

    REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPCK) ::  &
                        M_EULER,M_GAMMA_MA,M_GAMMA_MB,M_LN_2PI

!             MBSGAM is the value of MBASE used in the currently stored
!                    value of M_GAMMA_MA and M_GAMMA_MB.
!             NDGGAM is the maximum NDIG used in the currently stored
!                    value of M_GAMMA_MA and M_GAMMA_MB.

      REAL (KIND(1.0D0)), SAVE :: MBSGAM = 0.0D0
! Integer initialization
!      INTEGER, SAVE :: MBSGAM = 0

      INTEGER, SAVE :: NDGGAM = 0

!             MBS2PI is the value of MBASE used in the currently stored
!                    value of LN(2*pi).
!             NDG2PI is the maximum NDIG used in the currently stored
!                    value of LN(2*pi).

      REAL (KIND(1.0D0)), SAVE :: MBS2PI = 0.0D0
! Integer initialization
!      INTEGER, SAVE :: MBS2PI = 0

      INTEGER, SAVE :: NDG2PI = 0

!             MBSEUL is the value of MBASE used in the currently stored
!                    value of M_EULER.
!             NDGEUL is the maximum NDIG used in the currently stored
!                    value of M_EULER.

      REAL (KIND(1.0D0)), SAVE :: MBSEUL = 0.0D0
! Integer initialization
!      INTEGER, SAVE :: MBSEUL = 0

      INTEGER, SAVE :: NDGEUL = 0

!             MRETRY is used to detect convergence in some cases where
!                    cancellation error forces a retry.

      REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPCK) :: MRETRY

   END MODULE
SHAR_EOF
fi # end of overwriting check
if test -f 'FMZM90.f90'
then
	echo shar: will not over-write existing file "'FMZM90.f90'"
else
cat << "SHAR_EOF" > 'FMZM90.f90'
 MODULE FMZM_1

!  FMZM 1.2                        David M. Smith

!  This module extends the definition of Fortran-90 arithmetic and function
!  operations so they also apply to multiple precision numbers, using version
!  1.2 of FM.
!  There are three multiple precision data types:
!     FM  (multiple precision real)
!     IM  (multiple precision integer)
!     ZM  (multiple precision complex)

!  Some of the interface routines assume that the precision chosen in the
!  calling program (using FMSET) represents more significant digits than does
!  the machine's double precision.

!  Most of the functions defined in this module are multiple precision versions
!  of standard Fortran-90 functions.  In addition, there are functions for
!  direct conversion, formatting, and some mathematical special functions.

!  TO_FM is a function for converting other types of numbers to type FM.  Note
!  that TO_FM(3.12) converts the REAL constant to FM, but it is accurate only
!  to single precision.  TO_FM(3.12D0) agrees with 3.12 to double precision
!  accuracy, and TO_FM('3.12') or TO_FM(312)/TO_FM(100) agrees to full FM
!  accuracy.

!  TO_IM converts to type IM, and TO_ZM converts to type ZM.

!  Functions are also supplied for converting the three multiple precision types
!  to the other numeric data types:
!     TO_INT   converts to machine precision integer
!     TO_SP    converts to single precision
!     TO_DP    converts to double precision
!     TO_SPZ   converts to single precision complex
!     TO_DPZ   converts to double precision complex

!  WARNING:   When multiple precision type declarations are inserted in an
!             existing program, take care in converting functions like DBLE(X),
!             where X has been declared as a multiple precision type.  If X
!             was single precision in the original program, then replacing
!             the DBLE(X) by TO_DP(X) in the new version could lose accuracy.
!             For this reason, the Fortran type-conversion functions defined
!             in this module assume that results should be multiple precision
!             whenever inputs are.  Examples:
!             DBLE(TO_FM('1.23E+123456')) is type FM
!             REAL(TO_FM('1.23E+123456')) is type FM
!             REAL(TO_ZM('3.12+4.56i'))   is type FM   = TO_FM('3.12')
!             INT(TO_FM('1.23'))          is type IM   = TO_IM(1)
!             INT(TO_IM('1E+23'))         is type IM
!             CMPLX(TO_FM('1.23'),TO_FM('4.56')) is type ZM

!  Programs using this module may sometimes need to call FM, IM, or ZM routines
!  directly.  This is normally the case when routines are needed that are not
!  Fortran-90 intrinsics, such as the formatting subroutine FMFORM.  In a
!  program using this module, suppose MAFM has been declared with
!  TYPE ( FM ) MAFM.  To use the routine FMFORM, which expects the second
!  argument to be an array and not a derived type, the call would have to be
!  CALL FMFORM('F65.60',MAFM%MFM,ST1) so that the array contained in MAFM is
!  passed.

!  As an alternative so the user can refer directly to the FM-, IM-, and ZM-type
!  variables and avoid the cumbersome "%MFM" suffixes, the FM package provides a
!  collection of interface routines to supply any needed argument conversions.
!  For each FM, IM, and ZM routine that is designed to be called by the user,
!  there is also a version that assumes any multiple-precision arguments are
!  derived types instead of arrays.  Each interface routine has the same name as
!  the original with an underscore after the first two letters of the routine
!  name.  To convert the number to a character string with F65.60 format, use
!  CALL FM_FORM('F65.60',MAFM,ST1) if MAFM is of TYPE ( FM ), or use
!  CALL FMFORM('F65.60',MA,ST1) if MA is declared as an array.  All the routines
!  shown below may be used this way.

!  For each of the operations =,  == ,  /= ,  < ,  <= ,  > ,  >= , +, -, *, /,
!  and **, the interface module defines all mixed mode variations involving one
!  of the three multiple precision derived types and another argument having one
!  of the types: { integer, real, double, complex, complex double, FM, IM, ZM }.
!  So mixed mode expressions such as
!        MAFM = 12
!        MAFM = MAFM + 1
!        IF (ABS(MAFM) > 1.0D-23) THEN
!  are handled correctly.

!  Not all the named functions are defined for all three multiple precision
!  derived types, so the list below shows which can be used.  The labels "real",
!  "integer", and "complex" refer to types FM, IM, and ZM respectively, "string"
!  means the function accepts character strings (e.g., TO_FM('3.45')), and
!  "other" means the function can accept any of the machine precision data types
!  integer, real, double, complex, or complex double.  For functions that accept
!  two or more arguments, like ATAN2 or MAX, all the arguments must be of the
!  same type.


!  AVAILABLE OPERATIONS:

!     =
!     +
!     -
!     *
!     /
!     **
!     ==
!     /=
!     <
!     <=
!     >
!     >=
!     ABS          real    integer    complex
!     ACOS         real               complex
!     AIMAG                           complex
!     AINT         real               complex
!     ANINT        real               complex
!     ASIN         real               complex
!     ATAN         real               complex
!     ATAN2        real
!     BTEST                integer
!     CEILING      real               complex
!     CMPLX        real    integer
!     CONJ                            complex
!     COS          real               complex
!     COSH         real               complex
!     DBLE         real    integer    complex
!     DIGITS       real    integer    complex
!     DIM          real    integer
!     DINT         real               complex
!     DOTPRODUCT   real    integer    complex
!     EPSILON      real
!     EXP          real               complex
!     EXPONENT     real
!     FLOOR        real    integer    complex
!     FRACTION     real               complex
!     HUGE         real    integer    complex
!     INT          real    integer    complex
!     LOG          real               complex
!     LOG10        real               complex
!     MATMUL       real    integer    complex
!     MAX          real    integer
!     MAXEXPONENT  real
!     MIN          real    integer
!     MINEXPONENT  real
!     MOD          real    integer
!     MODULO       real    integer
!     NEAREST      real
!     NINT         real    integer    complex
!     PRECISION    real               complex
!     RADIX        real    integer    complex
!     RANGE        real    integer    complex
!     REAL         real    integer    complex
!     RRSPACING    real
!     SCALE        real               complex
!     SETEXPONENT  real
!     SIGN         real    integer
!     SIN          real               complex
!     SINH         real               complex
!     SPACING      real
!     SQRT         real               complex
!     TAN          real               complex
!     TANH         real               complex
!     TINY         real    integer    complex
!     TO_FM        real    integer    complex    string    other
!     TO_IM        real    integer    complex    string    other
!     TO_ZM        real    integer    complex    string    other
!     TO_INT       real    integer    complex
!     TO_SP        real    integer    complex
!     TO_DP        real    integer    complex
!     TO_SPZ       real    integer    complex
!     TO_DPZ       real    integer    complex

!  Some other functions are defined that do not correspond to machine precision
!  intrinsic functions.  These include formatting functions, integer modular
!  functions and GCD, and the Gamma function and its related functions.
!  N below is a machine precision integer, J1, J2, J3 are TYPE (IM), FMT, FMTR,
!  FMTI are character strings, A,B,X are TYPE (FM), and Z is TYPE (ZM).
!  The three formatting functions return a character string containing the
!  formatted number, the three TYPE (IM) functions return a TYPE (IM) result,
!  and the 12 special functions return TYPE (FM) results.

!  Formatting functions:

!     FM_FORMAT(FMT,A)        Put A into FMT (real) format
!     IM_FORMAT(FMT,J1)       Put J1 into FMT (integer) format
!     ZM_FORMAT(FMTR,FMTI,Z)  Put Z into (complex) format, FMTR for the real
!                             part and FMTI for the imaginary part

!     Examples:
!        ST = FM_FORMAT('F65.60',A)
!        WRITE (*,*) ' A = ',TRIM(ST)
!        ST = FM_FORMAT('E75.60',B)
!        WRITE (*,*) ' B = ',ST(1:75)
!        ST = IM_FORMAT('I50',J1)
!        WRITE (*,*) ' J1 = ',ST(1:50)
!        ST = ZM_FORMAT('F35.30','F30.25',Z)
!        WRITE (*,*) ' Z = ',ST(1:70)

!     These functions are used for one-line output.  The returned character
!     strings are of length 200.  Avoid using the formatting function in the
!     write list, as in
!        WRITE (*,*) ' J1 = ',IM_FORMAT('I50',J1)(1:50)
!     since the formatting functions may themselves execute an internal WRITE
!     and that would cause a recursive write reference.

!     For higher precision numbers, the output can be broken onto multiple
!     lines automatically by calling subroutines FM_PRNT, IM_PRNT, ZM_PRNT,
!     or the line breaks can be done by hand after calling one of the
!     subroutines FM_FORM, IM_FORM, ZM_FORM.

!     For ZM_FORMAT the length of the output is 5 more than the sum of the
!     two field widths.

!  Integer functions:

!     GCD(J1,J2)              Greatest Common Divisor of J1 and J2.
!     MULTIPLY_MOD(J1,J2,J3)  J1 * J2 mod J3
!     POWER_MOD(J1,J2,J3)     J1 ** J2 mod J3

!  Special functions:

!     BERNOULLI(N)            Nth Bernoulli number
!     BETA(A,B)               Integral (0 to 1)  t**(A-1) * (1-t)**(B-1)  dt
!     BINOMIAL(A,B)           Binomial Coefficient  A! / ( B! (A-B)! )
!     FACTORIAL(A)            A!
!     GAMMA(A)                Integral (0 to infinity)  t**(A-1) * exp(-t)  dt
!     INCOMPLETE_BETA(X,A,B)  Integral (0 to X)  t**(A-1) * (1-t)**(B-1)  dt
!     INCOMPLETE_GAMMA1(A,X)  Integral (0 to X)  t**(A-1) * exp(-t)  dt
!     INCOMPLETE_GAMMA2(A,X)  Integral (X to infinity)  t**(A-1) * exp(-t)  dt
!     LOG_GAMMA(A)            Ln( GAMMA(A) )
!     POLYGAMMA(N,A)          Nth derivative of Psi(x), evaluated at A
!     POCHHAMMER(A,N)         A*(A+1)*(A+2)*...*(A+N-1)
!     PSI(A)                  Derivative of Ln(Gamma(x)), evaluated at A


!        To keep the FM variables hidden from a program that uses this
!        module, these parameters are set to the same values as the
!        corresponding ones in the FM_VARIABLES module.

    USE FMVALS, ONLY : NDIGMX_2 => NDIGMX
    INTEGER, PARAMETER, PRIVATE :: LUNPCK_2 = (11*NDIGMX_2)/5 + 30
    INTEGER, PARAMETER, PRIVATE :: LUNPKZ_2 = 2*LUNPCK_2+2

    TYPE FM
       REAL (KIND(1.0D0)) :: MFM(-1:LUNPCK_2)
    END TYPE

    TYPE IM
       REAL (KIND(1.0D0)) :: MIM(-1:LUNPCK_2)
    END TYPE

    TYPE ZM
       REAL (KIND(1.0D0)) :: MZM(-1:LUNPKZ_2)
    END TYPE

    REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPCK_2) :: MTFM,MUFM,MVFM
    REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPCK_2) :: MTIM,MUIM,MVIM
    REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPKZ_2) :: MTZM,MUZM,MVZM

 END MODULE FMZM_1

 MODULE FMZM_2
    USE FMZM_1

!   These abbreviations are used for operations
!   on the various data types.

!   I    Integer
!   R    Real
!   D    Double Precision
!   Z    Complex
!   C    Complex Double Precision
!   FM   Multiple precision real
!   IM   Multiple precision integer
!   ZM   Multiple precision complex

!   For example, the "=" procedure FMEQ_FMD is for statements like
!   X = A, where X is type FM and A is type Double Precision.

    INTERFACE ASSIGNMENT (=)
       MODULE PROCEDURE FMEQ_IFM
       MODULE PROCEDURE FMEQ_IIM
       MODULE PROCEDURE FMEQ_IZM
       MODULE PROCEDURE FMEQ_RFM
       MODULE PROCEDURE FMEQ_RIM
       MODULE PROCEDURE FMEQ_RZM
       MODULE PROCEDURE FMEQ_DFM
       MODULE PROCEDURE FMEQ_DIM
       MODULE PROCEDURE FMEQ_DZM
       MODULE PROCEDURE FMEQ_ZFM
       MODULE PROCEDURE FMEQ_ZIM
       MODULE PROCEDURE FMEQ_ZZM
       MODULE PROCEDURE FMEQ_CFM
       MODULE PROCEDURE FMEQ_CIM
       MODULE PROCEDURE FMEQ_CZM
       MODULE PROCEDURE FMEQ_FMI
       MODULE PROCEDURE FMEQ_FMR
       MODULE PROCEDURE FMEQ_FMD
       MODULE PROCEDURE FMEQ_FMZ
       MODULE PROCEDURE FMEQ_FMC
       MODULE PROCEDURE FMEQ_FMFM
       MODULE PROCEDURE FMEQ_FMIM
       MODULE PROCEDURE FMEQ_FMZM
       MODULE PROCEDURE FMEQ_IMI
       MODULE PROCEDURE FMEQ_IMR
       MODULE PROCEDURE FMEQ_IMD
       MODULE PROCEDURE FMEQ_IMZ
       MODULE PROCEDURE FMEQ_IMC
       MODULE PROCEDURE FMEQ_IMFM
       MODULE PROCEDURE FMEQ_IMIM
       MODULE PROCEDURE FMEQ_IMZM
       MODULE PROCEDURE FMEQ_ZMI
       MODULE PROCEDURE FMEQ_ZMR
       MODULE PROCEDURE FMEQ_ZMD
       MODULE PROCEDURE FMEQ_ZMZ
       MODULE PROCEDURE FMEQ_ZMC
       MODULE PROCEDURE FMEQ_ZMFM
       MODULE PROCEDURE FMEQ_ZMIM
       MODULE PROCEDURE FMEQ_ZMZM
    END INTERFACE

    INTERFACE OPERATOR ( == )
       MODULE PROCEDURE FMLEQ_IFM
       MODULE PROCEDURE FMLEQ_IIM
       MODULE PROCEDURE FMLEQ_IZM
       MODULE PROCEDURE FMLEQ_RFM
       MODULE PROCEDURE FMLEQ_RIM
       MODULE PROCEDURE FMLEQ_RZM
       MODULE PROCEDURE FMLEQ_DFM
       MODULE PROCEDURE FMLEQ_DIM
       MODULE PROCEDURE FMLEQ_DZM
       MODULE PROCEDURE FMLEQ_ZFM
       MODULE PROCEDURE FMLEQ_ZIM
       MODULE PROCEDURE FMLEQ_ZZM
       MODULE PROCEDURE FMLEQ_CFM
       MODULE PROCEDURE FMLEQ_CIM
       MODULE PROCEDURE FMLEQ_CZM
       MODULE PROCEDURE FMLEQ_FMI
       MODULE PROCEDURE FMLEQ_FMR
       MODULE PROCEDURE FMLEQ_FMD
       MODULE PROCEDURE FMLEQ_FMZ
       MODULE PROCEDURE FMLEQ_FMC
       MODULE PROCEDURE FMLEQ_FMFM
       MODULE PROCEDURE FMLEQ_FMIM
       MODULE PROCEDURE FMLEQ_FMZM
       MODULE PROCEDURE FMLEQ_IMI
       MODULE PROCEDURE FMLEQ_IMR
       MODULE PROCEDURE FMLEQ_IMD
       MODULE PROCEDURE FMLEQ_IMZ
       MODULE PROCEDURE FMLEQ_IMC
       MODULE PROCEDURE FMLEQ_IMFM
       MODULE PROCEDURE FMLEQ_IMIM
       MODULE PROCEDURE FMLEQ_IMZM
       MODULE PROCEDURE FMLEQ_ZMI
       MODULE PROCEDURE FMLEQ_ZMR
       MODULE PROCEDURE FMLEQ_ZMD
       MODULE PROCEDURE FMLEQ_ZMZ
       MODULE PROCEDURE FMLEQ_ZMC
       MODULE PROCEDURE FMLEQ_ZMFM
       MODULE PROCEDURE FMLEQ_ZMIM
       MODULE PROCEDURE FMLEQ_ZMZM
    END INTERFACE


 CONTAINS

!                                                                   =

   SUBROUTINE FMEQ_IFM(IVAL,MA)
      TYPE ( FM ) MA
      INTEGER IVAL
      INTENT (INOUT) :: IVAL
      INTENT (IN) :: MA
      CALL FMM2I(MA%MFM,IVAL)
   END SUBROUTINE

   SUBROUTINE FMEQ_IIM(IVAL,MA)
      TYPE ( IM ) MA
      INTEGER IVAL
      INTENT (INOUT) :: IVAL
      INTENT (IN) :: MA
      CALL IMM2I(MA%MIM,IVAL)
   END SUBROUTINE

   SUBROUTINE FMEQ_IZM(IVAL,MA)
      TYPE ( ZM ) MA
      INTEGER IVAL
      INTENT (INOUT) :: IVAL
      INTENT (IN) :: MA
      CALL ZMM2I(MA%MZM,IVAL)
   END SUBROUTINE

   SUBROUTINE FMEQ_RFM(R,MA)
      TYPE ( FM ) MA
      REAL R
      INTENT (INOUT) :: R
      INTENT (IN) :: MA
      CALL FMM2SP(MA%MFM,R)
   END SUBROUTINE

   SUBROUTINE FMEQ_RIM(R,MA)
      TYPE ( IM ) MA
      REAL R
      INTENT (INOUT) :: R
      INTENT (IN) :: MA
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMM2SP(MTFM,R)
   END SUBROUTINE

   SUBROUTINE FMEQ_RZM(R,MA)
      TYPE ( ZM ) MA
      REAL R
      INTENT (INOUT) :: R
      INTENT (IN) :: MA
      CALL ZMREAL(MA%MZM,MTFM)
      CALL FMM2SP(MTFM,R)
   END SUBROUTINE

   SUBROUTINE FMEQ_DFM(D,MA)
      TYPE ( FM ) MA
      DOUBLE PRECISION D
      INTENT (INOUT) :: D
      INTENT (IN) :: MA
      CALL FMM2DP(MA%MFM,D)
   END SUBROUTINE

   SUBROUTINE FMEQ_DIM(D,MA)
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTENT (INOUT) :: D
      INTENT (IN) :: MA
      CALL IMM2DP(MA%MIM,D)
   END SUBROUTINE

   SUBROUTINE FMEQ_DZM(D,MA)
      TYPE ( ZM ) MA
      DOUBLE PRECISION D
      INTENT (INOUT) :: D
      INTENT (IN) :: MA
      CALL ZMREAL(MA%MZM,MTFM)
      CALL FMM2DP(MTFM,D)
   END SUBROUTINE

   SUBROUTINE FMEQ_ZFM(Z,MA)
      TYPE ( FM ) MA
      COMPLEX Z
      REAL R
      INTENT (INOUT) :: Z
      INTENT (IN) :: MA
      CALL FMM2SP(MA%MFM,R)
      Z = CMPLX( R , 0.0 )
   END SUBROUTINE

   SUBROUTINE FMEQ_ZIM(Z,MA)
      TYPE ( IM ) MA
      COMPLEX Z
      DOUBLE PRECISION D
      INTENT (INOUT) :: Z
      INTENT (IN) :: MA
      CALL IMM2DP(MA%MIM,D)
      Z = CMPLX( REAL(D) , 0.0 )
   END SUBROUTINE

   SUBROUTINE FMEQ_ZZM(Z,MA)
      TYPE ( ZM ) MA
      COMPLEX Z
      INTENT (INOUT) :: Z
      INTENT (IN) :: MA
      CALL ZMM2Z(MA%MZM,Z)
   END SUBROUTINE

   SUBROUTINE FMEQ_CFM(C,MA)
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      DOUBLE PRECISION D
      INTENT (INOUT) :: C
      INTENT (IN) :: MA
      CALL FMM2DP(MA%MFM,D)
      C = CMPLX( D , 0.0D0 , KIND(0.0D0) )
   END SUBROUTINE

   SUBROUTINE FMEQ_CIM(C,MA)
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      DOUBLE PRECISION D
      INTENT (INOUT) :: C
      INTENT (IN) :: MA
      CALL IMM2DP(MA%MIM,D)
      C = CMPLX( D , 0.0D0 , KIND(0.0D0) )
   END SUBROUTINE

   SUBROUTINE FMEQ_CZM(C,MA)
      TYPE ( ZM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      DOUBLE PRECISION D1,D2
      INTENT (INOUT) :: C
      INTENT (IN) :: MA
      CALL ZMREAL(MA%MZM,MTFM)
      CALL FMM2DP(MTFM,D1)
      CALL ZMIMAG(MA%MZM,MTFM)
      CALL FMM2DP(MTFM,D2)
      C = CMPLX( D1 , D2 , KIND(0.0D0) )
   END SUBROUTINE

   SUBROUTINE FMEQ_FMI(MA,IVAL)
      TYPE ( FM ) MA
      INTEGER IVAL
      INTENT (INOUT) :: MA
      INTENT (IN) :: IVAL
      CALL FMI2M(IVAL,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FMEQ_FMR(MA,R)
      TYPE ( FM ) MA
      REAL R
      INTENT (INOUT) :: MA
      INTENT (IN) :: R
      CALL FMSP2M(R,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FMEQ_FMD(MA,D)
      TYPE ( FM ) MA
      DOUBLE PRECISION D
      INTENT (INOUT) :: MA
      INTENT (IN) :: D
      CALL FMDP2M(D,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FMEQ_FMZ(MA,Z)
      TYPE ( FM ) MA
      COMPLEX Z
      REAL R
      INTENT (INOUT) :: MA
      INTENT (IN) :: Z
      R = REAL(Z)
      CALL FMSP2M(R,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FMEQ_FMC(MA,C)
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      DOUBLE PRECISION D
      INTENT (INOUT) :: MA
      INTENT (IN) :: C
      D = REAL(C,KIND(0.0D0))
      CALL FMDP2M(D,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FMEQ_FMFM(MA,MB)
      TYPE ( FM ) MA,MB
      INTENT (INOUT) :: MA
      INTENT (IN) :: MB
      CALL FMEQ(MB%MFM,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FMEQ_FMIM(MA,MB)
      TYPE ( FM ) MA
      TYPE ( IM ) MB
      INTENT (INOUT) :: MA
      INTENT (IN) :: MB
      CALL IMI2FM(MB%MIM,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FMEQ_FMZM(MA,MB)
      TYPE ( FM ) MA
      TYPE ( ZM ) MB
      INTENT (INOUT) :: MA
      INTENT (IN) :: MB
      CALL ZMREAL(MB%MZM,MA%MFM)
   END SUBROUTINE

   SUBROUTINE FMEQ_IMI(MA,IVAL)
      TYPE ( IM ) MA
      INTEGER IVAL
      INTENT (INOUT) :: MA
      INTENT (IN) :: IVAL
      CALL IMI2M(IVAL,MA%MIM)
   END SUBROUTINE

   SUBROUTINE FMEQ_IMR(MA,R)
      TYPE ( IM ) MA
      INTEGER IVAL
      REAL R
      CHARACTER(25) :: ST
      INTENT (INOUT) :: MA
      INTENT (IN) :: R
      IF (ABS(R) < HUGE(1)) THEN
          IVAL = INT(R)
          CALL IMI2M(IVAL,MA%MIM)
      ELSE
          WRITE (ST,'(E25.16)') R
          CALL IMST2M(ST,MA%MIM)
      ENDIF
   END SUBROUTINE

   SUBROUTINE FMEQ_IMD(MA,D)
      TYPE ( IM ) MA
      INTEGER IVAL
      DOUBLE PRECISION D
      CHARACTER(25) :: ST
      INTENT (INOUT) :: MA
      INTENT (IN) :: D
      IF (ABS(D) < HUGE(1)) THEN
          IVAL = INT(D)
          CALL IMI2M(IVAL,MA%MIM)
      ELSE
          WRITE (ST,'(E25.16)') D
          CALL IMST2M(ST,MA%MIM)
      ENDIF
   END SUBROUTINE

   SUBROUTINE FMEQ_IMZ(MA,Z)
      TYPE ( IM ) MA
      COMPLEX Z
      REAL R
      CHARACTER(25) :: ST
      INTENT (INOUT) :: MA
      INTENT (IN) :: Z
      R = REAL(Z)
      IF (ABS(R) < HUGE(1)) THEN
          IVAL = INT(R)
          CALL IMI2M(IVAL,MA%MIM)
      ELSE
          WRITE (ST,'(E25.16)') R
          CALL IMST2M(ST,MA%MIM)
      ENDIF
   END SUBROUTINE

   SUBROUTINE FMEQ_IMC(MA,C)
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      DOUBLE PRECISION D
      CHARACTER(25) :: ST
      INTENT (INOUT) :: MA
      INTENT (IN) :: C
      D = REAL(C)
      IF (ABS(D) < HUGE(1)) THEN
          IVAL = INT(D)
          CALL IMI2M(IVAL,MA%MIM)
      ELSE
          WRITE (ST,'(E25.16)') D
          CALL IMST2M(ST,MA%MIM)
      ENDIF
   END SUBROUTINE

   SUBROUTINE FMEQ_IMFM(MA,MB)
      TYPE ( IM ) MA
      TYPE ( FM ) MB
      INTENT (INOUT) :: MA
      INTENT (IN) :: MB
      CALL IMFM2I(MB%MFM,MA%MIM)
   END SUBROUTINE

   SUBROUTINE FMEQ_IMIM(MA,MB)
      TYPE ( IM ) MA,MB
      INTENT (INOUT) :: MA
      INTENT (IN) :: MB
      CALL IMEQ(MB%MIM,MA%MIM)
   END SUBROUTINE

   SUBROUTINE FMEQ_IMZM(MA,MB)
      TYPE ( IM ) MA
      TYPE ( ZM ) MB
      INTENT (INOUT) :: MA
      INTENT (IN) :: MB
      CALL ZMREAL(MB%MZM,MTFM)
      CALL IMFM2I(MTFM,MA%MIM)
   END SUBROUTINE

   SUBROUTINE FMEQ_ZMI(MA,IVAL)
      TYPE ( ZM ) MA
      INTEGER IVAL
      INTENT (INOUT) :: MA
      INTENT (IN) :: IVAL
      CALL ZMI2M(IVAL,MA%MZM)
   END SUBROUTINE

   SUBROUTINE FMEQ_ZMR(MA,R)
      TYPE ( ZM ) MA
      REAL R
      COMPLEX Z
      INTENT (INOUT) :: MA
      INTENT (IN) :: R
      Z = CMPLX(R,0.0)
      CALL ZMZ2M(Z,MA%MZM)
   END SUBROUTINE

   SUBROUTINE FMEQ_ZMD(MA,D)
      TYPE ( ZM ) MA
      DOUBLE PRECISION D
      INTENT (INOUT) :: MA
      INTENT (IN) :: D
      CALL FMDP2M(D,MTFM)
      CALL FMDP2M(0.0D0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MA%MZM)
   END SUBROUTINE

   SUBROUTINE FMEQ_ZMZ(MA,Z)
      TYPE ( ZM ) MA
      COMPLEX Z
      INTENT (INOUT) :: MA
      INTENT (IN) :: Z
      CALL ZMZ2M(Z,MA%MZM)
   END SUBROUTINE

   SUBROUTINE FMEQ_ZMC(MA,C)
      TYPE ( ZM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      DOUBLE PRECISION D
      INTENT (INOUT) :: MA
      INTENT (IN) :: C
      D = REAL(C,KIND(0.0D0))
      CALL FMDP2M(D,MTFM)
      D = AIMAG(C)
      CALL FMDP2M(D,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MA%MZM)
   END SUBROUTINE

   SUBROUTINE FMEQ_ZMFM(MA,MB)
      TYPE ( FM ) MB
      TYPE ( ZM ) MA
      INTENT (INOUT) :: MA
      INTENT (IN) :: MB
      CALL FMI2M(0,MTFM)
      CALL ZMCMPX(MB%MFM,MTFM,MA%MZM)
   END SUBROUTINE

   SUBROUTINE FMEQ_ZMIM(MA,MB)
      TYPE ( IM ) MB
      TYPE ( ZM ) MA
      INTENT (INOUT) :: MA
      INTENT (IN) :: MB
      CALL IMI2FM(MB%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MA%MZM)
   END SUBROUTINE

   SUBROUTINE FMEQ_ZMZM(MA,MB)
      TYPE ( ZM ) MA,MB
      INTENT (INOUT) :: MA
      INTENT (IN) :: MB
      CALL ZMEQ(MB%MZM,MA%MZM)
   END SUBROUTINE

!                                                                ==

   FUNCTION FMLEQ_IFM(IVAL,MA)
      LOGICAL FMLEQ_IFM,FMCOMP
      TYPE ( FM ) MA
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      FMLEQ_IFM = FMCOMP(MTFM,'EQ',MA%MFM)
   END FUNCTION

   FUNCTION FMLEQ_IIM(IVAL,MA)
      LOGICAL FMLEQ_IIM,IMCOMP
      TYPE ( IM ) MA
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL IMI2M(IVAL,MTIM)
      FMLEQ_IIM = IMCOMP(MTIM,'EQ',MA%MIM)
   END FUNCTION

   FUNCTION FMLEQ_IZM(IVAL,MA)
      LOGICAL FMLEQ_IZM,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'EQ',MUFM)
      CALL FMI2M(0,MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'EQ',MUFM)
      FMLEQ_IZM = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_RFM(R,MA)
      LOGICAL FMLEQ_RFM,FMCOMP
      TYPE ( FM ) MA
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      FMLEQ_RFM = FMCOMP(MTFM,'EQ',MA%MFM)
   END FUNCTION

   FUNCTION FMLEQ_RIM(R,MA)
      USE FMVALS
      LOGICAL FMLEQ_RIM,FMCOMP
      TYPE ( IM ) MA
      INTEGER KA,NDSAVE
      REAL R
      INTENT (IN) :: R,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLEQ_RIM = FMCOMP(MTFM,'EQ',MUFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLEQ_RZM(R,MA)
      LOGICAL FMLEQ_RZM,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'EQ',MUFM)
      CALL FMI2M(0,MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'EQ',MUFM)
      FMLEQ_RZM = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_DFM(D,MA)
      LOGICAL FMLEQ_DFM,FMCOMP
      TYPE ( FM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      FMLEQ_DFM = FMCOMP(MTFM,'EQ',MA%MFM)
   END FUNCTION

   FUNCTION FMLEQ_DIM(D,MA)
      USE FMVALS
      LOGICAL FMLEQ_DIM,FMCOMP
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTEGER KA,NDSAVE
      INTENT (IN) :: D,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLEQ_DIM = FMCOMP(MTFM,'EQ',MUFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLEQ_DZM(D,MA)
      LOGICAL FMLEQ_DZM,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'EQ',MUFM)
      CALL FMI2M(0,MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'EQ',MUFM)
      FMLEQ_DZM = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_ZFM(Z,MA)
      LOGICAL FMLEQ_ZFM,FMCOMP,L1,L2
      TYPE ( FM ) MA
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL FMSP2M(REAL(Z),MTFM)
      L1 = FMCOMP(MTFM,'EQ',MA%MFM)
      L2 = .TRUE.
      IF (AIMAG(Z) /= 0.0) L2 = .FALSE.
      FMLEQ_ZFM = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_ZIM(Z,MA)
      USE FMVALS
      LOGICAL FMLEQ_ZIM,FMCOMP,L1,L2
      TYPE ( IM ) MA
      COMPLEX Z
      INTEGER KA,NDSAVE
      INTENT (IN) :: Z,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(REAL(Z),MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      L1 = FMCOMP(MTFM,'EQ',MUFM)
      NDIG = NDSAVE
      L2 = .TRUE.
      IF (AIMAG(Z) /= 0.0) L2 = .FALSE.
      FMLEQ_ZIM = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_ZZM(Z,MA)
      LOGICAL FMLEQ_ZZM,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL ZMREAL(MTZM,MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'EQ',MUFM)
      CALL ZMIMAG(MTZM,MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'EQ',MUFM)
      FMLEQ_ZZM = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_CFM(C,MA)
      LOGICAL FMLEQ_CFM,FMCOMP,L1,L2
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      L1 = FMCOMP(MTFM,'EQ',MA%MFM)
      L2 = .TRUE.
      IF (AIMAG(C) /= 0.0) L2 = .FALSE.
      FMLEQ_CFM = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_CIM(C,MA)
      USE FMVALS
      LOGICAL FMLEQ_CIM,FMCOMP,L1,L2
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTEGER KA,NDSAVE
      INTENT (IN) :: C,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      L1 = FMCOMP(MTFM,'EQ',MUFM)
      NDIG = NDSAVE
      L2 = .TRUE.
      IF (AIMAG(C) /= 0.0) L2 = .FALSE.
      FMLEQ_CIM = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_CZM(C,MA)
      LOGICAL FMLEQ_CZM,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'EQ',MUFM)
      CALL FMDP2M(AIMAG(C),MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'EQ',MUFM)
      FMLEQ_CZM = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_FMI(MA,IVAL)
      LOGICAL FMLEQ_FMI,FMCOMP
      TYPE ( FM ) MA
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL FMI2M(IVAL,MTFM)
      FMLEQ_FMI = FMCOMP(MA%MFM,'EQ',MTFM)
   END FUNCTION

   FUNCTION FMLEQ_FMR(MA,R)
      LOGICAL FMLEQ_FMR,FMCOMP
      TYPE ( FM ) MA
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      FMLEQ_FMR = FMCOMP(MA%MFM,'EQ',MTFM)
   END FUNCTION

   FUNCTION FMLEQ_FMD(MA,D)
      LOGICAL FMLEQ_FMD,FMCOMP
      TYPE ( FM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      FMLEQ_FMD = FMCOMP(MA%MFM,'EQ',MTFM)
   END FUNCTION

   FUNCTION FMLEQ_FMZ(MA,Z)
      LOGICAL FMLEQ_FMZ,FMCOMP,L1,L2
      TYPE ( FM ) MA
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL FMSP2M(REAL(Z),MTFM)
      L1 = FMCOMP(MA%MFM,'EQ',MTFM)
      L2 = .TRUE.
      IF (AIMAG(Z) /= 0.0) L2 = .FALSE.
      FMLEQ_FMZ = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_FMC(MA,C)
      LOGICAL FMLEQ_FMC,FMCOMP,L1,L2
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      L1 = FMCOMP(MA%MFM,'EQ',MTFM)
      L2 = .TRUE.
      IF (AIMAG(C) /= 0.0) L2 = .FALSE.
      FMLEQ_FMC = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_FMFM(MA,MB)
      LOGICAL FMLEQ_FMFM,FMCOMP
      TYPE ( FM ) MA,MB
      INTENT (IN) :: MA,MB
      FMLEQ_FMFM = FMCOMP(MA%MFM,'EQ',MB%MFM)
   END FUNCTION

   FUNCTION FMLEQ_FMIM(MA,MB)
      LOGICAL FMLEQ_FMIM,FMCOMP
      TYPE ( FM ) MA
      TYPE ( IM ) MB
      INTENT (IN) :: MA,MB
      CALL FMINT(MA%MFM,MTFM)
      IF (FMCOMP(MA%MFM,'EQ',MTFM)) THEN
          CALL IMI2FM(MB%MIM,MTFM)
          FMLEQ_FMIM = FMCOMP(MA%MFM,'EQ',MTFM)
      ELSE
          FMLEQ_FMIM = .FALSE.
      ENDIF
   END FUNCTION

   FUNCTION FMLEQ_FMZM(MA,MB)
      USE FMVALS
      LOGICAL FMLEQ_FMZM,FMCOMP,L1,L2
      TYPE ( FM ) MA
      TYPE ( ZM ) MB
      INTENT (IN) :: MA,MB
      CALL ZMREAL(MB%MZM,MTFM)
      L1 = FMCOMP(MA%MFM,'EQ',MTFM)
      L2 = .TRUE.
      IF (MB%MZM(KPTIMU+2) /= 0) L2 = .FALSE.
      FMLEQ_FMZM = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_IMI(MA,IVAL)
      LOGICAL FMLEQ_IMI,IMCOMP
      TYPE ( IM ) MA
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL IMI2M(IVAL,MTIM)
      FMLEQ_IMI = IMCOMP(MA%MIM,'EQ',MTIM)
   END FUNCTION

   FUNCTION FMLEQ_IMR(MA,R)
      USE FMVALS
      LOGICAL FMLEQ_IMR,FMCOMP
      TYPE ( IM ) MA
      INTEGER KA,NDSAVE
      REAL R
      INTENT (IN) :: MA,R
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLEQ_IMR = FMCOMP(MUFM,'EQ',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLEQ_IMD(MA,D)
      USE FMVALS
      LOGICAL FMLEQ_IMD,FMCOMP
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,D
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLEQ_IMD = FMCOMP(MUFM,'EQ',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLEQ_IMZ(MA,Z)
      USE FMVALS
      LOGICAL FMLEQ_IMZ,FMCOMP,L1,L2
      TYPE ( IM ) MA
      COMPLEX Z
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,Z
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(REAL(Z),MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      L1 = FMCOMP(MUFM,'EQ',MTFM)
      NDIG = NDSAVE
      L2 = .TRUE.
      IF (AIMAG(Z) /= 0.0) L2 = .FALSE.
      FMLEQ_IMZ = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_IMC(MA,C)
      USE FMVALS
      LOGICAL FMLEQ_IMC,FMCOMP,L1,L2
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,C
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      L1 = FMCOMP(MUFM,'EQ',MTFM)
      NDIG = NDSAVE
      L2 = .TRUE.
      IF (AIMAG(C) /= 0.0) L2 = .FALSE.
      FMLEQ_IMC = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_IMFM(MA,MB)
      LOGICAL FMLEQ_IMFM,FMCOMP
      TYPE ( IM ) MA
      TYPE ( FM ) MB
      INTENT (IN) :: MA,MB
      CALL FMINT(MB%MFM,MTFM)
      IF (FMCOMP(MB%MFM,'EQ',MTFM)) THEN
          CALL IMI2FM(MA%MIM,MTFM)
          FMLEQ_IMFM = FMCOMP(MB%MFM,'EQ',MTFM)
      ELSE
          FMLEQ_IMFM = .FALSE.
      ENDIF
   END FUNCTION

   FUNCTION FMLEQ_IMIM(MA,MB)
      LOGICAL FMLEQ_IMIM,IMCOMP
      TYPE ( IM ) MA,MB
      INTENT (IN) :: MA,MB
      FMLEQ_IMIM = IMCOMP(MA%MIM,'EQ',MB%MIM)
   END FUNCTION

   FUNCTION FMLEQ_IMZM(MA,MB)
      USE FMVALS
      LOGICAL FMLEQ_IMZM,FMCOMP
      TYPE ( IM ) MA
      TYPE ( ZM ) MB
      INTENT (IN) :: MA,MB
      CALL ZMREAL(MB%MZM,MTFM)
      CALL FMINT(MTFM,MUFM)
      IF (FMCOMP(MUFM,'EQ',MTFM).AND.MB%MZM(KPTIMU+2) == 0) THEN
          CALL IMI2FM(MA%MIM,MUFM)
          FMLEQ_IMZM = FMCOMP(MUFM,'EQ',MTFM)
      ELSE
          FMLEQ_IMZM = .FALSE.
      ENDIF
   END FUNCTION

   FUNCTION FMLEQ_ZMI(MA,IVAL)
      USE FMVALS
      LOGICAL FMLEQ_ZMI,FMCOMP
      TYPE ( ZM ) MA
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL ZMREAL(MA%MZM,MTFM)
      CALL FMINT(MTFM,MUFM)
      IF (FMCOMP(MUFM,'EQ',MTFM).AND.MA%MZM(KPTIMU+2) == 0) THEN
          CALL FMI2M(IVAL,MUFM)
          FMLEQ_ZMI = FMCOMP(MTFM,'EQ',MUFM)
      ELSE
          FMLEQ_ZMI = .FALSE.
      ENDIF
   END FUNCTION

   FUNCTION FMLEQ_ZMR(MA,R)
      LOGICAL FMLEQ_ZMR,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'EQ',MUFM)
      CALL FMI2M(0,MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'EQ',MUFM)
      FMLEQ_ZMR = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_ZMD(MA,D)
      LOGICAL FMLEQ_ZMD,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'EQ',MUFM)
      CALL FMI2M(0,MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'EQ',MUFM)
      FMLEQ_ZMD = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_ZMZ(MA,Z)
      LOGICAL FMLEQ_ZMZ,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL ZMREAL(MTZM,MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'EQ',MUFM)
      CALL ZMIMAG(MTZM,MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'EQ',MUFM)
      FMLEQ_ZMZ = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_ZMC(MA,C)
      LOGICAL FMLEQ_ZMC,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'EQ',MUFM)
      CALL FMDP2M(AIMAG(C),MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'EQ',MUFM)
      FMLEQ_ZMC = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_ZMFM(MA,MB)
      USE FMVALS
      LOGICAL FMLEQ_ZMFM,FMCOMP,L1,L2
      TYPE ( FM ) MB
      TYPE ( ZM ) MA
      INTENT (IN) :: MA,MB
      CALL ZMREAL(MA%MZM,MTFM)
      L1 = FMCOMP(MB%MFM,'EQ',MTFM)
      L2 = .TRUE.
      IF (MA%MZM(KPTIMU+2) /= 0) L2 = .FALSE.
      FMLEQ_ZMFM = L1.AND.L2
   END FUNCTION

   FUNCTION FMLEQ_ZMIM(MA,MB)
      USE FMVALS
      LOGICAL FMLEQ_ZMIM,FMCOMP
      TYPE ( IM ) MB
      TYPE ( ZM ) MA
      INTENT (IN) :: MA,MB
      CALL ZMREAL(MA%MZM,MTFM)
      CALL FMINT(MTFM,MUFM)
      IF (FMCOMP(MUFM,'EQ',MTFM).AND.MA%MZM(KPTIMU+2) == 0) THEN
          CALL IMI2FM(MB%MIM,MUFM)
          FMLEQ_ZMIM = FMCOMP(MUFM,'EQ',MTFM)
      ELSE
          FMLEQ_ZMIM = .FALSE.
      ENDIF
   END FUNCTION

   FUNCTION FMLEQ_ZMZM(MA,MB)
      LOGICAL FMLEQ_ZMZM,FMCOMP,L1,L2
      TYPE ( ZM ) MA,MB
      INTENT (IN) :: MA,MB
      CALL ZMREAL(MA%MZM,MTFM)
      CALL ZMREAL(MB%MZM,MUFM)
      L1 = FMCOMP(MTFM,'EQ',MUFM)
      CALL ZMIMAG(MA%MZM,MTFM)
      CALL ZMIMAG(MB%MZM,MUFM)
      L2 = FMCOMP(MTFM,'EQ',MUFM)
      FMLEQ_ZMZM = L1.AND.L2
   END FUNCTION

 END MODULE FMZM_2

 MODULE FMZM_3
    USE FMZM_1

    INTERFACE OPERATOR ( /= )
       MODULE PROCEDURE FMLNE_IFM
       MODULE PROCEDURE FMLNE_IIM
       MODULE PROCEDURE FMLNE_IZM
       MODULE PROCEDURE FMLNE_RFM
       MODULE PROCEDURE FMLNE_RIM
       MODULE PROCEDURE FMLNE_RZM
       MODULE PROCEDURE FMLNE_DFM
       MODULE PROCEDURE FMLNE_DIM
       MODULE PROCEDURE FMLNE_DZM
       MODULE PROCEDURE FMLNE_ZFM
       MODULE PROCEDURE FMLNE_ZIM
       MODULE PROCEDURE FMLNE_ZZM
       MODULE PROCEDURE FMLNE_CFM
       MODULE PROCEDURE FMLNE_CIM
       MODULE PROCEDURE FMLNE_CZM
       MODULE PROCEDURE FMLNE_FMI
       MODULE PROCEDURE FMLNE_FMR
       MODULE PROCEDURE FMLNE_FMD
       MODULE PROCEDURE FMLNE_FMZ
       MODULE PROCEDURE FMLNE_FMC
       MODULE PROCEDURE FMLNE_FMFM
       MODULE PROCEDURE FMLNE_FMIM
       MODULE PROCEDURE FMLNE_FMZM
       MODULE PROCEDURE FMLNE_IMI
       MODULE PROCEDURE FMLNE_IMR
       MODULE PROCEDURE FMLNE_IMD
       MODULE PROCEDURE FMLNE_IMZ
       MODULE PROCEDURE FMLNE_IMC
       MODULE PROCEDURE FMLNE_IMFM
       MODULE PROCEDURE FMLNE_IMIM
       MODULE PROCEDURE FMLNE_IMZM
       MODULE PROCEDURE FMLNE_ZMI
       MODULE PROCEDURE FMLNE_ZMR
       MODULE PROCEDURE FMLNE_ZMD
       MODULE PROCEDURE FMLNE_ZMZ
       MODULE PROCEDURE FMLNE_ZMC
       MODULE PROCEDURE FMLNE_ZMFM
       MODULE PROCEDURE FMLNE_ZMIM
       MODULE PROCEDURE FMLNE_ZMZM
    END INTERFACE

    INTERFACE OPERATOR ( > )
       MODULE PROCEDURE FMLGT_IFM
       MODULE PROCEDURE FMLGT_IIM
       MODULE PROCEDURE FMLGT_RFM
       MODULE PROCEDURE FMLGT_RIM
       MODULE PROCEDURE FMLGT_DFM
       MODULE PROCEDURE FMLGT_DIM
       MODULE PROCEDURE FMLGT_FMI
       MODULE PROCEDURE FMLGT_FMR
       MODULE PROCEDURE FMLGT_FMD
       MODULE PROCEDURE FMLGT_FMFM
       MODULE PROCEDURE FMLGT_FMIM
       MODULE PROCEDURE FMLGT_IMI
       MODULE PROCEDURE FMLGT_IMR
       MODULE PROCEDURE FMLGT_IMD
       MODULE PROCEDURE FMLGT_IMFM
       MODULE PROCEDURE FMLGT_IMIM
    END INTERFACE

 CONTAINS

!                                                                /=

   FUNCTION FMLNE_IFM(IVAL,MA)
      LOGICAL FMLNE_IFM,FMCOMP
      TYPE ( FM ) MA
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      FMLNE_IFM = FMCOMP(MTFM,'NE',MA%MFM)
   END FUNCTION

   FUNCTION FMLNE_IIM(IVAL,MA)
      LOGICAL FMLNE_IIM,IMCOMP
      TYPE ( IM ) MA
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL IMI2M(IVAL,MTIM)
      FMLNE_IIM = IMCOMP(MTIM,'NE',MA%MIM)
   END FUNCTION

   FUNCTION FMLNE_IZM(IVAL,MA)
      LOGICAL FMLNE_IZM,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'NE',MUFM)
      CALL FMI2M(0,MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'NE',MUFM)
      FMLNE_IZM = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_RFM(R,MA)
      LOGICAL FMLNE_RFM,FMCOMP
      TYPE ( FM ) MA
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      FMLNE_RFM = FMCOMP(MTFM,'NE',MA%MFM)
   END FUNCTION

   FUNCTION FMLNE_RIM(R,MA)
      USE FMVALS
      LOGICAL FMLNE_RIM,FMCOMP
      TYPE ( IM ) MA
      REAL R
      INTEGER KA,NDSAVE
      INTENT (IN) :: R,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLNE_RIM = FMCOMP(MTFM,'NE',MUFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLNE_RZM(R,MA)
      LOGICAL FMLNE_RZM,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'NE',MUFM)
      CALL FMI2M(0,MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'NE',MUFM)
      FMLNE_RZM = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_DFM(D,MA)
      LOGICAL FMLNE_DFM,FMCOMP
      TYPE ( FM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      FMLNE_DFM = FMCOMP(MTFM,'NE',MA%MFM)
   END FUNCTION

   FUNCTION FMLNE_DIM(D,MA)
      USE FMVALS
      LOGICAL FMLNE_DIM,FMCOMP
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTEGER KA,NDSAVE
      INTENT (IN) :: D,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLNE_DIM = FMCOMP(MTFM,'NE',MUFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLNE_DZM(D,MA)
      LOGICAL FMLNE_DZM,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'NE',MUFM)
      CALL FMI2M(0,MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'NE',MUFM)
      FMLNE_DZM = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_ZFM(Z,MA)
      LOGICAL FMLNE_ZFM,FMCOMP,L1,L2
      TYPE ( FM ) MA
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL FMSP2M(REAL(Z),MTFM)
      L1 = FMCOMP(MTFM,'NE',MA%MFM)
      L2 = .FALSE.
      IF (AIMAG(Z) /= 0.0) L2 = .TRUE.
      FMLNE_ZFM = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_ZIM(Z,MA)
      USE FMVALS
      LOGICAL FMLNE_ZIM,FMCOMP,L1,L2
      TYPE ( IM ) MA
      INTEGER KA,NDSAVE
      COMPLEX Z
      INTENT (IN) :: Z,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(REAL(Z),MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      L1 = FMCOMP(MTFM,'NE',MUFM)
      NDIG = NDSAVE
      L2 = .FALSE.
      IF (AIMAG(Z) /= 0.0) L2 = .TRUE.
      FMLNE_ZIM = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_ZZM(Z,MA)
      LOGICAL FMLNE_ZZM,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL ZMREAL(MTZM,MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'NE',MUFM)
      CALL ZMIMAG(MTZM,MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'NE',MUFM)
      FMLNE_ZZM = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_CFM(C,MA)
      LOGICAL FMLNE_CFM,FMCOMP,L1,L2
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      L1 = FMCOMP(MTFM,'NE',MA%MFM)
      L2 = .FALSE.
      IF (AIMAG(C) /= 0.0) L2 = .TRUE.
      FMLNE_CFM = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_CIM(C,MA)
      USE FMVALS
      LOGICAL FMLNE_CIM,FMCOMP,L1,L2
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTEGER KA,NDSAVE
      INTENT (IN) :: C,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      L1 = FMCOMP(MTFM,'NE',MUFM)
      NDIG = NDSAVE
      L2 = .FALSE.
      IF (AIMAG(C) /= 0.0) L2 = .TRUE.
      FMLNE_CIM = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_CZM(C,MA)
      LOGICAL FMLNE_CZM,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'NE',MUFM)
      CALL FMDP2M(AIMAG(C),MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'NE',MUFM)
      FMLNE_CZM = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_FMI(MA,IVAL)
      LOGICAL FMLNE_FMI,FMCOMP
      TYPE ( FM ) MA
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL FMI2M(IVAL,MTFM)
      FMLNE_FMI = FMCOMP(MA%MFM,'NE',MTFM)
   END FUNCTION

   FUNCTION FMLNE_FMR(MA,R)
      LOGICAL FMLNE_FMR,FMCOMP
      TYPE ( FM ) MA
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      FMLNE_FMR = FMCOMP(MA%MFM,'NE',MTFM)
   END FUNCTION

   FUNCTION FMLNE_FMD(MA,D)
      LOGICAL FMLNE_FMD,FMCOMP
      TYPE ( FM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      FMLNE_FMD = FMCOMP(MA%MFM,'NE',MTFM)
   END FUNCTION

   FUNCTION FMLNE_FMZ(MA,Z)
      LOGICAL FMLNE_FMZ,FMCOMP,L1,L2
      TYPE ( FM ) MA
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL FMSP2M(REAL(Z),MTFM)
      L1 = FMCOMP(MA%MFM,'NE',MTFM)
      L2 = .FALSE.
      IF (AIMAG(Z) /= 0.0) L2 = .TRUE.
      FMLNE_FMZ = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_FMC(MA,C)
      LOGICAL FMLNE_FMC,FMCOMP,L1,L2
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      L1 = FMCOMP(MA%MFM,'NE',MTFM)
      L2 = .FALSE.
      IF (AIMAG(C) /= 0.0) L2 = .TRUE.
      FMLNE_FMC = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_FMFM(MA,MB)
      LOGICAL FMLNE_FMFM,FMCOMP
      TYPE ( FM ) MA,MB
      INTENT (IN) :: MA,MB
      FMLNE_FMFM = FMCOMP(MA%MFM,'NE',MB%MFM)
   END FUNCTION

   FUNCTION FMLNE_FMIM(MA,MB)
      LOGICAL FMLNE_FMIM,FMCOMP
      TYPE ( FM ) MA
      TYPE ( IM ) MB
      INTENT (IN) :: MA,MB
      CALL FMINT(MA%MFM,MTFM)
      IF (FMCOMP(MA%MFM,'EQ',MTFM)) THEN
          CALL IMI2FM(MB%MIM,MTFM)
          FMLNE_FMIM = FMCOMP(MA%MFM,'NE',MTFM)
      ELSE
          FMLNE_FMIM = .TRUE.
      ENDIF
   END FUNCTION

   FUNCTION FMLNE_FMZM(MA,MB)
      USE FMVALS
      LOGICAL FMLNE_FMZM,FMCOMP,L1,L2
      TYPE ( FM ) MA
      TYPE ( ZM ) MB
      INTENT (IN) :: MA,MB
      CALL ZMREAL(MB%MZM,MTFM)
      L1 = FMCOMP(MA%MFM,'NE',MTFM)
      L2 = .FALSE.
      IF (MB%MZM(KPTIMU+2) /= 0) L2 = .TRUE.
      FMLNE_FMZM = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_IMI(MA,IVAL)
      LOGICAL FMLNE_IMI,IMCOMP
      TYPE ( IM ) MA
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL IMI2M(IVAL,MTIM)
      FMLNE_IMI = IMCOMP(MA%MIM,'NE',MTIM)
   END FUNCTION

   FUNCTION FMLNE_IMR(MA,R)
      USE FMVALS
      LOGICAL FMLNE_IMR,FMCOMP
      TYPE ( IM ) MA
      INTEGER KA,NDSAVE
      REAL R
      INTENT (IN) :: MA,R
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLNE_IMR = FMCOMP(MUFM,'NE',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLNE_IMD(MA,D)
      USE FMVALS
      LOGICAL FMLNE_IMD,FMCOMP
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,D
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLNE_IMD = FMCOMP(MUFM,'NE',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLNE_IMZ(MA,Z)
      USE FMVALS
      LOGICAL FMLNE_IMZ,FMCOMP,L1,L2
      TYPE ( IM ) MA
      INTEGER KA,NDSAVE
      COMPLEX Z
      INTENT (IN) :: MA,Z
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(REAL(Z),MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      L1 = FMCOMP(MUFM,'NE',MTFM)
      NDIG = NDSAVE
      L2 = .FALSE.
      IF (AIMAG(Z) /= 0.0) L2 = .TRUE.
      FMLNE_IMZ = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_IMC(MA,C)
      USE FMVALS
      LOGICAL FMLNE_IMC,FMCOMP,L1,L2
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,C
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      L1 = FMCOMP(MUFM,'NE',MTFM)
      NDIG = NDSAVE
      L2 = .FALSE.
      IF (AIMAG(C) /= 0.0) L2 = .TRUE.
      FMLNE_IMC = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_IMFM(MA,MB)
      LOGICAL FMLNE_IMFM,FMCOMP
      TYPE ( IM ) MA
      TYPE ( FM ) MB
      INTENT (IN) :: MA,MB
      CALL FMINT(MB%MFM,MTFM)
      IF (FMCOMP(MB%MFM,'EQ',MTFM)) THEN
          CALL IMI2FM(MA%MIM,MTFM)
          FMLNE_IMFM = FMCOMP(MB%MFM,'NE',MTFM)
      ELSE
          FMLNE_IMFM = .TRUE.
      ENDIF
   END FUNCTION

   FUNCTION FMLNE_IMIM(MA,MB)
      LOGICAL FMLNE_IMIM,IMCOMP
      TYPE ( IM ) MA,MB
      INTENT (IN) :: MA,MB
      FMLNE_IMIM = IMCOMP(MA%MIM,'NE',MB%MIM)
   END FUNCTION

   FUNCTION FMLNE_IMZM(MA,MB)
      USE FMVALS
      LOGICAL FMLNE_IMZM,FMCOMP
      TYPE ( IM ) MA
      TYPE ( ZM ) MB
      INTENT (IN) :: MA,MB
      CALL ZMREAL(MB%MZM,MTFM)
      CALL FMINT(MTFM,MUFM)
      IF (FMCOMP(MUFM,'EQ',MTFM).AND.MB%MZM(KPTIMU+2) == 0) THEN
          CALL IMI2FM(MA%MIM,MUFM)
          FMLNE_IMZM = FMCOMP(MUFM,'NE',MTFM)
      ELSE
          FMLNE_IMZM = .TRUE.
      ENDIF
   END FUNCTION

   FUNCTION FMLNE_ZMI(MA,IVAL)
      USE FMVALS
      LOGICAL FMLNE_ZMI,FMCOMP
      TYPE ( ZM ) MA
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL ZMREAL(MA%MZM,MTFM)
      CALL FMINT(MTFM,MUFM)
      IF (FMCOMP(MUFM,'EQ',MTFM).AND.MA%MZM(KPTIMU+2) == 0) THEN
          CALL FMI2M(IVAL,MUFM)
          FMLNE_ZMI = FMCOMP(MTFM,'NE',MUFM)
      ELSE
          FMLNE_ZMI = .TRUE.
      ENDIF
   END FUNCTION

   FUNCTION FMLNE_ZMR(MA,R)
      LOGICAL FMLNE_ZMR,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'NE',MUFM)
      CALL FMI2M(0,MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'NE',MUFM)
      FMLNE_ZMR = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_ZMD(MA,D)
      LOGICAL FMLNE_ZMD,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'NE',MUFM)
      CALL FMI2M(0,MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'NE',MUFM)
      FMLNE_ZMD = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_ZMZ(MA,Z)
      LOGICAL FMLNE_ZMZ,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL ZMREAL(MTZM,MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'NE',MUFM)
      CALL ZMIMAG(MTZM,MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'NE',MUFM)
      FMLNE_ZMZ = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_ZMC(MA,C)
      LOGICAL FMLNE_ZMC,FMCOMP,L1,L2
      TYPE ( ZM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL ZMREAL(MA%MZM,MUFM)
      L1 = FMCOMP(MTFM,'NE',MUFM)
      CALL FMDP2M(AIMAG(C),MTFM)
      CALL ZMIMAG(MA%MZM,MUFM)
      L2 = FMCOMP(MTFM,'NE',MUFM)
      FMLNE_ZMC = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_ZMFM(MA,MB)
      USE FMVALS
      LOGICAL FMLNE_ZMFM,FMCOMP,L1,L2
      TYPE ( FM ) MB
      TYPE ( ZM ) MA
      INTENT (IN) :: MA,MB
      CALL ZMREAL(MA%MZM,MTFM)
      L1 = FMCOMP(MB%MFM,'NE',MTFM)
      L2 = .FALSE.
      IF (MA%MZM(KPTIMU+2) /= 0) L2 = .TRUE.
      FMLNE_ZMFM = L1.OR.L2
   END FUNCTION

   FUNCTION FMLNE_ZMIM(MA,MB)
      USE FMVALS
      LOGICAL FMLNE_ZMIM,FMCOMP
      TYPE ( IM ) MB
      TYPE ( ZM ) MA
      INTENT (IN) :: MA,MB
      CALL ZMREAL(MA%MZM,MTFM)
      CALL FMINT(MTFM,MUFM)
      IF (FMCOMP(MUFM,'EQ',MTFM).AND.MA%MZM(KPTIMU+2) == 0) THEN
          CALL IMI2FM(MB%MIM,MUFM)
          FMLNE_ZMIM = FMCOMP(MUFM,'NE',MTFM)
      ELSE
          FMLNE_ZMIM = .TRUE.
      ENDIF
   END FUNCTION

   FUNCTION FMLNE_ZMZM(MA,MB)
      LOGICAL FMLNE_ZMZM,FMCOMP,L1,L2
      TYPE ( ZM ) MA,MB
      INTENT (IN) :: MA,MB
      CALL ZMREAL(MA%MZM,MTFM)
      CALL ZMREAL(MB%MZM,MUFM)
      L1 = FMCOMP(MTFM,'NE',MUFM)
      CALL ZMIMAG(MA%MZM,MTFM)
      CALL ZMIMAG(MB%MZM,MUFM)
      L2 = FMCOMP(MTFM,'NE',MUFM)
      FMLNE_ZMZM = L1.OR.L2
   END FUNCTION

!                                                                >

   FUNCTION FMLGT_IFM(IVAL,MA)
      LOGICAL FMLGT_IFM,FMCOMP
      TYPE ( FM ) MA
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      FMLGT_IFM = FMCOMP(MTFM,'GT',MA%MFM)
   END FUNCTION

   FUNCTION FMLGT_IIM(IVAL,MA)
      LOGICAL FMLGT_IIM,IMCOMP
      TYPE ( IM ) MA
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL IMI2M(IVAL,MTIM)
      FMLGT_IIM = IMCOMP(MTIM,'GT',MA%MIM)
   END FUNCTION

   FUNCTION FMLGT_RFM(R,MA)
      LOGICAL FMLGT_RFM,FMCOMP
      TYPE ( FM ) MA
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      FMLGT_RFM = FMCOMP(MTFM,'GT',MA%MFM)
   END FUNCTION

   FUNCTION FMLGT_RIM(R,MA)
      USE FMVALS
      LOGICAL FMLGT_RIM,FMCOMP
      TYPE ( IM ) MA
      INTEGER KA,NDSAVE
      REAL R
      INTENT (IN) :: R,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLGT_RIM = FMCOMP(MTFM,'GT',MUFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLGT_DFM(D,MA)
      LOGICAL FMLGT_DFM,FMCOMP
      TYPE ( FM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      FMLGT_DFM = FMCOMP(MTFM,'GT',MA%MFM)
   END FUNCTION

   FUNCTION FMLGT_DIM(D,MA)
      USE FMVALS
      LOGICAL FMLGT_DIM,FMCOMP
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTEGER KA,NDSAVE
      INTENT (IN) :: D,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLGT_DIM = FMCOMP(MTFM,'GT',MUFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLGT_FMI(MA,IVAL)
      LOGICAL FMLGT_FMI,FMCOMP
      TYPE ( FM ) MA
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL FMI2M(IVAL,MTFM)
      FMLGT_FMI = FMCOMP(MA%MFM,'GT',MTFM)
   END FUNCTION

   FUNCTION FMLGT_FMR(MA,R)
      LOGICAL FMLGT_FMR,FMCOMP
      TYPE ( FM ) MA
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      FMLGT_FMR = FMCOMP(MA%MFM,'GT',MTFM)
   END FUNCTION

   FUNCTION FMLGT_FMD(MA,D)
      LOGICAL FMLGT_FMD,FMCOMP
      TYPE ( FM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      FMLGT_FMD = FMCOMP(MA%MFM,'GT',MTFM)
   END FUNCTION

   FUNCTION FMLGT_FMFM(MA,MB)
      LOGICAL FMLGT_FMFM,FMCOMP
      TYPE ( FM ) MA,MB
      INTENT (IN) :: MA,MB
      FMLGT_FMFM = FMCOMP(MA%MFM,'GT',MB%MFM)
   END FUNCTION

   FUNCTION FMLGT_FMIM(MA,MB)
      USE FMVALS
      LOGICAL FMLGT_FMIM,FMCOMP
      TYPE ( FM ) MA
      TYPE ( IM ) MB
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,MB
      NDSAVE = NDIG
      KA = MB%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL IMI2FM(MB%MIM,MTFM)
      FMLGT_FMIM = FMCOMP(MA%MFM,'GT',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLGT_IMI(MA,IVAL)
      LOGICAL FMLGT_IMI,IMCOMP
      TYPE ( IM ) MA
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL IMI2M(IVAL,MTIM)
      FMLGT_IMI = IMCOMP(MA%MIM,'GT',MTIM)
   END FUNCTION

   FUNCTION FMLGT_IMR(MA,R)
      USE FMVALS
      LOGICAL FMLGT_IMR,FMCOMP
      TYPE ( IM ) MA
      INTEGER KA,NDSAVE
      REAL R
      INTENT (IN) :: MA,R
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLGT_IMR = FMCOMP(MUFM,'GT',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLGT_IMD(MA,D)
      USE FMVALS
      LOGICAL FMLGT_IMD,FMCOMP
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,D
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLGT_IMD = FMCOMP(MUFM,'GT',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLGT_IMFM(MA,MB)
      USE FMVALS
      LOGICAL FMLGT_IMFM,FMCOMP
      TYPE ( IM ) MA
      TYPE ( FM ) MB
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,MB
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL IMI2FM(MA%MIM,MTFM)
      FMLGT_IMFM = FMCOMP(MTFM,'GT',MB%MFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLGT_IMIM(MA,MB)
      LOGICAL FMLGT_IMIM,IMCOMP
      TYPE ( IM ) MA,MB
      INTENT (IN) :: MA,MB
      FMLGT_IMIM = IMCOMP(MA%MIM,'GT',MB%MIM)
   END FUNCTION

 END MODULE FMZM_3

 MODULE FMZM_4
    USE FMZM_1

    INTERFACE OPERATOR ( >= )
       MODULE PROCEDURE FMLGE_IFM
       MODULE PROCEDURE FMLGE_IIM
       MODULE PROCEDURE FMLGE_RFM
       MODULE PROCEDURE FMLGE_RIM
       MODULE PROCEDURE FMLGE_DFM
       MODULE PROCEDURE FMLGE_DIM
       MODULE PROCEDURE FMLGE_FMI
       MODULE PROCEDURE FMLGE_FMR
       MODULE PROCEDURE FMLGE_FMD
       MODULE PROCEDURE FMLGE_FMFM
       MODULE PROCEDURE FMLGE_FMIM
       MODULE PROCEDURE FMLGE_IMI
       MODULE PROCEDURE FMLGE_IMR
       MODULE PROCEDURE FMLGE_IMD
       MODULE PROCEDURE FMLGE_IMFM
       MODULE PROCEDURE FMLGE_IMIM
    END INTERFACE

    INTERFACE OPERATOR ( < )
       MODULE PROCEDURE FMLLT_IFM
       MODULE PROCEDURE FMLLT_IIM
       MODULE PROCEDURE FMLLT_RFM
       MODULE PROCEDURE FMLLT_RIM
       MODULE PROCEDURE FMLLT_DFM
       MODULE PROCEDURE FMLLT_DIM
       MODULE PROCEDURE FMLLT_FMI
       MODULE PROCEDURE FMLLT_FMR
       MODULE PROCEDURE FMLLT_FMD
       MODULE PROCEDURE FMLLT_FMFM
       MODULE PROCEDURE FMLLT_FMIM
       MODULE PROCEDURE FMLLT_IMI
       MODULE PROCEDURE FMLLT_IMR
       MODULE PROCEDURE FMLLT_IMD
       MODULE PROCEDURE FMLLT_IMFM
       MODULE PROCEDURE FMLLT_IMIM
    END INTERFACE

    INTERFACE OPERATOR ( <= )
       MODULE PROCEDURE FMLLE_IFM
       MODULE PROCEDURE FMLLE_IIM
       MODULE PROCEDURE FMLLE_RFM
       MODULE PROCEDURE FMLLE_RIM
       MODULE PROCEDURE FMLLE_DFM
       MODULE PROCEDURE FMLLE_DIM
       MODULE PROCEDURE FMLLE_FMI
       MODULE PROCEDURE FMLLE_FMR
       MODULE PROCEDURE FMLLE_FMD
       MODULE PROCEDURE FMLLE_FMFM
       MODULE PROCEDURE FMLLE_FMIM
       MODULE PROCEDURE FMLLE_IMI
       MODULE PROCEDURE FMLLE_IMR
       MODULE PROCEDURE FMLLE_IMD
       MODULE PROCEDURE FMLLE_IMFM
       MODULE PROCEDURE FMLLE_IMIM
    END INTERFACE

 CONTAINS

!                                                                >=

   FUNCTION FMLGE_IFM(IVAL,MA)
      LOGICAL FMLGE_IFM,FMCOMP
      TYPE ( FM ) MA
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      FMLGE_IFM = FMCOMP(MTFM,'GE',MA%MFM)
   END FUNCTION

   FUNCTION FMLGE_IIM(IVAL,MA)
      LOGICAL FMLGE_IIM,IMCOMP
      TYPE ( IM ) MA
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL IMI2M(IVAL,MTIM)
      FMLGE_IIM = IMCOMP(MTIM,'GE',MA%MIM)
   END FUNCTION

   FUNCTION FMLGE_RFM(R,MA)
      LOGICAL FMLGE_RFM,FMCOMP
      TYPE ( FM ) MA
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      FMLGE_RFM = FMCOMP(MTFM,'GE',MA%MFM)
   END FUNCTION

   FUNCTION FMLGE_RIM(R,MA)
      USE FMVALS
      LOGICAL FMLGE_RIM,FMCOMP
      TYPE ( IM ) MA
      INTEGER KA,NDSAVE
      REAL R
      INTENT (IN) :: R,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLGE_RIM = FMCOMP(MTFM,'GE',MUFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLGE_DFM(D,MA)
      LOGICAL FMLGE_DFM,FMCOMP
      TYPE ( FM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      FMLGE_DFM = FMCOMP(MTFM,'GE',MA%MFM)
   END FUNCTION

   FUNCTION FMLGE_DIM(D,MA)
      USE FMVALS
      LOGICAL FMLGE_DIM,FMCOMP
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTEGER KA,NDSAVE
      INTENT (IN) :: D,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLGE_DIM = FMCOMP(MTFM,'GE',MUFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLGE_FMI(MA,IVAL)
      LOGICAL FMLGE_FMI,FMCOMP
      TYPE ( FM ) MA
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL FMI2M(IVAL,MTFM)
      FMLGE_FMI = FMCOMP(MA%MFM,'GE',MTFM)
   END FUNCTION

   FUNCTION FMLGE_FMR(MA,R)
      LOGICAL FMLGE_FMR,FMCOMP
      TYPE ( FM ) MA
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      FMLGE_FMR = FMCOMP(MA%MFM,'GE',MTFM)
   END FUNCTION

   FUNCTION FMLGE_FMD(MA,D)
      LOGICAL FMLGE_FMD,FMCOMP
      TYPE ( FM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      FMLGE_FMD = FMCOMP(MA%MFM,'GE',MTFM)
   END FUNCTION

   FUNCTION FMLGE_FMFM(MA,MB)
      LOGICAL FMLGE_FMFM,FMCOMP
      TYPE ( FM ) MA,MB
      INTENT (IN) :: MA,MB
      FMLGE_FMFM = FMCOMP(MA%MFM,'GE',MB%MFM)
   END FUNCTION

   FUNCTION FMLGE_FMIM(MA,MB)
      USE FMVALS
      LOGICAL FMLGE_FMIM,FMCOMP
      TYPE ( FM ) MA
      TYPE ( IM ) MB
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,MB
      NDSAVE = NDIG
      KA = MB%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL IMI2FM(MB%MIM,MTFM)
      FMLGE_FMIM = FMCOMP(MA%MFM,'GE',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLGE_IMI(MA,IVAL)
      LOGICAL FMLGE_IMI,IMCOMP
      TYPE ( IM ) MA
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL IMI2M(IVAL,MTIM)
      FMLGE_IMI = IMCOMP(MA%MIM,'GE',MTIM)
   END FUNCTION

   FUNCTION FMLGE_IMR(MA,R)
      USE FMVALS
      LOGICAL FMLGE_IMR,FMCOMP
      TYPE ( IM ) MA
      INTEGER KA,NDSAVE
      REAL R
      INTENT (IN) :: MA,R
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLGE_IMR = FMCOMP(MUFM,'GE',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLGE_IMD(MA,D)
      USE FMVALS
      LOGICAL FMLGE_IMD,FMCOMP
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,D
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLGE_IMD = FMCOMP(MUFM,'GE',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLGE_IMFM(MA,MB)
      USE FMVALS
      LOGICAL FMLGE_IMFM,FMCOMP
      TYPE ( IM ) MA
      TYPE ( FM ) MB
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,MB
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL IMI2FM(MA%MIM,MTFM)
      FMLGE_IMFM = FMCOMP(MTFM,'GE',MB%MFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLGE_IMIM(MA,MB)
      LOGICAL FMLGE_IMIM,IMCOMP
      TYPE ( IM ) MA,MB
      INTENT (IN) :: MA,MB
      FMLGE_IMIM = IMCOMP(MA%MIM,'GE',MB%MIM)
   END FUNCTION

!                                                                <

   FUNCTION FMLLT_IFM(IVAL,MA)
      LOGICAL FMLLT_IFM,FMCOMP
      TYPE ( FM ) MA
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      FMLLT_IFM = FMCOMP(MTFM,'LT',MA%MFM)
   END FUNCTION

   FUNCTION FMLLT_IIM(IVAL,MA)
      LOGICAL FMLLT_IIM,IMCOMP
      TYPE ( IM ) MA
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL IMI2M(IVAL,MTIM)
      FMLLT_IIM = IMCOMP(MTIM,'LT',MA%MIM)
   END FUNCTION

   FUNCTION FMLLT_RFM(R,MA)
      LOGICAL FMLLT_RFM,FMCOMP
      TYPE ( FM ) MA
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      FMLLT_RFM = FMCOMP(MTFM,'LT',MA%MFM)
   END FUNCTION

   FUNCTION FMLLT_RIM(R,MA)
      USE FMVALS
      LOGICAL FMLLT_RIM,FMCOMP
      TYPE ( IM ) MA
      INTEGER KA,NDSAVE
      REAL R
      INTENT (IN) :: R,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLLT_RIM = FMCOMP(MTFM,'LT',MUFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLLT_DFM(D,MA)
      LOGICAL FMLLT_DFM,FMCOMP
      TYPE ( FM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      FMLLT_DFM = FMCOMP(MTFM,'LT',MA%MFM)
   END FUNCTION

   FUNCTION FMLLT_DIM(D,MA)
      USE FMVALS
      LOGICAL FMLLT_DIM,FMCOMP
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTEGER KA,NDSAVE
      INTENT (IN) :: D,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLLT_DIM = FMCOMP(MTFM,'LT',MUFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLLT_FMI(MA,IVAL)
      LOGICAL FMLLT_FMI,FMCOMP
      TYPE ( FM ) MA
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL FMI2M(IVAL,MTFM)
      FMLLT_FMI = FMCOMP(MA%MFM,'LT',MTFM)
   END FUNCTION

   FUNCTION FMLLT_FMR(MA,R)
      LOGICAL FMLLT_FMR,FMCOMP
      TYPE ( FM ) MA
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      FMLLT_FMR = FMCOMP(MA%MFM,'LT',MTFM)
   END FUNCTION

   FUNCTION FMLLT_FMD(MA,D)
      LOGICAL FMLLT_FMD,FMCOMP
      TYPE ( FM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      FMLLT_FMD = FMCOMP(MA%MFM,'LT',MTFM)
   END FUNCTION

   FUNCTION FMLLT_FMFM(MA,MB)
      LOGICAL FMLLT_FMFM,FMCOMP
      TYPE ( FM ) MA,MB
      INTENT (IN) :: MA,MB
      FMLLT_FMFM = FMCOMP(MA%MFM,'LT',MB%MFM)
   END FUNCTION

   FUNCTION FMLLT_FMIM(MA,MB)
      USE FMVALS
      LOGICAL FMLLT_FMIM,FMCOMP
      TYPE ( FM ) MA
      TYPE ( IM ) MB
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,MB
      NDSAVE = NDIG
      KA = MB%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL IMI2FM(MB%MIM,MTFM)
      FMLLT_FMIM = FMCOMP(MA%MFM,'LT',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLLT_IMI(MA,IVAL)
      LOGICAL FMLLT_IMI,IMCOMP
      TYPE ( IM ) MA
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL IMI2M(IVAL,MTIM)
      FMLLT_IMI = IMCOMP(MA%MIM,'LT',MTIM)
   END FUNCTION

   FUNCTION FMLLT_IMR(MA,R)
      USE FMVALS
      LOGICAL FMLLT_IMR,FMCOMP
      TYPE ( IM ) MA
      INTEGER KA,NDSAVE
      REAL R
      INTENT (IN) :: MA,R
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLLT_IMR = FMCOMP(MUFM,'LT',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLLT_IMD(MA,D)
      USE FMVALS
      LOGICAL FMLLT_IMD,FMCOMP
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,D
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLLT_IMD = FMCOMP(MUFM,'LT',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLLT_IMFM(MA,MB)
      USE FMVALS
      LOGICAL FMLLT_IMFM,FMCOMP
      TYPE ( IM ) MA
      TYPE ( FM ) MB
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,MB
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL IMI2FM(MA%MIM,MTFM)
      FMLLT_IMFM = FMCOMP(MTFM,'LT',MB%MFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLLT_IMIM(MA,MB)
      LOGICAL FMLLT_IMIM,IMCOMP
      TYPE ( IM ) MA,MB
      INTENT (IN) :: MA,MB
      FMLLT_IMIM = IMCOMP(MA%MIM,'LT',MB%MIM)
   END FUNCTION

!                                                                <=

   FUNCTION FMLLE_IFM(IVAL,MA)
      LOGICAL FMLLE_IFM,FMCOMP
      TYPE ( FM ) MA
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      FMLLE_IFM = FMCOMP(MTFM,'LE',MA%MFM)
   END FUNCTION

   FUNCTION FMLLE_IIM(IVAL,MA)
      LOGICAL FMLLE_IIM,IMCOMP
      TYPE ( IM ) MA
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL IMI2M(IVAL,MTIM)
      FMLLE_IIM = IMCOMP(MTIM,'LE',MA%MIM)
   END FUNCTION

   FUNCTION FMLLE_RFM(R,MA)
      LOGICAL FMLLE_RFM,FMCOMP
      TYPE ( FM ) MA
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      FMLLE_RFM = FMCOMP(MTFM,'LE',MA%MFM)
   END FUNCTION

   FUNCTION FMLLE_RIM(R,MA)
      USE FMVALS
      LOGICAL FMLLE_RIM,FMCOMP
      TYPE ( IM ) MA
      INTEGER KA,NDSAVE
      REAL R
      INTENT (IN) :: R,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLLE_RIM = FMCOMP(MTFM,'LE',MUFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLLE_DFM(D,MA)
      LOGICAL FMLLE_DFM,FMCOMP
      TYPE ( FM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      FMLLE_DFM = FMCOMP(MTFM,'LE',MA%MFM)
   END FUNCTION

   FUNCTION FMLLE_DIM(D,MA)
      USE FMVALS
      LOGICAL FMLLE_DIM,FMCOMP
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTEGER KA,NDSAVE
      INTENT (IN) :: D,MA
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLLE_DIM = FMCOMP(MTFM,'LE',MUFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLLE_FMI(MA,IVAL)
      LOGICAL FMLLE_FMI,FMCOMP
      TYPE ( FM ) MA
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL FMI2M(IVAL,MTFM)
      FMLLE_FMI = FMCOMP(MA%MFM,'LE',MTFM)
   END FUNCTION

   FUNCTION FMLLE_FMR(MA,R)
      LOGICAL FMLLE_FMR,FMCOMP
      TYPE ( FM ) MA
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      FMLLE_FMR = FMCOMP(MA%MFM,'LE',MTFM)
   END FUNCTION

   FUNCTION FMLLE_FMD(MA,D)
      LOGICAL FMLLE_FMD,FMCOMP
      TYPE ( FM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      FMLLE_FMD = FMCOMP(MA%MFM,'LE',MTFM)
   END FUNCTION

   FUNCTION FMLLE_FMFM(MA,MB)
      LOGICAL FMLLE_FMFM,FMCOMP
      TYPE ( FM ) MA,MB
      INTENT (IN) :: MA,MB
      FMLLE_FMFM = FMCOMP(MA%MFM,'LE',MB%MFM)
   END FUNCTION

   FUNCTION FMLLE_FMIM(MA,MB)
      USE FMVALS
      LOGICAL FMLLE_FMIM,FMCOMP
      TYPE ( FM ) MA
      TYPE ( IM ) MB
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,MB
      NDSAVE = NDIG
      KA = MB%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL IMI2FM(MB%MIM,MTFM)
      FMLLE_FMIM = FMCOMP(MA%MFM,'LE',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLLE_IMI(MA,IVAL)
      LOGICAL FMLLE_IMI,IMCOMP
      TYPE ( IM ) MA
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL IMI2M(IVAL,MTIM)
      FMLLE_IMI = IMCOMP(MA%MIM,'LE',MTIM)
   END FUNCTION

   FUNCTION FMLLE_IMR(MA,R)
      USE FMVALS
      LOGICAL FMLLE_IMR,FMCOMP
      TYPE ( IM ) MA
      INTEGER KA,NDSAVE
      REAL R
      INTENT (IN) :: MA,R
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLLE_IMR = FMCOMP(MUFM,'LE',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLLE_IMD(MA,D)
      USE FMVALS
      LOGICAL FMLLE_IMD,FMCOMP
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,D
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      FMLLE_IMD = FMCOMP(MUFM,'LE',MTFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLLE_IMFM(MA,MB)
      USE FMVALS
      LOGICAL FMLLE_IMFM,FMCOMP
      TYPE ( IM ) MA
      TYPE ( FM ) MB
      INTEGER KA,NDSAVE
      INTENT (IN) :: MA,MB
      NDSAVE = NDIG
      KA = MA%MIM(1)
      NDIG = MAX(KA+NGRD52,NDIG)
      CALL IMI2FM(MA%MIM,MTFM)
      FMLLE_IMFM = FMCOMP(MTFM,'LE',MB%MFM)
      NDIG = NDSAVE
   END FUNCTION

   FUNCTION FMLLE_IMIM(MA,MB)
      LOGICAL FMLLE_IMIM,IMCOMP
      TYPE ( IM ) MA,MB
      INTENT (IN) :: MA,MB
      FMLLE_IMIM = IMCOMP(MA%MIM,'LE',MB%MIM)
   END FUNCTION

 END MODULE FMZM_4

 MODULE FMZM_5
    USE FMZM_1

    INTERFACE OPERATOR (+)
       MODULE PROCEDURE FMADD_IFM
       MODULE PROCEDURE FMADD_IIM
       MODULE PROCEDURE FMADD_IZM
       MODULE PROCEDURE FMADD_RFM
       MODULE PROCEDURE FMADD_RIM
       MODULE PROCEDURE FMADD_RZM
       MODULE PROCEDURE FMADD_DFM
       MODULE PROCEDURE FMADD_DIM
       MODULE PROCEDURE FMADD_DZM
       MODULE PROCEDURE FMADD_ZFM
       MODULE PROCEDURE FMADD_ZIM
       MODULE PROCEDURE FMADD_ZZM
       MODULE PROCEDURE FMADD_CFM
       MODULE PROCEDURE FMADD_CIM
       MODULE PROCEDURE FMADD_CZM
       MODULE PROCEDURE FMADD_FMI
       MODULE PROCEDURE FMADD_FMR
       MODULE PROCEDURE FMADD_FMD
       MODULE PROCEDURE FMADD_FMZ
       MODULE PROCEDURE FMADD_FMC
       MODULE PROCEDURE FMADD_FMFM
       MODULE PROCEDURE FMADD_FMIM
       MODULE PROCEDURE FMADD_FMZM
       MODULE PROCEDURE FMADD_IMI
       MODULE PROCEDURE FMADD_IMR
       MODULE PROCEDURE FMADD_IMD
       MODULE PROCEDURE FMADD_IMZ
       MODULE PROCEDURE FMADD_IMC
       MODULE PROCEDURE FMADD_IMFM
       MODULE PROCEDURE FMADD_IMIM
       MODULE PROCEDURE FMADD_IMZM
       MODULE PROCEDURE FMADD_ZMI
       MODULE PROCEDURE FMADD_ZMR
       MODULE PROCEDURE FMADD_ZMD
       MODULE PROCEDURE FMADD_ZMZ
       MODULE PROCEDURE FMADD_ZMC
       MODULE PROCEDURE FMADD_ZMFM
       MODULE PROCEDURE FMADD_ZMIM
       MODULE PROCEDURE FMADD_ZMZM
       MODULE PROCEDURE FMADD_FM
       MODULE PROCEDURE FMADD_IM
       MODULE PROCEDURE FMADD_ZM
    END INTERFACE

    INTERFACE OPERATOR (-)
       MODULE PROCEDURE FMSUB_IFM
       MODULE PROCEDURE FMSUB_IIM
       MODULE PROCEDURE FMSUB_IZM
       MODULE PROCEDURE FMSUB_RFM
       MODULE PROCEDURE FMSUB_RIM
       MODULE PROCEDURE FMSUB_RZM
       MODULE PROCEDURE FMSUB_DFM
       MODULE PROCEDURE FMSUB_DIM
       MODULE PROCEDURE FMSUB_DZM
       MODULE PROCEDURE FMSUB_ZFM
       MODULE PROCEDURE FMSUB_ZIM
       MODULE PROCEDURE FMSUB_ZZM
       MODULE PROCEDURE FMSUB_CFM
       MODULE PROCEDURE FMSUB_CIM
       MODULE PROCEDURE FMSUB_CZM
       MODULE PROCEDURE FMSUB_FMI
       MODULE PROCEDURE FMSUB_FMR
       MODULE PROCEDURE FMSUB_FMD
       MODULE PROCEDURE FMSUB_FMZ
       MODULE PROCEDURE FMSUB_FMC
       MODULE PROCEDURE FMSUB_FMFM
       MODULE PROCEDURE FMSUB_FMIM
       MODULE PROCEDURE FMSUB_FMZM
       MODULE PROCEDURE FMSUB_IMI
       MODULE PROCEDURE FMSUB_IMR
       MODULE PROCEDURE FMSUB_IMD
       MODULE PROCEDURE FMSUB_IMZ
       MODULE PROCEDURE FMSUB_IMC
       MODULE PROCEDURE FMSUB_IMFM
       MODULE PROCEDURE FMSUB_IMIM
       MODULE PROCEDURE FMSUB_IMZM
       MODULE PROCEDURE FMSUB_ZMI
       MODULE PROCEDURE FMSUB_ZMR
       MODULE PROCEDURE FMSUB_ZMD
       MODULE PROCEDURE FMSUB_ZMZ
       MODULE PROCEDURE FMSUB_ZMC
       MODULE PROCEDURE FMSUB_ZMFM
       MODULE PROCEDURE FMSUB_ZMIM
       MODULE PROCEDURE FMSUB_ZMZM
       MODULE PROCEDURE FMSUB_FM
       MODULE PROCEDURE FMSUB_IM
       MODULE PROCEDURE FMSUB_ZM
    END INTERFACE

 CONTAINS

!                                                                   +

   FUNCTION FMADD_IFM(IVAL,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMADD_IFM
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      CALL FMADD(MTFM,MA%MFM,FMADD_IFM%MFM)
   END FUNCTION

   FUNCTION FMADD_IIM(IVAL,MA)
      USE FMVALS
      TYPE ( IM ) MA,FMADD_IIM
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL IMI2M(IVAL,MTIM)
      CALL IMADD(MTIM,MA%MIM,FMADD_IIM%MIM)
   END FUNCTION

   FUNCTION FMADD_IZM(IVAL,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMADD_IZM
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMADD(MTZM,MA%MZM,FMADD_IZM%MZM)
   END FUNCTION

   FUNCTION FMADD_RFM(R,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMADD_RFM
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL FMADD(MTFM,MA%MFM,FMADD_RFM%MFM)
   END FUNCTION

   FUNCTION FMADD_RIM(R,MA)
      USE FMVALS
      TYPE ( FM ) FMADD_RIM
      TYPE ( IM ) MA
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMADD(MTFM,MUFM,FMADD_RIM%MFM)
   END FUNCTION

   FUNCTION FMADD_RZM(R,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMADD_RZM
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMADD(MTZM,MA%MZM,FMADD_RZM%MZM)
   END FUNCTION

   FUNCTION FMADD_DFM(D,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMADD_DFM
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL FMADD(MTFM,MA%MFM,FMADD_DFM%MFM)
   END FUNCTION

   FUNCTION FMADD_DIM(D,MA)
      USE FMVALS
      TYPE ( FM ) FMADD_DIM
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMADD(MTFM,MUFM,FMADD_DIM%MFM)
   END FUNCTION

   FUNCTION FMADD_DZM(D,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMADD_DZM
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMADD(MTZM,MA%MZM,FMADD_DZM%MZM)
   END FUNCTION

   FUNCTION FMADD_ZFM(Z,MA)
      USE FMVALS
      TYPE ( ZM ) FMADD_ZFM
      TYPE ( FM ) MA
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMADD(MTZM,MUZM,FMADD_ZFM%MZM)
   END FUNCTION

   FUNCTION FMADD_ZIM(Z,MA)
      USE FMVALS
      TYPE ( ZM ) FMADD_ZIM
      TYPE ( IM ) MA
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMADD(MTZM,MUZM,FMADD_ZIM%MZM)
   END FUNCTION

   FUNCTION FMADD_ZZM(Z,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMADD_ZZM
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL ZMADD(MTZM,MA%MZM,FMADD_ZZM%MZM)
   END FUNCTION

   FUNCTION FMADD_CFM(C,MA)
      USE FMVALS
      TYPE ( ZM ) FMADD_CFM
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMADD(MTZM,MUZM,FMADD_CFM%MZM)
   END FUNCTION

   FUNCTION FMADD_CIM(C,MA)
      USE FMVALS
      TYPE ( ZM ) FMADD_CIM
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMADD(MTZM,MUZM,FMADD_CIM%MZM)
   END FUNCTION

   FUNCTION FMADD_CZM(C,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMADD_CZM
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMADD(MTZM,MA%MZM,FMADD_CZM%MZM)
   END FUNCTION

   FUNCTION FMADD_FMI(MA,IVAL)
      USE FMVALS
      TYPE ( FM ) MA,FMADD_FMI
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL FMI2M(IVAL,MTFM)
      CALL FMADD(MA%MFM,MTFM,FMADD_FMI%MFM)
   END FUNCTION

   FUNCTION FMADD_FMR(MA,R)
      USE FMVALS
      TYPE ( FM ) MA,FMADD_FMR
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL FMADD(MA%MFM,MTFM,FMADD_FMR%MFM)
   END FUNCTION

   FUNCTION FMADD_FMD(MA,D)
      USE FMVALS
      TYPE ( FM ) MA,FMADD_FMD
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL FMADD(MA%MFM,MTFM,FMADD_FMD%MFM)
   END FUNCTION

   FUNCTION FMADD_FMZ(MA,Z)
      USE FMVALS
      TYPE ( ZM ) FMADD_FMZ
      TYPE ( FM ) MA
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMADD(MUZM,MTZM,FMADD_FMZ%MZM)
   END FUNCTION

   FUNCTION FMADD_FMC(MA,C)
      USE FMVALS
      TYPE ( ZM ) FMADD_FMC
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMADD(MUZM,MTZM,FMADD_FMC%MZM)
   END FUNCTION

   FUNCTION FMADD_FMFM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMADD_FMFM
      INTENT (IN) :: MA,MB
      CALL FMADD(MA%MFM,MB%MFM,FMADD_FMFM%MFM)
   END FUNCTION

   FUNCTION FMADD_FMIM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,FMADD_FMIM
      TYPE ( IM ) MB
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MB%MIM,MTFM)
      CALL FMADD(MA%MFM,MTFM,FMADD_FMIM%MFM)
   END FUNCTION

   FUNCTION FMADD_FMZM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA
      TYPE ( ZM ) MB,FMADD_FMZM
      INTENT (IN) :: MA,MB
      CALL FMI2M(0,MTFM)
      CALL ZMCMPX(MA%MFM,MTFM,MTZM)
      CALL ZMADD(MTZM,MB%MZM,FMADD_FMZM%MZM)
   END FUNCTION

   FUNCTION FMADD_IMI(MA,IVAL)
      USE FMVALS
      TYPE ( IM ) MA,FMADD_IMI
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL IMI2M(IVAL,MTIM)
      CALL IMADD(MA%MIM,MTIM,FMADD_IMI%MIM)
   END FUNCTION

   FUNCTION FMADD_IMR(MA,R)
      USE FMVALS
      TYPE ( FM ) FMADD_IMR
      TYPE ( IM ) MA
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMADD(MUFM,MTFM,FMADD_IMR%MFM)
   END FUNCTION

   FUNCTION FMADD_IMD(MA,D)
      USE FMVALS
      TYPE ( FM ) FMADD_IMD
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMADD(MUFM,MTFM,FMADD_IMD%MFM)
   END FUNCTION

   FUNCTION FMADD_IMZ(MA,Z)
      USE FMVALS
      TYPE ( ZM ) FMADD_IMZ
      TYPE ( IM ) MA
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMADD(MUZM,MTZM,FMADD_IMZ%MZM)
   END FUNCTION

   FUNCTION FMADD_IMC(MA,C)
      USE FMVALS
      TYPE ( ZM ) FMADD_IMC
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMADD(MUZM,MTZM,FMADD_IMC%MZM)
   END FUNCTION

   FUNCTION FMADD_IMFM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA
      TYPE ( FM ) MB,FMADD_IMFM
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMADD(MTFM,MB%MFM,FMADD_IMFM%MFM)
   END FUNCTION

   FUNCTION FMADD_IMIM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA,MB,FMADD_IMIM
      INTENT (IN) :: MA,MB
      CALL IMADD(MA%MIM,MB%MIM,FMADD_IMIM%MIM)
   END FUNCTION

   FUNCTION FMADD_IMZM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA
      TYPE ( ZM ) MB,FMADD_IMZM
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMADD(MUZM,MB%MZM,FMADD_IMZM%MZM)
   END FUNCTION

   FUNCTION FMADD_ZMI(MA,IVAL)
      USE FMVALS
      TYPE ( ZM ) MA,FMADD_ZMI
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL FMI2M(IVAL,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMADD(MA%MZM,MTZM,FMADD_ZMI%MZM)
   END FUNCTION

   FUNCTION FMADD_ZMR(MA,R)
      USE FMVALS
      TYPE ( ZM ) MA,FMADD_ZMR
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMADD(MA%MZM,MTZM,FMADD_ZMR%MZM)
   END FUNCTION

   FUNCTION FMADD_ZMD(MA,D)
      USE FMVALS
      TYPE ( ZM ) MA,FMADD_ZMD
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMADD(MA%MZM,MTZM,FMADD_ZMD%MZM)
   END FUNCTION

   FUNCTION FMADD_ZMZ(MA,Z)
      USE FMVALS
      TYPE ( ZM ) MA,FMADD_ZMZ
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL ZMADD(MA%MZM,MTZM,FMADD_ZMZ%MZM)
   END FUNCTION

   FUNCTION FMADD_ZMC(MA,C)
      USE FMVALS
      TYPE ( ZM ) MA,FMADD_ZMC
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMADD(MA%MZM,MTZM,FMADD_ZMC%MZM)
   END FUNCTION

   FUNCTION FMADD_ZMFM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MB
      TYPE ( ZM ) MA,FMADD_ZMFM
      INTENT (IN) :: MA,MB
      CALL FMI2M(0,MTFM)
      CALL ZMCMPX(MB%MFM,MTFM,MTZM)
      CALL ZMADD(MA%MZM,MTZM,FMADD_ZMFM%MZM)
   END FUNCTION

   FUNCTION FMADD_ZMIM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MB
      TYPE ( ZM ) MA,FMADD_ZMIM
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MB%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMADD(MA%MZM,MUZM,FMADD_ZMIM%MZM)
   END FUNCTION

   FUNCTION FMADD_ZMZM(MA,MB)
      USE FMVALS
      TYPE ( ZM ) MA,MB,FMADD_ZMZM
      INTENT (IN) :: MA,MB
      CALL ZMADD(MA%MZM,MB%MZM,FMADD_ZMZM%MZM)
   END FUNCTION

   FUNCTION FMADD_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMADD_FM
      INTENT (IN) :: MA
      CALL FMEQ(MA%MFM,FMADD_FM%MFM)
   END FUNCTION

   FUNCTION FMADD_IM(MA)
      USE FMVALS
      TYPE ( IM ) MA,FMADD_IM
      INTENT (IN) :: MA
      CALL IMEQ(MA%MIM,FMADD_IM%MIM)
   END FUNCTION

   FUNCTION FMADD_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMADD_ZM
      INTENT (IN) :: MA
      CALL ZMEQ(MA%MZM,FMADD_ZM%MZM)
   END FUNCTION

!                                                                   -

   FUNCTION FMSUB_IFM(IVAL,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMSUB_IFM
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      CALL FMSUB(MTFM,MA%MFM,FMSUB_IFM%MFM)
   END FUNCTION

   FUNCTION FMSUB_IIM(IVAL,MA)
      USE FMVALS
      TYPE ( IM ) MA,FMSUB_IIM
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL IMI2M(IVAL,MTIM)
      CALL IMSUB(MTIM,MA%MIM,FMSUB_IIM%MIM)
   END FUNCTION

   FUNCTION FMSUB_IZM(IVAL,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMSUB_IZM
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMSUB(MTZM,MA%MZM,FMSUB_IZM%MZM)
   END FUNCTION

   FUNCTION FMSUB_RFM(R,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMSUB_RFM
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL FMSUB(MTFM,MA%MFM,FMSUB_RFM%MFM)
   END FUNCTION

   FUNCTION FMSUB_RIM(R,MA)
      USE FMVALS
      TYPE ( FM ) FMSUB_RIM
      TYPE ( IM ) MA
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMSUB(MTFM,MUFM,FMSUB_RIM%MFM)
   END FUNCTION

   FUNCTION FMSUB_RZM(R,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMSUB_RZM
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMSUB(MTZM,MA%MZM,FMSUB_RZM%MZM)
   END FUNCTION

   FUNCTION FMSUB_DFM(D,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMSUB_DFM
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL FMSUB(MTFM,MA%MFM,FMSUB_DFM%MFM)
   END FUNCTION

   FUNCTION FMSUB_DIM(D,MA)
      USE FMVALS
      TYPE ( FM ) FMSUB_DIM
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMSUB(MTFM,MUFM,FMSUB_DIM%MFM)
   END FUNCTION

   FUNCTION FMSUB_DZM(D,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMSUB_DZM
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMSUB(MTZM,MA%MZM,FMSUB_DZM%MZM)
   END FUNCTION

   FUNCTION FMSUB_ZFM(Z,MA)
      USE FMVALS
      TYPE ( ZM ) FMSUB_ZFM
      TYPE ( FM ) MA
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMSUB(MTZM,MUZM,FMSUB_ZFM%MZM)
   END FUNCTION

   FUNCTION FMSUB_ZIM(Z,MA)
      USE FMVALS
      TYPE ( ZM ) FMSUB_ZIM
      TYPE ( IM ) MA
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMSUB(MTZM,MUZM,FMSUB_ZIM%MZM)
   END FUNCTION

   FUNCTION FMSUB_ZZM(Z,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMSUB_ZZM
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL ZMSUB(MTZM,MA%MZM,FMSUB_ZZM%MZM)
   END FUNCTION

   FUNCTION FMSUB_CFM(C,MA)
      USE FMVALS
      TYPE ( ZM ) FMSUB_CFM
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMSUB(MTZM,MUZM,FMSUB_CFM%MZM)
   END FUNCTION

   FUNCTION FMSUB_CIM(C,MA)
      USE FMVALS
      TYPE ( ZM ) FMSUB_CIM
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMSUB(MTZM,MUZM,FMSUB_CIM%MZM)
   END FUNCTION

   FUNCTION FMSUB_CZM(C,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMSUB_CZM
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMSUB(MTZM,MA%MZM,FMSUB_CZM%MZM)
   END FUNCTION

   FUNCTION FMSUB_FMI(MA,IVAL)
      USE FMVALS
      TYPE ( FM ) MA,FMSUB_FMI
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL FMI2M(IVAL,MTFM)
      CALL FMSUB(MA%MFM,MTFM,FMSUB_FMI%MFM)
   END FUNCTION

   FUNCTION FMSUB_FMR(MA,R)
      USE FMVALS
      TYPE ( FM ) MA,FMSUB_FMR
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL FMSUB(MA%MFM,MTFM,FMSUB_FMR%MFM)
   END FUNCTION

   FUNCTION FMSUB_FMD(MA,D)
      USE FMVALS
      TYPE ( FM ) MA,FMSUB_FMD
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL FMSUB(MA%MFM,MTFM,FMSUB_FMD%MFM)
   END FUNCTION

   FUNCTION FMSUB_FMZ(MA,Z)
      USE FMVALS
      TYPE ( ZM ) FMSUB_FMZ
      TYPE ( FM ) MA
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMSUB(MUZM,MTZM,FMSUB_FMZ%MZM)
   END FUNCTION

   FUNCTION FMSUB_FMC(MA,C)
      USE FMVALS
      TYPE ( ZM ) FMSUB_FMC
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMSUB(MUZM,MTZM,FMSUB_FMC%MZM)
   END FUNCTION

   FUNCTION FMSUB_FMFM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMSUB_FMFM
      INTENT (IN) :: MA,MB
      CALL FMSUB(MA%MFM,MB%MFM,FMSUB_FMFM%MFM)
   END FUNCTION

   FUNCTION FMSUB_FMIM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,FMSUB_FMIM
      TYPE ( IM ) MB
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MB%MIM,MTFM)
      CALL FMSUB(MA%MFM,MTFM,FMSUB_FMIM%MFM)
   END FUNCTION

   FUNCTION FMSUB_FMZM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA
      TYPE ( ZM ) MB,FMSUB_FMZM
      INTENT (IN) :: MA,MB
      CALL FMI2M(0,MTFM)
      CALL ZMCMPX(MA%MFM,MTFM,MTZM)
      CALL ZMSUB(MTZM,MB%MZM,FMSUB_FMZM%MZM)
   END FUNCTION

   FUNCTION FMSUB_IMI(MA,IVAL)
      USE FMVALS
      TYPE ( IM ) MA,FMSUB_IMI
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL IMI2M(IVAL,MTIM)
      CALL IMSUB(MA%MIM,MTIM,FMSUB_IMI%MIM)
   END FUNCTION

   FUNCTION FMSUB_IMR(MA,R)
      USE FMVALS
      TYPE ( FM ) FMSUB_IMR
      TYPE ( IM ) MA
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMSUB(MUFM,MTFM,FMSUB_IMR%MFM)
   END FUNCTION

   FUNCTION FMSUB_IMD(MA,D)
      USE FMVALS
      TYPE ( FM ) FMSUB_IMD
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMSUB(MUFM,MTFM,FMSUB_IMD%MFM)
   END FUNCTION

   FUNCTION FMSUB_IMZ(MA,Z)
      USE FMVALS
      TYPE ( ZM ) FMSUB_IMZ
      TYPE ( IM ) MA
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMSUB(MUZM,MTZM,FMSUB_IMZ%MZM)
   END FUNCTION

   FUNCTION FMSUB_IMC(MA,C)
      USE FMVALS
      TYPE ( ZM ) FMSUB_IMC
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMSUB(MUZM,MTZM,FMSUB_IMC%MZM)
   END FUNCTION

   FUNCTION FMSUB_IMFM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA
      TYPE ( FM ) MB,FMSUB_IMFM
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMSUB(MTFM,MB%MFM,FMSUB_IMFM%MFM)
   END FUNCTION

   FUNCTION FMSUB_IMIM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA,MB,FMSUB_IMIM
      INTENT (IN) :: MA,MB
      CALL IMSUB(MA%MIM,MB%MIM,FMSUB_IMIM%MIM)
   END FUNCTION

   FUNCTION FMSUB_IMZM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA
      TYPE ( ZM ) MB,FMSUB_IMZM
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMSUB(MUZM,MB%MZM,FMSUB_IMZM%MZM)
   END FUNCTION

   FUNCTION FMSUB_ZMI(MA,IVAL)
      USE FMVALS
      TYPE ( ZM ) MA,FMSUB_ZMI
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL FMI2M(IVAL,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMSUB(MA%MZM,MTZM,FMSUB_ZMI%MZM)
   END FUNCTION

   FUNCTION FMSUB_ZMR(MA,R)
      USE FMVALS
      TYPE ( ZM ) MA,FMSUB_ZMR
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMSUB(MA%MZM,MTZM,FMSUB_ZMR%MZM)
   END FUNCTION

   FUNCTION FMSUB_ZMD(MA,D)
      USE FMVALS
      TYPE ( ZM ) MA,FMSUB_ZMD
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMSUB(MA%MZM,MTZM,FMSUB_ZMD%MZM)
   END FUNCTION

   FUNCTION FMSUB_ZMZ(MA,Z)
      USE FMVALS
      TYPE ( ZM ) MA,FMSUB_ZMZ
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL ZMSUB(MA%MZM,MTZM,FMSUB_ZMZ%MZM)
   END FUNCTION

   FUNCTION FMSUB_ZMC(MA,C)
      USE FMVALS
      TYPE ( ZM ) MA,FMSUB_ZMC
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMSUB(MA%MZM,MTZM,FMSUB_ZMC%MZM)
   END FUNCTION

   FUNCTION FMSUB_ZMFM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MB
      TYPE ( ZM ) MA,FMSUB_ZMFM
      INTENT (IN) :: MA,MB
      CALL FMI2M(0,MTFM)
      CALL ZMCMPX(MB%MFM,MTFM,MTZM)
      CALL ZMSUB(MA%MZM,MTZM,FMSUB_ZMFM%MZM)
   END FUNCTION

   FUNCTION FMSUB_ZMIM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MB
      TYPE ( ZM ) MA,FMSUB_ZMIM
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MB%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMSUB(MA%MZM,MUZM,FMSUB_ZMIM%MZM)
   END FUNCTION

   FUNCTION FMSUB_ZMZM(MA,MB)
      USE FMVALS
      TYPE ( ZM ) MA,MB,FMSUB_ZMZM
      INTENT (IN) :: MA,MB
      CALL ZMSUB(MA%MZM,MB%MZM,FMSUB_ZMZM%MZM)
   END FUNCTION

   FUNCTION FMSUB_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMSUB_FM
      INTENT (IN) :: MA
      CALL FMEQ(MA%MFM,MTFM)
      IF (MTFM(1) /= MUNKNO .AND. MTFM(2) /= 0)  &
          MTFM(-1) = -MTFM(-1)
      CALL FMEQ(MTFM,FMSUB_FM%MFM)
   END FUNCTION

   FUNCTION FMSUB_IM(MA)
      USE FMVALS
      TYPE ( IM ) MA,FMSUB_IM
      INTENT (IN) :: MA
      CALL IMEQ(MA%MIM,MTIM)
      IF (MTIM(1) /= MUNKNO .AND. MTIM(2) /= 0)  &
          MTIM(-1) = -MTIM(-1)
      CALL IMEQ(MTIM,FMSUB_IM%MIM)
   END FUNCTION

   FUNCTION FMSUB_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMSUB_ZM
      INTENT (IN) :: MA
      CALL ZMEQ(MA%MZM,MTZM)
      IF (MTZM(1) /= MUNKNO .AND. MTZM(2) /= 0)  &
          MTZM(-1) = -MTZM(-1)
      IF (MTZM(KPTIMU+1) /= MUNKNO .AND. MTZM(KPTIMU+2) /= 0) THEN
          MTZM(KPTIMU-1) = -MTZM(KPTIMU-1)
      ENDIF
      CALL ZMEQ(MTZM,FMSUB_ZM%MZM)
   END FUNCTION

 END MODULE FMZM_5

 MODULE FMZM_6
    USE FMZM_1

    INTERFACE OPERATOR (*)
       MODULE PROCEDURE FMMPY_IFM
       MODULE PROCEDURE FMMPY_IIM
       MODULE PROCEDURE FMMPY_IZM
       MODULE PROCEDURE FMMPY_RFM
       MODULE PROCEDURE FMMPY_RIM
       MODULE PROCEDURE FMMPY_RZM
       MODULE PROCEDURE FMMPY_DFM
       MODULE PROCEDURE FMMPY_DIM
       MODULE PROCEDURE FMMPY_DZM
       MODULE PROCEDURE FMMPY_ZFM
       MODULE PROCEDURE FMMPY_ZIM
       MODULE PROCEDURE FMMPY_ZZM
       MODULE PROCEDURE FMMPY_CFM
       MODULE PROCEDURE FMMPY_CIM
       MODULE PROCEDURE FMMPY_CZM
       MODULE PROCEDURE FMMPY_FMI
       MODULE PROCEDURE FMMPY_FMR
       MODULE PROCEDURE FMMPY_FMD
       MODULE PROCEDURE FMMPY_FMZ
       MODULE PROCEDURE FMMPY_FMC
       MODULE PROCEDURE FMMPY_FMFM
       MODULE PROCEDURE FMMPY_FMIM
       MODULE PROCEDURE FMMPY_FMZM
       MODULE PROCEDURE FMMPY_IMI
       MODULE PROCEDURE FMMPY_IMR
       MODULE PROCEDURE FMMPY_IMD
       MODULE PROCEDURE FMMPY_IMZ
       MODULE PROCEDURE FMMPY_IMC
       MODULE PROCEDURE FMMPY_IMFM
       MODULE PROCEDURE FMMPY_IMIM
       MODULE PROCEDURE FMMPY_IMZM
       MODULE PROCEDURE FMMPY_ZMI
       MODULE PROCEDURE FMMPY_ZMR
       MODULE PROCEDURE FMMPY_ZMD
       MODULE PROCEDURE FMMPY_ZMZ
       MODULE PROCEDURE FMMPY_ZMC
       MODULE PROCEDURE FMMPY_ZMFM
       MODULE PROCEDURE FMMPY_ZMIM
       MODULE PROCEDURE FMMPY_ZMZM
    END INTERFACE

    INTERFACE OPERATOR (/)
       MODULE PROCEDURE FMDIV_IFM
       MODULE PROCEDURE FMDIV_IIM
       MODULE PROCEDURE FMDIV_IZM
       MODULE PROCEDURE FMDIV_RFM
       MODULE PROCEDURE FMDIV_RIM
       MODULE PROCEDURE FMDIV_RZM
       MODULE PROCEDURE FMDIV_DFM
       MODULE PROCEDURE FMDIV_DIM
       MODULE PROCEDURE FMDIV_DZM
       MODULE PROCEDURE FMDIV_ZFM
       MODULE PROCEDURE FMDIV_ZIM
       MODULE PROCEDURE FMDIV_ZZM
       MODULE PROCEDURE FMDIV_CFM
       MODULE PROCEDURE FMDIV_CIM
       MODULE PROCEDURE FMDIV_CZM
       MODULE PROCEDURE FMDIV_FMI
       MODULE PROCEDURE FMDIV_FMR
       MODULE PROCEDURE FMDIV_FMD
       MODULE PROCEDURE FMDIV_FMZ
       MODULE PROCEDURE FMDIV_FMC
       MODULE PROCEDURE FMDIV_FMFM
       MODULE PROCEDURE FMDIV_FMIM
       MODULE PROCEDURE FMDIV_FMZM
       MODULE PROCEDURE FMDIV_IMI
       MODULE PROCEDURE FMDIV_IMR
       MODULE PROCEDURE FMDIV_IMD
       MODULE PROCEDURE FMDIV_IMZ
       MODULE PROCEDURE FMDIV_IMC
       MODULE PROCEDURE FMDIV_IMFM
       MODULE PROCEDURE FMDIV_IMIM
       MODULE PROCEDURE FMDIV_IMZM
       MODULE PROCEDURE FMDIV_ZMI
       MODULE PROCEDURE FMDIV_ZMR
       MODULE PROCEDURE FMDIV_ZMD
       MODULE PROCEDURE FMDIV_ZMZ
       MODULE PROCEDURE FMDIV_ZMC
       MODULE PROCEDURE FMDIV_ZMFM
       MODULE PROCEDURE FMDIV_ZMIM
       MODULE PROCEDURE FMDIV_ZMZM
    END INTERFACE

 CONTAINS

!                                                                   *

   FUNCTION FMMPY_IFM(IVAL,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMMPY_IFM
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMMPYI(MA%MFM,IVAL,FMMPY_IFM%MFM)
   END FUNCTION

   FUNCTION FMMPY_IIM(IVAL,MA)
      USE FMVALS
      TYPE ( IM ) MA,FMMPY_IIM
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL IMMPYI(MA%MIM,IVAL,FMMPY_IIM%MIM)
   END FUNCTION

   FUNCTION FMMPY_IZM(IVAL,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMMPY_IZM
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL ZMMPYI(MA%MZM,IVAL,FMMPY_IZM%MZM)
   END FUNCTION

   FUNCTION FMMPY_RFM(R,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMMPY_RFM
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL FMMPY(MTFM,MA%MFM,FMMPY_RFM%MFM)
   END FUNCTION

   FUNCTION FMMPY_RIM(R,MA)
      USE FMVALS
      TYPE ( FM ) FMMPY_RIM
      TYPE ( IM ) MA
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMMPY(MTFM,MUFM,FMMPY_RIM%MFM)
   END FUNCTION

   FUNCTION FMMPY_RZM(R,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMMPY_RZM
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMMPY(MTZM,MA%MZM,FMMPY_RZM%MZM)
   END FUNCTION

   FUNCTION FMMPY_DFM(D,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMMPY_DFM
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL FMMPY(MTFM,MA%MFM,FMMPY_DFM%MFM)
   END FUNCTION

   FUNCTION FMMPY_DIM(D,MA)
      USE FMVALS
      TYPE ( FM ) FMMPY_DIM
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMMPY(MTFM,MUFM,FMMPY_DIM%MFM)
   END FUNCTION

   FUNCTION FMMPY_DZM(D,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMMPY_DZM
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMMPY(MTZM,MA%MZM,FMMPY_DZM%MZM)
   END FUNCTION

   FUNCTION FMMPY_ZFM(Z,MA)
      USE FMVALS
      TYPE ( ZM ) FMMPY_ZFM
      TYPE ( FM ) MA
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMMPY(MTZM,MUZM,FMMPY_ZFM%MZM)
   END FUNCTION

   FUNCTION FMMPY_ZIM(Z,MA)
      USE FMVALS
      TYPE ( ZM ) FMMPY_ZIM
      TYPE ( IM ) MA
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMMPY(MTZM,MUZM,FMMPY_ZIM%MZM)
   END FUNCTION

   FUNCTION FMMPY_ZZM(Z,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMMPY_ZZM
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL ZMMPY(MTZM,MA%MZM,FMMPY_ZZM%MZM)
   END FUNCTION

   FUNCTION FMMPY_CFM(C,MA)
      USE FMVALS
      TYPE ( ZM ) FMMPY_CFM
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMMPY(MTZM,MUZM,FMMPY_CFM%MZM)
   END FUNCTION

   FUNCTION FMMPY_CIM(C,MA)
      USE FMVALS
      TYPE ( ZM ) FMMPY_CIM
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMMPY(MTZM,MUZM,FMMPY_CIM%MZM)
   END FUNCTION

   FUNCTION FMMPY_CZM(C,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMMPY_CZM
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMMPY(MTZM,MA%MZM,FMMPY_CZM%MZM)
   END FUNCTION

   FUNCTION FMMPY_FMI(MA,IVAL)
      USE FMVALS
      TYPE ( FM ) MA,FMMPY_FMI
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL FMMPYI(MA%MFM,IVAL,FMMPY_FMI%MFM)
   END FUNCTION

   FUNCTION FMMPY_FMR(MA,R)
      USE FMVALS
      TYPE ( FM ) MA,FMMPY_FMR
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL FMMPY(MA%MFM,MTFM,FMMPY_FMR%MFM)
   END FUNCTION

   FUNCTION FMMPY_FMD(MA,D)
      USE FMVALS
      TYPE ( FM ) MA,FMMPY_FMD
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL FMMPY(MA%MFM,MTFM,FMMPY_FMD%MFM)
   END FUNCTION

   FUNCTION FMMPY_FMZ(MA,Z)
      USE FMVALS
      TYPE ( ZM ) FMMPY_FMZ
      TYPE ( FM ) MA
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMMPY(MUZM,MTZM,FMMPY_FMZ%MZM)
   END FUNCTION

   FUNCTION FMMPY_FMC(MA,C)
      USE FMVALS
      TYPE ( ZM ) FMMPY_FMC
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMMPY(MUZM,MTZM,FMMPY_FMC%MZM)
   END FUNCTION

   FUNCTION FMMPY_FMFM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMMPY_FMFM
      INTENT (IN) :: MA,MB
      CALL FMMPY(MA%MFM,MB%MFM,FMMPY_FMFM%MFM)
   END FUNCTION

   FUNCTION FMMPY_FMIM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,FMMPY_FMIM
      TYPE ( IM ) MB
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MB%MIM,MTFM)
      CALL FMMPY(MA%MFM,MTFM,FMMPY_FMIM%MFM)
   END FUNCTION

   FUNCTION FMMPY_FMZM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA
      TYPE ( ZM ) MB,FMMPY_FMZM
      INTENT (IN) :: MA,MB
      CALL FMI2M(0,MTFM)
      CALL ZMCMPX(MA%MFM,MTFM,MTZM)
      CALL ZMMPY(MTZM,MB%MZM,FMMPY_FMZM%MZM)
   END FUNCTION

   FUNCTION FMMPY_IMI(MA,IVAL)
      USE FMVALS
      TYPE ( IM ) MA,FMMPY_IMI
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL IMMPYI(MA%MIM,IVAL,FMMPY_IMI%MIM)
   END FUNCTION

   FUNCTION FMMPY_IMR(MA,R)
      USE FMVALS
      TYPE ( FM ) FMMPY_IMR
      TYPE ( IM ) MA
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMMPY(MUFM,MTFM,FMMPY_IMR%MFM)
   END FUNCTION

   FUNCTION FMMPY_IMD(MA,D)
      USE FMVALS
      TYPE ( FM ) FMMPY_IMD
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMMPY(MUFM,MTFM,FMMPY_IMD%MFM)
   END FUNCTION

   FUNCTION FMMPY_IMZ(MA,Z)
      USE FMVALS
      TYPE ( ZM ) FMMPY_IMZ
      TYPE ( IM ) MA
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMMPY(MUZM,MTZM,FMMPY_IMZ%MZM)
   END FUNCTION

   FUNCTION FMMPY_IMC(MA,C)
      USE FMVALS
      TYPE ( ZM ) FMMPY_IMC
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMMPY(MUZM,MTZM,FMMPY_IMC%MZM)
   END FUNCTION

   FUNCTION FMMPY_IMFM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA
      TYPE ( FM ) MB,FMMPY_IMFM
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMMPY(MTFM,MB%MFM,FMMPY_IMFM%MFM)
   END FUNCTION

   FUNCTION FMMPY_IMIM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA,MB,FMMPY_IMIM
      INTENT (IN) :: MA,MB
      CALL IMMPY(MA%MIM,MB%MIM,FMMPY_IMIM%MIM)
   END FUNCTION

   FUNCTION FMMPY_IMZM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA
      TYPE ( ZM ) MB,FMMPY_IMZM
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMMPY(MUZM,MB%MZM,FMMPY_IMZM%MZM)
   END FUNCTION

   FUNCTION FMMPY_ZMI(MA,IVAL)
      USE FMVALS
      TYPE ( ZM ) MA,FMMPY_ZMI
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL ZMMPYI(MA%MZM,IVAL,FMMPY_ZMI%MZM)
   END FUNCTION

   FUNCTION FMMPY_ZMR(MA,R)
      USE FMVALS
      TYPE ( ZM ) MA,FMMPY_ZMR
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMMPY(MA%MZM,MTZM,FMMPY_ZMR%MZM)
   END FUNCTION

   FUNCTION FMMPY_ZMD(MA,D)
      USE FMVALS
      TYPE ( ZM ) MA,FMMPY_ZMD
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMMPY(MA%MZM,MTZM,FMMPY_ZMD%MZM)
   END FUNCTION

   FUNCTION FMMPY_ZMZ(MA,Z)
      USE FMVALS
      TYPE ( ZM ) MA,FMMPY_ZMZ
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL ZMMPY(MA%MZM,MTZM,FMMPY_ZMZ%MZM)
   END FUNCTION

   FUNCTION FMMPY_ZMC(MA,C)
      USE FMVALS
      TYPE ( ZM ) MA,FMMPY_ZMC
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMMPY(MA%MZM,MTZM,FMMPY_ZMC%MZM)
   END FUNCTION

   FUNCTION FMMPY_ZMFM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MB
      TYPE ( ZM ) MA,FMMPY_ZMFM
      INTENT (IN) :: MA,MB
      CALL FMI2M(0,MTFM)
      CALL ZMCMPX(MB%MFM,MTFM,MTZM)
      CALL ZMMPY(MA%MZM,MTZM,FMMPY_ZMFM%MZM)
   END FUNCTION

   FUNCTION FMMPY_ZMIM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MB
      TYPE ( ZM ) MA,FMMPY_ZMIM
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MB%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMMPY(MA%MZM,MUZM,FMMPY_ZMIM%MZM)
   END FUNCTION

   FUNCTION FMMPY_ZMZM(MA,MB)
      USE FMVALS
      TYPE ( ZM ) MA,MB,FMMPY_ZMZM
      INTENT (IN) :: MA,MB
      CALL ZMMPY(MA%MZM,MB%MZM,FMMPY_ZMZM%MZM)
   END FUNCTION

!                                                                   /

   FUNCTION FMDIV_IFM(IVAL,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMDIV_IFM
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      CALL FMDIV(MTFM,MA%MFM,FMDIV_IFM%MFM)
   END FUNCTION

   FUNCTION FMDIV_IIM(IVAL,MA)
      USE FMVALS
      TYPE ( IM ) MA,FMDIV_IIM
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL IMI2M(IVAL,MTIM)
      CALL IMDIV(MTIM,MA%MIM,FMDIV_IIM%MIM)
   END FUNCTION

   FUNCTION FMDIV_IZM(IVAL,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMDIV_IZM
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMDIV(MTZM,MA%MZM,FMDIV_IZM%MZM)
   END FUNCTION

   FUNCTION FMDIV_RFM(R,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMDIV_RFM
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL FMDIV(MTFM,MA%MFM,FMDIV_RFM%MFM)
   END FUNCTION

   FUNCTION FMDIV_RIM(R,MA)
      USE FMVALS
      TYPE ( FM ) FMDIV_RIM
      TYPE ( IM ) MA
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMDIV(MTFM,MUFM,FMDIV_RIM%MFM)
   END FUNCTION

   FUNCTION FMDIV_RZM(R,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMDIV_RZM
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMDIV(MTZM,MA%MZM,FMDIV_RZM%MZM)
   END FUNCTION

   FUNCTION FMDIV_DFM(D,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMDIV_DFM
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL FMDIV(MTFM,MA%MFM,FMDIV_DFM%MFM)
   END FUNCTION

   FUNCTION FMDIV_DIM(D,MA)
      USE FMVALS
      TYPE ( FM ) FMDIV_DIM
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMDIV(MTFM,MUFM,FMDIV_DIM%MFM)
   END FUNCTION

   FUNCTION FMDIV_DZM(D,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMDIV_DZM
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMDIV(MTZM,MA%MZM,FMDIV_DZM%MZM)
   END FUNCTION

   FUNCTION FMDIV_ZFM(Z,MA)
      USE FMVALS
      TYPE ( ZM ) FMDIV_ZFM
      TYPE ( FM ) MA
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMDIV(MTZM,MUZM,FMDIV_ZFM%MZM)
   END FUNCTION

   FUNCTION FMDIV_ZIM(Z,MA)
      USE FMVALS
      TYPE ( ZM ) FMDIV_ZIM
      TYPE ( IM ) MA
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMDIV(MTZM,MUZM,FMDIV_ZIM%MZM)
   END FUNCTION

   FUNCTION FMDIV_ZZM(Z,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMDIV_ZZM
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL ZMDIV(MTZM,MA%MZM,FMDIV_ZZM%MZM)
   END FUNCTION

   FUNCTION FMDIV_CFM(C,MA)
      USE FMVALS
      TYPE ( ZM ) FMDIV_CFM
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMDIV(MTZM,MUZM,FMDIV_CFM%MZM)
   END FUNCTION

   FUNCTION FMDIV_CIM(C,MA)
      USE FMVALS
      TYPE ( ZM ) FMDIV_CIM
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMDIV(MTZM,MUZM,FMDIV_CIM%MZM)
   END FUNCTION

   FUNCTION FMDIV_CZM(C,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMDIV_CZM
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMDIV(MTZM,MA%MZM,FMDIV_CZM%MZM)
   END FUNCTION

   FUNCTION FMDIV_FMI(MA,IVAL)
      USE FMVALS
      TYPE ( FM ) MA,FMDIV_FMI
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL FMDIVI(MA%MFM,IVAL,FMDIV_FMI%MFM)
   END FUNCTION

   FUNCTION FMDIV_FMR(MA,R)
      USE FMVALS
      TYPE ( FM ) MA,FMDIV_FMR
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL FMDIV(MA%MFM,MTFM,FMDIV_FMR%MFM)
   END FUNCTION

   FUNCTION FMDIV_FMD(MA,D)
      USE FMVALS
      TYPE ( FM ) MA,FMDIV_FMD
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL FMDIV(MA%MFM,MTFM,FMDIV_FMD%MFM)
   END FUNCTION

   FUNCTION FMDIV_FMZ(MA,Z)
      USE FMVALS
      TYPE ( ZM ) FMDIV_FMZ
      TYPE ( FM ) MA
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMDIV(MUZM,MTZM,FMDIV_FMZ%MZM)
   END FUNCTION

   FUNCTION FMDIV_FMC(MA,C)
      USE FMVALS
      TYPE ( ZM ) FMDIV_FMC
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMDIV(MUZM,MTZM,FMDIV_FMC%MZM)
   END FUNCTION

   FUNCTION FMDIV_FMFM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMDIV_FMFM
      INTENT (IN) :: MA,MB
      CALL FMDIV(MA%MFM,MB%MFM,FMDIV_FMFM%MFM)
   END FUNCTION

   FUNCTION FMDIV_FMIM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,FMDIV_FMIM
      TYPE ( IM ) MB
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MB%MIM,MTFM)
      CALL FMDIV(MA%MFM,MTFM,FMDIV_FMIM%MFM)
   END FUNCTION

   FUNCTION FMDIV_FMZM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA
      TYPE ( ZM ) MB,FMDIV_FMZM
      INTENT (IN) :: MA,MB
      CALL FMI2M(0,MTFM)
      CALL ZMCMPX(MA%MFM,MTFM,MTZM)
      CALL ZMDIV(MTZM,MB%MZM,FMDIV_FMZM%MZM)
   END FUNCTION

   FUNCTION FMDIV_IMI(MA,IVAL)
      USE FMVALS
      TYPE ( IM ) MA,FMDIV_IMI
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL IMDIVI(MA%MIM,IVAL,FMDIV_IMI%MIM)
   END FUNCTION

   FUNCTION FMDIV_IMR(MA,R)
      USE FMVALS
      TYPE ( FM ) FMDIV_IMR
      TYPE ( IM ) MA
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMDIV(MUFM,MTFM,FMDIV_IMR%MFM)
   END FUNCTION

   FUNCTION FMDIV_IMD(MA,D)
      USE FMVALS
      TYPE ( FM ) FMDIV_IMD
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMDIV(MUFM,MTFM,FMDIV_IMD%MFM)
   END FUNCTION

   FUNCTION FMDIV_IMZ(MA,Z)
      USE FMVALS
      TYPE ( ZM ) FMDIV_IMZ
      TYPE ( IM ) MA
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMDIV(MUZM,MTZM,FMDIV_IMZ%MZM)
   END FUNCTION

   FUNCTION FMDIV_IMC(MA,C)
      USE FMVALS
      TYPE ( ZM ) FMDIV_IMC
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMDIV(MUZM,MTZM,FMDIV_IMC%MZM)
   END FUNCTION

   FUNCTION FMDIV_IMFM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA
      TYPE ( FM ) MB,FMDIV_IMFM
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMDIV(MTFM,MB%MFM,FMDIV_IMFM%MFM)
   END FUNCTION

   FUNCTION FMDIV_IMIM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA,MB,FMDIV_IMIM
      INTENT (IN) :: MA,MB
      CALL IMDIV(MA%MIM,MB%MIM,FMDIV_IMIM%MIM)
   END FUNCTION

   FUNCTION FMDIV_IMZM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA
      TYPE ( ZM ) MB,FMDIV_IMZM
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMDIV(MUZM,MB%MZM,FMDIV_IMZM%MZM)
   END FUNCTION

   FUNCTION FMDIV_ZMI(MA,IVAL)
      USE FMVALS
      TYPE ( ZM ) MA,FMDIV_ZMI
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL ZMDIVI(MA%MZM,IVAL,FMDIV_ZMI%MZM)
   END FUNCTION

   FUNCTION FMDIV_ZMR(MA,R)
      USE FMVALS
      TYPE ( ZM ) MA,FMDIV_ZMR
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMDIV(MA%MZM,MTZM,FMDIV_ZMR%MZM)
   END FUNCTION

   FUNCTION FMDIV_ZMD(MA,D)
      USE FMVALS
      TYPE ( ZM ) MA,FMDIV_ZMD
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMDIV(MA%MZM,MTZM,FMDIV_ZMD%MZM)
   END FUNCTION

   FUNCTION FMDIV_ZMZ(MA,Z)
      USE FMVALS
      TYPE ( ZM ) MA,FMDIV_ZMZ
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL ZMDIV(MA%MZM,MTZM,FMDIV_ZMZ%MZM)
   END FUNCTION

   FUNCTION FMDIV_ZMC(MA,C)
      USE FMVALS
      TYPE ( ZM ) MA,FMDIV_ZMC
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMDIV(MA%MZM,MTZM,FMDIV_ZMC%MZM)
   END FUNCTION

   FUNCTION FMDIV_ZMFM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MB
      TYPE ( ZM ) MA,FMDIV_ZMFM
      INTENT (IN) :: MA,MB
      CALL FMI2M(0,MTFM)
      CALL ZMCMPX(MB%MFM,MTFM,MTZM)
      CALL ZMDIV(MA%MZM,MTZM,FMDIV_ZMFM%MZM)
   END FUNCTION

   FUNCTION FMDIV_ZMIM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MB
      TYPE ( ZM ) MA,FMDIV_ZMIM
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MB%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMDIV(MA%MZM,MUZM,FMDIV_ZMIM%MZM)
   END FUNCTION

   FUNCTION FMDIV_ZMZM(MA,MB)
      USE FMVALS
      TYPE ( ZM ) MA,MB,FMDIV_ZMZM
      INTENT (IN) :: MA,MB
      CALL ZMDIV(MA%MZM,MB%MZM,FMDIV_ZMZM%MZM)
   END FUNCTION

 END MODULE FMZM_6

 MODULE FMZM_7
    USE FMZM_1

    INTERFACE OPERATOR (**)
       MODULE PROCEDURE FMPWR_IFM
       MODULE PROCEDURE FMPWR_IIM
       MODULE PROCEDURE FMPWR_IZM
       MODULE PROCEDURE FMPWR_RFM
       MODULE PROCEDURE FMPWR_RIM
       MODULE PROCEDURE FMPWR_RZM
       MODULE PROCEDURE FMPWR_DFM
       MODULE PROCEDURE FMPWR_DIM
       MODULE PROCEDURE FMPWR_DZM
       MODULE PROCEDURE FMPWR_ZFM
       MODULE PROCEDURE FMPWR_ZIM
       MODULE PROCEDURE FMPWR_ZZM
       MODULE PROCEDURE FMPWR_CFM
       MODULE PROCEDURE FMPWR_CIM
       MODULE PROCEDURE FMPWR_CZM
       MODULE PROCEDURE FMPWR_FMI
       MODULE PROCEDURE FMPWR_FMR
       MODULE PROCEDURE FMPWR_FMD
       MODULE PROCEDURE FMPWR_FMZ
       MODULE PROCEDURE FMPWR_FMC
       MODULE PROCEDURE FMPWR_FMFM
       MODULE PROCEDURE FMPWR_FMIM
       MODULE PROCEDURE FMPWR_FMZM
       MODULE PROCEDURE FMPWR_IMI
       MODULE PROCEDURE FMPWR_IMR
       MODULE PROCEDURE FMPWR_IMD
       MODULE PROCEDURE FMPWR_IMZ
       MODULE PROCEDURE FMPWR_IMC
       MODULE PROCEDURE FMPWR_IMFM
       MODULE PROCEDURE FMPWR_IMIM
       MODULE PROCEDURE FMPWR_IMZM
       MODULE PROCEDURE FMPWR_ZMI
       MODULE PROCEDURE FMPWR_ZMR
       MODULE PROCEDURE FMPWR_ZMD
       MODULE PROCEDURE FMPWR_ZMZ
       MODULE PROCEDURE FMPWR_ZMC
       MODULE PROCEDURE FMPWR_ZMFM
       MODULE PROCEDURE FMPWR_ZMIM
       MODULE PROCEDURE FMPWR_ZMZM
    END INTERFACE

   INTERFACE ABS
      MODULE PROCEDURE FMABS_FM
      MODULE PROCEDURE FMABS_IM
      MODULE PROCEDURE FMABS_ZM
   END INTERFACE

   INTERFACE ACOS
      MODULE PROCEDURE FMACOS_FM
      MODULE PROCEDURE FMACOS_ZM
   END INTERFACE

   INTERFACE AIMAG
      MODULE PROCEDURE FMAIMAG_ZM
   END INTERFACE

   INTERFACE AINT
      MODULE PROCEDURE FMAINT_FM
      MODULE PROCEDURE FMAINT_ZM
   END INTERFACE

   INTERFACE ANINT
      MODULE PROCEDURE FMANINT_FM
      MODULE PROCEDURE FMANINT_ZM
   END INTERFACE

   INTERFACE ASIN
      MODULE PROCEDURE FMASIN_FM
      MODULE PROCEDURE FMASIN_ZM
   END INTERFACE

   INTERFACE ATAN
      MODULE PROCEDURE FMATAN_FM
      MODULE PROCEDURE FMATAN_ZM
   END INTERFACE

   INTERFACE ATAN2
      MODULE PROCEDURE FMATAN2_FM
   END INTERFACE

   INTERFACE BTEST
      MODULE PROCEDURE FMBTEST_IM
   END INTERFACE

   INTERFACE CEILING
      MODULE PROCEDURE FMCEILING_FM
      MODULE PROCEDURE FMCEILING_ZM
   END INTERFACE

   INTERFACE CMPLX
      MODULE PROCEDURE FMCMPLX_FM
      MODULE PROCEDURE FMCMPLX_IM
   END INTERFACE

   INTERFACE CONJG
      MODULE PROCEDURE FMCONJG_ZM
   END INTERFACE

   INTERFACE COS
      MODULE PROCEDURE FMCOS_FM
      MODULE PROCEDURE FMCOS_ZM
   END INTERFACE

   INTERFACE COSH
      MODULE PROCEDURE FMCOSH_FM
      MODULE PROCEDURE FMCOSH_ZM
   END INTERFACE

   INTERFACE DBLE
      MODULE PROCEDURE FMDBLE_FM
      MODULE PROCEDURE FMDBLE_IM
      MODULE PROCEDURE FMDBLE_ZM
   END INTERFACE

   INTERFACE DIGITS
      MODULE PROCEDURE FMDIGITS_FM
      MODULE PROCEDURE FMDIGITS_IM
      MODULE PROCEDURE FMDIGITS_ZM
   END INTERFACE

   INTERFACE DIM
      MODULE PROCEDURE FMDIM_FM
      MODULE PROCEDURE FMDIM_IM
   END INTERFACE

   INTERFACE DINT
      MODULE PROCEDURE FMDINT_FM
      MODULE PROCEDURE FMDINT_ZM
   END INTERFACE

   INTERFACE DOTPRODUCT
      MODULE PROCEDURE FMDOTPRODUCT_FM
      MODULE PROCEDURE FMDOTPRODUCT_IM
      MODULE PROCEDURE FMDOTPRODUCT_ZM
   END INTERFACE

 CONTAINS

!                                                                  **

   FUNCTION FMPWR_IFM(IVAL,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMPWR_IFM
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      CALL FMPWR(MTFM,MA%MFM,FMPWR_IFM%MFM)
   END FUNCTION

   FUNCTION FMPWR_IIM(IVAL,MA)
      USE FMVALS
      TYPE ( IM ) MA,FMPWR_IIM
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL IMI2M(IVAL,MTIM)
      CALL IMPWR(MTIM,MA%MIM,FMPWR_IIM%MIM)
   END FUNCTION

   FUNCTION FMPWR_IZM(IVAL,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMPWR_IZM
      INTEGER IVAL
      INTENT (IN) :: IVAL,MA
      CALL FMI2M(IVAL,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMPWR(MTZM,MA%MZM,FMPWR_IZM%MZM)
   END FUNCTION

   FUNCTION FMPWR_RFM(R,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMPWR_RFM
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL FMPWR(MTFM,MA%MFM,FMPWR_RFM%MFM)
   END FUNCTION

   FUNCTION FMPWR_RIM(R,MA)
      USE FMVALS
      TYPE ( FM ) FMPWR_RIM
      TYPE ( IM ) MA
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMPWR(MTFM,MUFM,FMPWR_RIM%MFM)
   END FUNCTION

   FUNCTION FMPWR_RZM(R,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMPWR_RZM
      REAL R
      INTENT (IN) :: R,MA
      CALL FMSP2M(R,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMPWR(MTZM,MA%MZM,FMPWR_RZM%MZM)
   END FUNCTION

   FUNCTION FMPWR_DFM(D,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMPWR_DFM
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL FMPWR(MTFM,MA%MFM,FMPWR_DFM%MFM)
   END FUNCTION

   FUNCTION FMPWR_DIM(D,MA)
      USE FMVALS
      TYPE ( FM ) FMPWR_DIM
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMPWR(MTFM,MUFM,FMPWR_DIM%MFM)
   END FUNCTION

   FUNCTION FMPWR_DZM(D,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMPWR_DZM
      DOUBLE PRECISION D
      INTENT (IN) :: D,MA
      CALL FMDP2M(D,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMPWR(MTZM,MA%MZM,FMPWR_DZM%MZM)
   END FUNCTION

   FUNCTION FMPWR_ZFM(Z,MA)
      USE FMVALS
      TYPE ( ZM ) FMPWR_ZFM
      TYPE ( FM ) MA
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMPWR(MTZM,MUZM,FMPWR_ZFM%MZM)
   END FUNCTION

   FUNCTION FMPWR_ZIM(Z,MA)
      USE FMVALS
      TYPE ( ZM ) FMPWR_ZIM
      TYPE ( IM ) MA
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMPWR(MTZM,MUZM,FMPWR_ZIM%MZM)
   END FUNCTION

   FUNCTION FMPWR_ZZM(Z,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMPWR_ZZM
      COMPLEX Z
      INTENT (IN) :: Z,MA
      CALL ZMZ2M(Z,MTZM)
      CALL ZMPWR(MTZM,MA%MZM,FMPWR_ZZM%MZM)
   END FUNCTION

   FUNCTION FMPWR_CFM(C,MA)
      USE FMVALS
      TYPE ( ZM ) FMPWR_CFM
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMPWR(MTZM,MUZM,FMPWR_CFM%MZM)
   END FUNCTION

   FUNCTION FMPWR_CIM(C,MA)
      USE FMVALS
      TYPE ( ZM ) FMPWR_CIM
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMPWR(MTZM,MUZM,FMPWR_CIM%MZM)
   END FUNCTION

   FUNCTION FMPWR_CZM(C,MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMPWR_CZM
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C,MA
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMPWR(MTZM,MA%MZM,FMPWR_CZM%MZM)
   END FUNCTION

   FUNCTION FMPWR_FMI(MA,IVAL)
      USE FMVALS
      TYPE ( FM ) MA,FMPWR_FMI
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL FMIPWR(MA%MFM,IVAL,FMPWR_FMI%MFM)
   END FUNCTION

   FUNCTION FMPWR_FMR(MA,R)
      USE FMVALS
      TYPE ( FM ) MA,FMPWR_FMR
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL FMPWR(MA%MFM,MTFM,FMPWR_FMR%MFM)
   END FUNCTION

   FUNCTION FMPWR_FMD(MA,D)
      USE FMVALS
      TYPE ( FM ) MA,FMPWR_FMD
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL FMPWR(MA%MFM,MTFM,FMPWR_FMD%MFM)
   END FUNCTION

   FUNCTION FMPWR_FMZ(MA,Z)
      USE FMVALS
      TYPE ( ZM ) FMPWR_FMZ
      TYPE ( FM ) MA
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMPWR(MUZM,MTZM,FMPWR_FMZ%MZM)
   END FUNCTION

   FUNCTION FMPWR_FMC(MA,C)
      USE FMVALS
      TYPE ( ZM ) FMPWR_FMC
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,MUZM)
      CALL ZMPWR(MUZM,MTZM,FMPWR_FMC%MZM)
   END FUNCTION

   FUNCTION FMPWR_FMFM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMPWR_FMFM
      INTENT (IN) :: MA,MB
      CALL FMPWR(MA%MFM,MB%MFM,FMPWR_FMFM%MFM)
   END FUNCTION

   FUNCTION FMPWR_FMIM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,FMPWR_FMIM
      TYPE ( IM ) MB
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MB%MIM,MTFM)
      CALL FMPWR(MA%MFM,MTFM,FMPWR_FMIM%MFM)
   END FUNCTION

   FUNCTION FMPWR_FMZM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA
      TYPE ( ZM ) MB,FMPWR_FMZM
      INTENT (IN) :: MA,MB
      CALL FMI2M(0,MTFM)
      CALL ZMCMPX(MA%MFM,MTFM,MTZM)
      CALL ZMPWR(MTZM,MB%MZM,FMPWR_FMZM%MZM)
   END FUNCTION

   FUNCTION FMPWR_IMI(MA,IVAL)
      USE FMVALS
      TYPE ( IM ) MA,FMPWR_IMI
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL IMI2M(IVAL,MTIM)
      CALL IMPWR(MA%MIM,MTIM,FMPWR_IMI%MIM)
   END FUNCTION

   FUNCTION FMPWR_IMR(MA,R)
      USE FMVALS
      TYPE ( FM ) FMPWR_IMR
      TYPE ( IM ) MA
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMPWR(MUFM,MTFM,FMPWR_IMR%MFM)
   END FUNCTION

   FUNCTION FMPWR_IMD(MA,D)
      USE FMVALS
      TYPE ( FM ) FMPWR_IMD
      TYPE ( IM ) MA
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL IMI2FM(MA%MIM,MUFM)
      CALL FMPWR(MUFM,MTFM,FMPWR_IMD%MFM)
   END FUNCTION

   FUNCTION FMPWR_IMZ(MA,Z)
      USE FMVALS
      TYPE ( ZM ) FMPWR_IMZ
      TYPE ( IM ) MA
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMPWR(MUZM,MTZM,FMPWR_IMZ%MZM)
   END FUNCTION

   FUNCTION FMPWR_IMC(MA,C)
      USE FMVALS
      TYPE ( ZM ) FMPWR_IMC
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMPWR(MUZM,MTZM,FMPWR_IMC%MZM)
   END FUNCTION

   FUNCTION FMPWR_IMFM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA
      TYPE ( FM ) MB,FMPWR_IMFM
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMPWR(MTFM,MB%MFM,FMPWR_IMFM%MFM)
   END FUNCTION

   FUNCTION FMPWR_IMIM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA,MB,FMPWR_IMIM
      INTENT (IN) :: MA,MB
      CALL IMPWR(MA%MIM,MB%MIM,FMPWR_IMIM%MIM)
   END FUNCTION

   FUNCTION FMPWR_IMZM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA
      TYPE ( ZM ) MB,FMPWR_IMZM
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMPWR(MUZM,MB%MZM,FMPWR_IMZM%MZM)
   END FUNCTION

   FUNCTION FMPWR_ZMI(MA,IVAL)
      USE FMVALS
      TYPE ( ZM ) MA,FMPWR_ZMI
      INTEGER IVAL
      INTENT (IN) :: MA,IVAL
      CALL ZMIPWR(MA%MZM,IVAL,FMPWR_ZMI%MZM)
   END FUNCTION

   FUNCTION FMPWR_ZMR(MA,R)
      USE FMVALS
      TYPE ( ZM ) MA,FMPWR_ZMR
      REAL R
      INTENT (IN) :: MA,R
      CALL FMSP2M(R,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMPWR(MA%MZM,MTZM,FMPWR_ZMR%MZM)
   END FUNCTION

   FUNCTION FMPWR_ZMD(MA,D)
      USE FMVALS
      TYPE ( ZM ) MA,FMPWR_ZMD
      DOUBLE PRECISION D
      INTENT (IN) :: MA,D
      CALL FMDP2M(D,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMPWR(MA%MZM,MTZM,FMPWR_ZMD%MZM)
   END FUNCTION

   FUNCTION FMPWR_ZMZ(MA,Z)
      USE FMVALS
      TYPE ( ZM ) MA,FMPWR_ZMZ
      COMPLEX Z
      INTENT (IN) :: MA,Z
      CALL ZMZ2M(Z,MTZM)
      CALL ZMPWR(MA%MZM,MTZM,FMPWR_ZMZ%MZM)
   END FUNCTION

   FUNCTION FMPWR_ZMC(MA,C)
      USE FMVALS
      TYPE ( ZM ) MA,FMPWR_ZMC
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: MA,C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,MTZM)
      CALL ZMPWR(MA%MZM,MTZM,FMPWR_ZMC%MZM)
   END FUNCTION

   FUNCTION FMPWR_ZMFM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MB
      TYPE ( ZM ) MA,FMPWR_ZMFM
      INTENT (IN) :: MA,MB
      CALL FMI2M(0,MTFM)
      CALL ZMCMPX(MB%MFM,MTFM,MTZM)
      CALL ZMPWR(MA%MZM,MTZM,FMPWR_ZMFM%MZM)
   END FUNCTION

   FUNCTION FMPWR_ZMIM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MB
      TYPE ( ZM ) MA,FMPWR_ZMIM
      INTENT (IN) :: MA,MB
      CALL IMI2FM(MB%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,MUZM)
      CALL ZMPWR(MA%MZM,MUZM,FMPWR_ZMIM%MZM)
   END FUNCTION

   FUNCTION FMPWR_ZMZM(MA,MB)
      USE FMVALS
      TYPE ( ZM ) MA,MB,FMPWR_ZMZM
      INTENT (IN) :: MA,MB
      CALL ZMPWR(MA%MZM,MB%MZM,FMPWR_ZMZM%MZM)
   END FUNCTION

!                                                                 ABS

   FUNCTION FMABS_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMABS_FM
      INTENT (IN) :: MA
      CALL FMABS(MA%MFM,FMABS_FM%MFM)
   END FUNCTION

   FUNCTION FMABS_IM(MA)
      USE FMVALS
      TYPE ( IM ) MA,FMABS_IM
      INTENT (IN) :: MA
      CALL IMABS(MA%MIM,FMABS_IM%MIM)
   END FUNCTION

   FUNCTION FMABS_ZM(MA)
      USE FMVALS
      TYPE ( FM ) FMABS_ZM
      TYPE ( ZM ) MA
      INTENT (IN) :: MA
      CALL ZMABS(MA%MZM,FMABS_ZM%MFM)
   END FUNCTION

!                                                                ACOS

   FUNCTION FMACOS_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMACOS_FM
      INTENT (IN) :: MA
      CALL FMACOS(MA%MFM,FMACOS_FM%MFM)
   END FUNCTION

   FUNCTION FMACOS_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMACOS_ZM
      INTENT (IN) :: MA
      CALL ZMACOS(MA%MZM,FMACOS_ZM%MZM)
   END FUNCTION

!                                                               AIMAG

   FUNCTION FMAIMAG_ZM(MA)
      USE FMVALS
      TYPE ( FM ) FMAIMAG_ZM
      TYPE ( ZM ) MA
      INTENT (IN) :: MA
      CALL ZMIMAG(MA%MZM,FMAIMAG_ZM%MFM)
   END FUNCTION

!                                                                AINT

   FUNCTION FMAINT_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMAINT_FM
      INTENT (IN) :: MA
      CALL FMINT(MA%MFM,FMAINT_FM%MFM)
   END FUNCTION

   FUNCTION FMAINT_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMAINT_ZM
      INTENT (IN) :: MA
      CALL ZMINT(MA%MZM,FMAINT_ZM%MZM)
   END FUNCTION

!                                                               ANINT

   FUNCTION FMANINT_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMANINT_FM
      INTENT (IN) :: MA
      CALL FMNINT(MA%MFM,FMANINT_FM%MFM)
   END FUNCTION

   FUNCTION FMANINT_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMANINT_ZM
      INTENT (IN) :: MA
      CALL ZMNINT(MA%MZM,FMANINT_ZM%MZM)
   END FUNCTION

!                                                                ASIN

   FUNCTION FMASIN_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMASIN_FM
      INTENT (IN) :: MA
      CALL FMASIN(MA%MFM,FMASIN_FM%MFM)
   END FUNCTION

   FUNCTION FMASIN_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMASIN_ZM
      INTENT (IN) :: MA
      CALL ZMASIN(MA%MZM,FMASIN_ZM%MZM)
   END FUNCTION

!                                                                ATAN

   FUNCTION FMATAN_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMATAN_FM
      INTENT (IN) :: MA
      CALL FMATAN(MA%MFM,FMATAN_FM%MFM)
   END FUNCTION

   FUNCTION FMATAN_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMATAN_ZM
      INTENT (IN) :: MA
      CALL ZMATAN(MA%MZM,FMATAN_ZM%MZM)
   END FUNCTION

!                                                               ATAN2

   FUNCTION FMATAN2_FM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMATAN2_FM
      INTENT (IN) :: MA,MB
      CALL FMATN2(MA%MFM,MB%MFM,FMATAN2_FM%MFM)
   END FUNCTION

!                                                               BTEST

   FUNCTION FMBTEST_IM(MA,POS)
      TYPE ( IM ) MA
      INTEGER POS
      LOGICAL FMBTEST_IM
      INTENT (IN) :: MA,POS
      CALL IMI2M(2,MTIM)
      CALL IMI2M(POS,MUIM)
      CALL IMPWR(MTIM,MUIM,MVIM)
      CALL IMDIV(MA%MIM,MVIM,MUIM)
      MUIM(-1) = 1
      CALL IMMOD(MUIM,MTIM,MVIM)
      IF (MVIM(2) == 0) THEN
          FMBTEST_IM = .FALSE.
      ELSE
          FMBTEST_IM = .TRUE.
      ENDIF
   END FUNCTION

!                                                             CEILING

   FUNCTION FMCEILING_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMCEILING_FM
      INTENT (IN) :: MA
      CALL FMINT(MA%MFM,MTFM)
      CALL FMSUB(MA%MFM,MTFM,MUFM)
      IF (MUFM(2) == 0) THEN
          CALL FMEQ(MA%MFM,FMCEILING_FM%MFM)
      ELSE IF (MA%MFM(-1) > 0) THEN
          CALL FMADDI(MTFM,1)
          CALL FMEQ(MTFM,FMCEILING_FM%MFM)
      ELSE
          CALL FMEQ(MTFM,FMCEILING_FM%MFM)
      ENDIF
   END FUNCTION

   FUNCTION FMCEILING_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMCEILING_ZM
      INTENT (IN) :: MA
      CALL FMINT(MA%MZM,MTFM)
      CALL FMSUB(MA%MZM,MTFM,MUFM)
      IF (MUFM(2) == 0) THEN
          CALL FMEQ(MA%MZM,MVFM)
      ELSE IF (MA%MZM(-1) > 0) THEN
          CALL FMADDI(MTFM,1)
          CALL FMEQ(MTFM,MVFM)
      ELSE
          CALL FMEQ(MTFM,MVFM)
      ENDIF
      CALL FMINT(MA%MZM(KPTIMU-1),MTFM)
      CALL FMSUB(MA%MZM(KPTIMU-1),MTFM,MUFM)
      IF (MUFM(2) == 0) THEN
          CALL FMEQ(MA%MZM(KPTIMU-1),MUFM)
      ELSE IF (MA%MZM(KPTIMU-1) > 0) THEN
          CALL FMADDI(MTFM,1)
          CALL FMEQ(MTFM,MUFM)
      ELSE
          CALL FMEQ(MTFM,MUFM)
      ENDIF
      CALL ZMCMPX(MVFM,MUFM,FMCEILING_ZM%MZM)
   END FUNCTION

!                                                               CMPLX

   FUNCTION FMCMPLX_FM(MA,MB)
      USE FMVALS
      TYPE ( ZM ) FMCMPLX_FM
      TYPE ( FM ) MA
      TYPE ( FM ), OPTIONAL :: MB
      INTENT (IN) :: MA,MB
      IF (PRESENT(MB)) THEN
          CALL ZMCMPX(MA%MFM,MB%MFM,FMCMPLX_FM%MZM)
      ELSE
          CALL FMI2M(0,MTFM)
          CALL ZMCMPX(MA%MFM,MTFM,FMCMPLX_FM%MZM)
      ENDIF
   END FUNCTION

   FUNCTION FMCMPLX_IM(MA,MB)
      USE FMVALS
      TYPE ( ZM ) FMCMPLX_IM
      TYPE ( IM ) MA
      TYPE ( IM ), OPTIONAL :: MB
      INTENT (IN) :: MA,MB
      IF (PRESENT(MB)) THEN
          CALL IMI2FM(MA%MIM,MTFM)
          CALL IMI2FM(MB%MIM,MUFM)
          CALL ZMCMPX(MTFM,MUFM,FMCMPLX_IM%MZM)
      ELSE
          CALL IMI2FM(MA%MIM,MTFM)
          CALL FMI2M(0,MUFM)
          CALL ZMCMPX(MTFM,MUFM,FMCMPLX_IM%MZM)
      ENDIF
   END FUNCTION

!                                                               CONJG

   FUNCTION FMCONJG_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) FMCONJG_ZM,MA
      INTENT (IN) :: MA
      CALL ZMCONJ(MA%MZM,FMCONJG_ZM%MZM)
   END FUNCTION

!                                                                 COS

   FUNCTION FMCOS_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMCOS_FM
      INTENT (IN) :: MA
      CALL FMCOS(MA%MFM,FMCOS_FM%MFM)
   END FUNCTION

   FUNCTION FMCOS_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMCOS_ZM
      INTENT (IN) :: MA
      CALL ZMCOS(MA%MZM,FMCOS_ZM%MZM)
   END FUNCTION

!                                                                COSH

   FUNCTION FMCOSH_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMCOSH_FM
      INTENT (IN) :: MA
      CALL FMCOSH(MA%MFM,FMCOSH_FM%MFM)
   END FUNCTION

   FUNCTION FMCOSH_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMCOSH_ZM
      INTENT (IN) :: MA
      CALL ZMCOSH(MA%MZM,FMCOSH_ZM%MZM)
   END FUNCTION

!                                                                DBLE

   FUNCTION FMDBLE_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMDBLE_FM
      INTENT (IN) :: MA
      CALL FMEQ(MA%MFM,FMDBLE_FM%MFM)
   END FUNCTION

   FUNCTION FMDBLE_IM(MA)
      USE FMVALS
      TYPE ( FM ) FMDBLE_IM
      TYPE ( IM ) MA
      INTENT (IN) :: MA
      CALL IMI2FM(MA%MIM,FMDBLE_IM%MFM)
   END FUNCTION

   FUNCTION FMDBLE_ZM(MA)
      USE FMVALS
      TYPE ( FM ) FMDBLE_ZM
      TYPE ( ZM ) MA
      INTENT (IN) :: MA
      CALL ZMREAL(MA%MZM,FMDBLE_ZM%MFM)
   END FUNCTION

!                                                              DIGITS

   FUNCTION FMDIGITS_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA
      INTEGER FMDIGITS_FM
      INTENT (IN) :: MA
      FMDIGITS_FM = NDIG
   END FUNCTION

   FUNCTION FMDIGITS_IM(MA)
      USE FMVALS
      TYPE ( IM ) MA
      INTEGER FMDIGITS_IM
      INTENT (IN) :: MA
      FMDIGITS_IM = NDIGMX
   END FUNCTION

   FUNCTION FMDIGITS_ZM(MA)
      USE FMVALS
      INTEGER FMDIGITS_ZM
      TYPE ( ZM ) MA
      INTENT (IN) :: MA
      FMDIGITS_ZM = NDIG
   END FUNCTION

!                                                                 DIM

   FUNCTION FMDIM_FM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMDIM_FM
      INTENT (IN) :: MA,MB
      CALL FMDIM(MA%MFM,MB%MFM,FMDIM_FM%MFM)
   END FUNCTION

   FUNCTION FMDIM_IM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA,MB,FMDIM_IM
      INTENT (IN) :: MA,MB
      CALL IMDIM(MA%MIM,MB%MIM,FMDIM_IM%MIM)
   END FUNCTION

!                                                                DINT

   FUNCTION FMDINT_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMDINT_FM
      INTENT (IN) :: MA
      CALL FMINT(MA%MFM,FMDINT_FM%MFM)
   END FUNCTION

   FUNCTION FMDINT_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMDINT_ZM
      INTENT (IN) :: MA
      CALL ZMINT(MA%MZM,FMDINT_ZM%MZM)
   END FUNCTION

!                                                          DOTPRODUCT

   FUNCTION FMDOTPRODUCT_FM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA(:),MB(:),FMDOTPRODUCT_FM
      INTEGER J,JA,JB,NDSAVE
      INTENT (IN) :: MA,MB
      IF (SIZE(MA) == SIZE(MB)) THEN
          NDSAVE = NDIG
          J = MAX(NGRD52,2)
          NDIG = MIN(MAX(NDIG+J,2),NDG2MX)
          CALL FMI2M(0,FMDOTPRODUCT_FM%MFM)
          DO J = 1, SIZE(MA)
             JA = LBOUND(MA,DIM=1) + J - 1
             JB = LBOUND(MB,DIM=1) + J - 1
             CALL FMEQ2(MA(JA)%MFM,MUFM,NDSAVE,NDIG)
             CALL FMEQ2(MB(JB)%MFM,MVFM,NDSAVE,NDIG)
             CALL FMMPY(MUFM,MVFM,MTFM)
             CALL FMADD_R1(FMDOTPRODUCT_FM%MFM,MTFM)
          ENDDO
          CALL FMEQ2(FMDOTPRODUCT_FM%MFM,MTFM,NDIG,NDSAVE)
          CALL FMEQ(MTFM,FMDOTPRODUCT_FM%MFM)
          NDIG = NDSAVE
      ELSE
          CALL FMI2M(1,MTFM)
          CALL FMI2M(0,MUFM)
          CALL FMDIV(MTFM,MUFM,FMDOTPRODUCT_FM%MFM)
      ENDIF
   END FUNCTION

   FUNCTION FMDOTPRODUCT_IM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA(:),MB(:),FMDOTPRODUCT_IM
      INTEGER J,JA,JB
      INTENT (IN) :: MA,MB
      IF (SIZE(MA) == SIZE(MB)) THEN
      CALL IMI2M(0,FMDOTPRODUCT_IM%MIM)
          DO J = 1, SIZE(MA)
             JA = LBOUND(MA,DIM=1) + J - 1
             JB = LBOUND(MB,DIM=1) + J - 1
             CALL IMMPY(MA(JA)%MIM,MB(JB)%MIM,MTIM)
             CALL IMADD(FMDOTPRODUCT_IM%MIM,MTIM,MUIM)
             CALL IMEQ(MUIM,FMDOTPRODUCT_IM%MIM)
          ENDDO
      ELSE
          CALL IMI2M(1,MTIM)
          CALL IMI2M(0,MUIM)
          CALL IMDIV(MTIM,MUIM,FMDOTPRODUCT_IM%MIM)
      ENDIF
   END FUNCTION

   FUNCTION FMDOTPRODUCT_ZM(MA,MB)
      USE FMVALS
      TYPE ( ZM ) MA(:),MB(:),FMDOTPRODUCT_ZM
      INTEGER J,JA,JB,NDSAVE
      INTENT (IN) :: MA,MB
      IF (SIZE(MA) == SIZE(MB)) THEN
          NDSAVE = NDIG
          J = MAX(NGRD52,2)
          NDIG = MIN(MAX(NDIG+J,2),NDG2MX)
          CALL ZMI2M(0,FMDOTPRODUCT_ZM%MZM)
          DO J = 1, SIZE(MA)
             JA = LBOUND(MA,DIM=1) + J - 1
             JB = LBOUND(MB,DIM=1) + J - 1
             CALL ZMEQ2(MA(JA)%MZM,MUZM,NDSAVE,NDIG)
             CALL ZMEQ2(MB(JB)%MZM,MVZM,NDSAVE,NDIG)
             CALL ZMMPY(MUZM,MVZM,MTZM)
             CALL ZMADD(FMDOTPRODUCT_ZM%MZM,MTZM,MUZM)
             CALL ZMEQ(MUZM,FMDOTPRODUCT_ZM%MZM)
          ENDDO
          CALL ZMEQ2(FMDOTPRODUCT_ZM%MZM,MTZM,NDIG,NDSAVE)
          CALL ZMEQ(MTZM,FMDOTPRODUCT_ZM%MZM)
          NDIG = NDSAVE
      ELSE
          CALL ZMI2M(1,MTZM)
          CALL ZMI2M(0,MUZM)
          CALL ZMDIV(MTZM,MUZM,FMDOTPRODUCT_ZM%MZM)
      ENDIF
   END FUNCTION

 END MODULE FMZM_7

 MODULE FMZM_8
    USE FMZM_1

   INTERFACE EPSILON
      MODULE PROCEDURE FMEPSILON_FM
   END INTERFACE

   INTERFACE EXP
      MODULE PROCEDURE FMEXP_FM
      MODULE PROCEDURE FMEXP_ZM
   END INTERFACE

   INTERFACE EXPONENT
      MODULE PROCEDURE FMEXPONENT_FM
   END INTERFACE

   INTERFACE FLOOR
      MODULE PROCEDURE FMFLOOR_FM
      MODULE PROCEDURE FMFLOOR_IM
      MODULE PROCEDURE FMFLOOR_ZM
   END INTERFACE

   INTERFACE FRACTION
      MODULE PROCEDURE FMFRACTION_FM
      MODULE PROCEDURE FMFRACTION_ZM
   END INTERFACE

   INTERFACE HUGE
      MODULE PROCEDURE FMHUGE_FM
      MODULE PROCEDURE FMHUGE_IM
      MODULE PROCEDURE FMHUGE_ZM
   END INTERFACE

   INTERFACE INT
      MODULE PROCEDURE FMINT_FM
      MODULE PROCEDURE FMINT_IM
      MODULE PROCEDURE FMINT_ZM
   END INTERFACE

   INTERFACE LOG
      MODULE PROCEDURE FMLOG_FM
      MODULE PROCEDURE FMLOG_ZM
   END INTERFACE

   INTERFACE LOG10
      MODULE PROCEDURE FMLOG10_FM
      MODULE PROCEDURE FMLOG10_ZM
   END INTERFACE

   INTERFACE MATMUL
      MODULE PROCEDURE FMMATMUL_FM
      MODULE PROCEDURE FMMATMUL_IM
      MODULE PROCEDURE FMMATMUL_ZM
   END INTERFACE

   INTERFACE MAX
      MODULE PROCEDURE FMMAX_FM
      MODULE PROCEDURE FMMAX_IM
   END INTERFACE

   INTERFACE MAXEXPONENT
      MODULE PROCEDURE FMMAXEXPONENT_FM
   END INTERFACE

   INTERFACE MIN
      MODULE PROCEDURE FMMIN_FM
      MODULE PROCEDURE FMMIN_IM
   END INTERFACE

   INTERFACE MINEXPONENT
      MODULE PROCEDURE FMMINEXPONENT_FM
   END INTERFACE

   INTERFACE MOD
      MODULE PROCEDURE FMMOD_FM
      MODULE PROCEDURE FMMOD_IM
   END INTERFACE

   INTERFACE MODULO
      MODULE PROCEDURE FMMODULO_FM
      MODULE PROCEDURE FMMODULO_IM
   END INTERFACE

   INTERFACE NEAREST
      MODULE PROCEDURE FMNEAREST_FM
   END INTERFACE

   INTERFACE NINT
      MODULE PROCEDURE FMNINT_FM
      MODULE PROCEDURE FMNINT_IM
      MODULE PROCEDURE FMNINT_ZM
   END INTERFACE

   INTERFACE PRECISION
      MODULE PROCEDURE FMPRECISION_FM
      MODULE PROCEDURE FMPRECISION_ZM
   END INTERFACE

   INTERFACE RADIX
      MODULE PROCEDURE FMRADIX_FM
      MODULE PROCEDURE FMRADIX_IM
      MODULE PROCEDURE FMRADIX_ZM
   END INTERFACE

   INTERFACE RANGE
      MODULE PROCEDURE FMRANGE_FM
      MODULE PROCEDURE FMRANGE_IM
      MODULE PROCEDURE FMRANGE_ZM
   END INTERFACE

   INTERFACE REAL
      MODULE PROCEDURE FMREAL_FM
      MODULE PROCEDURE FMREAL_IM
      MODULE PROCEDURE FMREAL_ZM
   END INTERFACE

   INTERFACE RRSPACING
      MODULE PROCEDURE FMRRSPACING_FM
   END INTERFACE

   INTERFACE SCALE
      MODULE PROCEDURE FMSCALE_FM
      MODULE PROCEDURE FMSCALE_ZM
   END INTERFACE

   INTERFACE SETEXPONENT
      MODULE PROCEDURE FMSETEXPONENT_FM
   END INTERFACE

   INTERFACE SIGN
      MODULE PROCEDURE FMSIGN_FM
      MODULE PROCEDURE FMSIGN_IM
   END INTERFACE

 CONTAINS

!                                                             EPSILON

   FUNCTION FMEPSILON_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMEPSILON_FM
      INTENT (IN) :: MA
      CALL FMI2M(1,MTFM)
      CALL FMULP(MTFM,FMEPSILON_FM%MFM)
   END FUNCTION

!                                                                 EXP

   FUNCTION FMEXP_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMEXP_FM
      INTENT (IN) :: MA
      CALL FMEXP(MA%MFM,FMEXP_FM%MFM)
   END FUNCTION

   FUNCTION FMEXP_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMEXP_ZM
      INTENT (IN) :: MA
      CALL ZMEXP(MA%MZM,FMEXP_ZM%MZM)
   END FUNCTION

!                                                            EXPONENT

   FUNCTION FMEXPONENT_FM(MA)
      TYPE ( FM ) MA
      INTEGER FMEXPONENT_FM
      INTENT (IN) :: MA
      FMEXPONENT_FM = INT(MA%MFM(1))
   END FUNCTION

!                                                               FLOOR

   FUNCTION FMFLOOR_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMFLOOR_FM
      INTENT (IN) :: MA
      CALL FMINT(MA%MFM,MTFM)
      CALL FMSUB(MA%MFM,MTFM,MUFM)
      IF (MUFM(2) == 0) THEN
          CALL FMEQ(MA%MFM,FMFLOOR_FM%MFM)
      ELSE IF (MA%MFM(-1) < 0) THEN
          CALL FMADDI(MTFM,-1)
          CALL FMEQ(MTFM,FMFLOOR_FM%MFM)
      ELSE
          CALL FMEQ(MTFM,FMFLOOR_FM%MFM)
      ENDIF
   END FUNCTION

   FUNCTION FMFLOOR_IM(MA)
      USE FMVALS
      TYPE ( IM ) MA,FMFLOOR_IM
      INTENT (IN) :: MA
      CALL IMEQ(MA%MIM,FMFLOOR_IM%MIM)
   END FUNCTION

   FUNCTION FMFLOOR_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMFLOOR_ZM
      INTENT (IN) :: MA
      CALL FMINT(MA%MZM,MTFM)
      CALL FMSUB(MA%MZM,MTFM,MUFM)
      IF (MUFM(2) == 0) THEN
          CALL FMEQ(MA%MZM,MVFM)
      ELSE IF (MA%MZM(-1) < 0) THEN
          CALL FMADDI(MTFM,-1)
          CALL FMEQ(MTFM,MVFM)
      ELSE
          CALL FMEQ(MTFM,MVFM)
      ENDIF
      CALL FMINT(MA%MZM(KPTIMU-1),MTFM)
      CALL FMSUB(MA%MZM(KPTIMU-1),MTFM,MUFM)
      IF (MUFM(2) == 0) THEN
          CALL FMEQ(MA%MZM(KPTIMU-1),MUFM)
      ELSE IF (MA%MZM(KPTIMU-1) < 0) THEN
          CALL FMADDI(MTFM,-1)
          CALL FMEQ(MTFM,MUFM)
      ELSE
          CALL FMEQ(MTFM,MUFM)
      ENDIF
      CALL ZMCMPX(MVFM,MUFM,FMFLOOR_ZM%MZM)
   END FUNCTION

!                                                            FRACTION

   FUNCTION FMFRACTION_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMFRACTION_FM
      INTENT (IN) :: MA
      CALL FMEQ(MA%MFM,MTFM)
      MTFM(1) = 0
      CALL FMEQ(MTFM,FMFRACTION_FM%MFM)
   END FUNCTION

   FUNCTION FMFRACTION_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMFRACTION_ZM
      INTENT (IN) :: MA
      CALL ZMEQ(MA%MZM,MTZM)
      MTZM(1) = 0
      MTZM(KPTIMU+1) = 0
      CALL ZMEQ(MTZM,FMFRACTION_ZM%MZM)
   END FUNCTION

!                                                                HUGE

   FUNCTION FMHUGE_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMHUGE_FM
      INTENT (IN) :: MA
      CALL FMBIG(FMHUGE_FM%MFM)
   END FUNCTION

   FUNCTION FMHUGE_IM(MA)
      USE FMVALS
      TYPE ( IM ) MA,FMHUGE_IM
      INTENT (IN) :: MA
      CALL IMBIG(FMHUGE_IM%MIM)
   END FUNCTION

   FUNCTION FMHUGE_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMHUGE_ZM
      INTENT (IN) :: MA
      CALL FMBIG(MTFM)
      CALL ZMCMPX(MTFM,MTFM,FMHUGE_ZM%MZM)
   END FUNCTION

!                                                                 INT

   FUNCTION FMINT_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA
      TYPE ( IM ) FMINT_FM
      INTENT (IN) :: MA
      CALL FMINT(MA%MFM,MTFM)
      CALL IMFM2I(MTFM,FMINT_FM%MIM)
   END FUNCTION

   FUNCTION FMINT_IM(MA)
      USE FMVALS
      TYPE ( IM ) MA,FMINT_IM
      INTENT (IN) :: MA
      CALL IMEQ(MA%MIM,FMINT_IM%MIM)
   END FUNCTION

   FUNCTION FMINT_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA
      TYPE ( IM ) FMINT_ZM
      INTENT (IN) :: MA
      CALL ZMREAL(MA%MZM,MTFM)
      CALL FMINT(MTFM,MUFM)
      CALL IMFM2I(MUFM,FMINT_ZM%MIM)
   END FUNCTION

!                                                                 LOG

   FUNCTION FMLOG_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMLOG_FM
      INTENT (IN) :: MA
      CALL FMLN(MA%MFM,FMLOG_FM%MFM)
   END FUNCTION

   FUNCTION FMLOG_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMLOG_ZM
      INTENT (IN) :: MA
      CALL ZMLN(MA%MZM,FMLOG_ZM%MZM)
   END FUNCTION

!                                                               LOG10

   FUNCTION FMLOG10_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMLOG10_FM
      INTENT (IN) :: MA
      CALL FMLG10(MA%MFM,FMLOG10_FM%MFM)
   END FUNCTION

   FUNCTION FMLOG10_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMLOG10_ZM
      INTENT (IN) :: MA
      CALL ZMLG10(MA%MZM,FMLOG10_ZM%MZM)
   END FUNCTION

!                                                              MATMUL

   FUNCTION FMMATMUL_FM(MA,MB)        RESULT(MC)
      USE FMVALS
      TYPE ( FM ) MA(:,:),MB(:,:)
      TYPE ( FM ), DIMENSION(SIZE(MA,DIM=1),SIZE(MB,DIM=2)) :: MC
      INTEGER I,J,K,NDSAVE
      INTENT (IN) :: MA,MB
      DO J = 1, SIZE(MA,DIM=1)
         DO K = 1, SIZE(MB,DIM=2)
         ENDDO
      ENDDO
      IF (SIZE(MA,DIM=2) == SIZE(MB,DIM=1)) THEN
          NDSAVE = NDIG
          J = MAX(NGRD52,2)
          NDIG = MIN(MAX(NDIG+J,2),NDG2MX)
          DO I = LBOUND(MA,DIM=1), UBOUND(MA,DIM=1)
             DO J = LBOUND(MB,DIM=2), UBOUND(MB,DIM=2)
                CALL FMI2M(0,MTFM)
                DO K = LBOUND(MA,DIM=2), UBOUND(MA,DIM=2)
                   CALL FMEQ2(MA(I,K)%MFM,MUFM,NDSAVE,NDIG)
                   CALL FMEQ2(MB(K,J)%MFM,MVFM,NDSAVE,NDIG)
                   CALL FMMPY(MUFM,MVFM,M01)
                   CALL FMADD_R1(MTFM,M01)
                ENDDO
                CALL FMEQ2_R1(MTFM,NDIG,NDSAVE)
                CALL FMEQ(MTFM,MC(I,J)%MFM)
             ENDDO
          ENDDO
          NDIG = NDSAVE
      ELSE
          CALL FMI2M(1,MTFM)
          CALL FMI2M(0,MUFM)
          CALL FMDIV(MTFM,MUFM,MVFM)
          DO I = 1, SIZE(MA,DIM=1)
             DO J = 1, SIZE(MB,DIM=2)
                CALL FMEQ(MVFM,MC(I,J)%MFM)
             ENDDO
          ENDDO
      ENDIF
   END FUNCTION

   FUNCTION FMMATMUL_IM(MA,MB)        RESULT(MC)
      USE FMVALS
      TYPE ( IM ) MA(:,:),MB(:,:)
      TYPE ( IM ), DIMENSION(SIZE(MA,DIM=1),SIZE(MB,DIM=2)) :: MC
      INTEGER I,J,K
      INTENT (IN) :: MA,MB
      DO J = 1, SIZE(MA,DIM=1)
         DO K = 1, SIZE(MB,DIM=2)
         ENDDO
      ENDDO
      IF (SIZE(MA,DIM=2) == SIZE(MB,DIM=1)) THEN
          DO I = LBOUND(MA,DIM=1), UBOUND(MA,DIM=1)
             DO J = LBOUND(MB,DIM=2), UBOUND(MB,DIM=2)
                CALL IMI2M(0,MTIM)
                DO K = LBOUND(MA,DIM=2), UBOUND(MA,DIM=2)
                   CALL IMMPY(MA(I,K)%MIM,MB(K,J)%MIM,M01)
                   CALL IMADD(MTIM,M01,MUIM)
                   CALL IMEQ(MUIM,MTIM)
                ENDDO
                CALL IMEQ(MTIM,MC(I,J)%MIM)
             ENDDO
          ENDDO
      ELSE
          CALL IMI2M(1,MTIM)
          CALL IMI2M(0,MUIM)
          CALL IMDIV(MTIM,MUIM,MC(1,1)%MIM)
          DO I = 1, SIZE(MA,DIM=1)
             DO J = 1, SIZE(MB,DIM=2)
                IF (I > 1 .OR. J > 1) CALL IMEQ(MC(1,1)%MIM,MC(I,J)%MIM)
             ENDDO
          ENDDO
      ENDIF
   END FUNCTION

   FUNCTION FMMATMUL_ZM(MA,MB)        RESULT(MC)
      USE FMVALS
      TYPE ( ZM ) MA(:,:),MB(:,:)
      TYPE ( ZM ), DIMENSION(SIZE(MA,DIM=1),SIZE(MB,DIM=2)) :: MC
      INTEGER I,J,K,NDSAVE
      INTENT (IN) :: MA,MB
      DO J = 1, SIZE(MA,DIM=1)
         DO K = 1, SIZE(MB,DIM=2)
         ENDDO
      ENDDO
      IF (SIZE(MA,DIM=2) == SIZE(MB,DIM=1)) THEN
          NDSAVE = NDIG
          J = MAX(NGRD52,2)
          NDIG = MIN(MAX(NDIG+J,2),NDG2MX)
          DO I = LBOUND(MA,DIM=1), UBOUND(MA,DIM=1)
             DO J = LBOUND(MB,DIM=2), UBOUND(MB,DIM=2)
                CALL ZMI2M(0,MTZM)
                DO K = LBOUND(MA,DIM=2), UBOUND(MA,DIM=2)
                   CALL ZMEQ2(MA(I,K)%MZM,MUZM,NDSAVE,NDIG)
                   CALL ZMEQ2(MB(K,J)%MZM,MVZM,NDSAVE,NDIG)
                   CALL ZMMPY(MUZM,MVZM,MZ02)
                   CALL ZMADD(MTZM,MZ02,MUZM)
                   CALL ZMEQ(MUZM,MTZM)
                ENDDO
                CALL ZMEQ2_R1(MTZM,NDIG,NDSAVE)
                CALL ZMEQ(MTZM,MC(I,J)%MZM)
             ENDDO
          ENDDO
          NDIG = NDSAVE
      ELSE
          CALL ZMI2M(1,MTZM)
          CALL ZMI2M(0,MUZM)
          CALL ZMDIV(MTZM,MUZM,MC(1,1)%MZM)
          DO I = 1, SIZE(MA,DIM=1)
             DO J = 1, SIZE(MB,DIM=2)
                IF (I > 1 .OR. J > 1) CALL ZMEQ(MC(1,1)%MZM,MC(I,J)%MZM)
             ENDDO
          ENDDO
      ENDIF
   END FUNCTION

!                                                                 MAX

   FUNCTION FMMAX_FM(MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMMAX_FM
      TYPE ( FM ), OPTIONAL :: MC,MD,ME,MF,MG,MH,MI,MJ
      INTENT (IN) :: MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ
      CALL FMMAX(MA%MFM,MB%MFM,MTFM)
      IF (PRESENT(MC)) THEN
          CALL FMMAX(MTFM,MC%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      IF (PRESENT(MD)) THEN
          CALL FMMAX(MTFM,MD%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      IF (PRESENT(ME)) THEN
          CALL FMMAX(MTFM,ME%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      IF (PRESENT(MF)) THEN
          CALL FMMAX(MTFM,MF%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      IF (PRESENT(MG)) THEN
          CALL FMMAX(MTFM,MG%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      IF (PRESENT(MH)) THEN
          CALL FMMAX(MTFM,MH%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      IF (PRESENT(MI)) THEN
          CALL FMMAX(MTFM,MI%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      IF (PRESENT(MJ)) THEN
          CALL FMMAX(MTFM,MJ%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      CALL FMEQ(MTFM,FMMAX_FM%MFM)
   END FUNCTION

   FUNCTION FMMAX_IM(MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ)
      USE FMVALS
      TYPE ( IM ) MA,MB,FMMAX_IM
      TYPE ( IM ), OPTIONAL :: MC,MD,ME,MF,MG,MH,MI,MJ
      INTENT (IN) :: MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ
      CALL IMMAX(MA%MIM,MB%MIM,MTIM)
      IF (PRESENT(MC)) THEN
          CALL IMMAX(MTIM,MC%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      IF (PRESENT(MD)) THEN
          CALL IMMAX(MTIM,MD%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      IF (PRESENT(ME)) THEN
          CALL IMMAX(MTIM,ME%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      IF (PRESENT(MF)) THEN
          CALL IMMAX(MTIM,MF%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      IF (PRESENT(MG)) THEN
          CALL IMMAX(MTIM,MG%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      IF (PRESENT(MH)) THEN
          CALL IMMAX(MTIM,MH%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      IF (PRESENT(MI)) THEN
          CALL IMMAX(MTIM,MI%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      IF (PRESENT(MJ)) THEN
          CALL IMMAX(MTIM,MJ%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      CALL IMEQ(MTIM,FMMAX_IM%MIM)
   END FUNCTION

!                                                         MAXEXPONENT

   FUNCTION FMMAXEXPONENT_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA
      INTEGER FMMAXEXPONENT_FM
      INTENT (IN) :: MA
      FMMAXEXPONENT_FM = INT(MXEXP) + 1
   END FUNCTION

!                                                                 MIN

   FUNCTION FMMIN_FM(MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMMIN_FM
      TYPE ( FM ), OPTIONAL :: MC,MD,ME,MF,MG,MH,MI,MJ
      INTENT (IN) :: MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ
      CALL FMMIN(MA%MFM,MB%MFM,MTFM)
      IF (PRESENT(MC)) THEN
          CALL FMMIN(MTFM,MC%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      IF (PRESENT(MD)) THEN
          CALL FMMIN(MTFM,MD%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      IF (PRESENT(ME)) THEN
          CALL FMMIN(MTFM,ME%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      IF (PRESENT(MF)) THEN
          CALL FMMIN(MTFM,MF%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      IF (PRESENT(MG)) THEN
          CALL FMMIN(MTFM,MG%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      IF (PRESENT(MH)) THEN
          CALL FMMIN(MTFM,MH%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      IF (PRESENT(MI)) THEN
          CALL FMMIN(MTFM,MI%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      IF (PRESENT(MJ)) THEN
          CALL FMMIN(MTFM,MJ%MFM,MUFM)
          CALL FMEQ(MUFM,MTFM)
      ENDIF
      CALL FMEQ(MTFM,FMMIN_FM%MFM)
   END FUNCTION

   FUNCTION FMMIN_IM(MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ)
      USE FMVALS
      TYPE ( IM ) MA,MB,FMMIN_IM
      TYPE ( IM ), OPTIONAL :: MC,MD,ME,MF,MG,MH,MI,MJ
      INTENT (IN) :: MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ
      CALL IMMIN(MA%MIM,MB%MIM,MTIM)
      IF (PRESENT(MC)) THEN
          CALL IMMIN(MTIM,MC%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      IF (PRESENT(MD)) THEN
          CALL IMMIN(MTIM,MD%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      IF (PRESENT(ME)) THEN
          CALL IMMIN(MTIM,ME%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      IF (PRESENT(MF)) THEN
          CALL IMMIN(MTIM,MF%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      IF (PRESENT(MG)) THEN
          CALL IMMIN(MTIM,MG%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      IF (PRESENT(MH)) THEN
          CALL IMMIN(MTIM,MH%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      IF (PRESENT(MI)) THEN
          CALL IMMIN(MTIM,MI%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      IF (PRESENT(MJ)) THEN
          CALL IMMIN(MTIM,MJ%MIM,MUIM)
          CALL IMEQ(MUIM,MTIM)
      ENDIF
      CALL IMEQ(MTIM,FMMIN_IM%MIM)
   END FUNCTION

!                                                         MINEXPONENT

   FUNCTION FMMINEXPONENT_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA
      INTEGER FMMINEXPONENT_FM
      INTENT (IN) :: MA
      FMMINEXPONENT_FM = -INT(MXEXP)
   END FUNCTION

!                                                                 MOD

   FUNCTION FMMOD_FM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMMOD_FM
      INTENT (IN) :: MA,MB
      CALL FMMOD(MA%MFM,MB%MFM,FMMOD_FM%MFM)
   END FUNCTION

   FUNCTION FMMOD_IM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA,MB,FMMOD_IM
      INTENT (IN) :: MA,MB
      CALL IMMOD(MA%MIM,MB%MIM,FMMOD_IM%MIM)
   END FUNCTION

!                                                              MODULO

   FUNCTION FMMODULO_FM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMMODULO_FM
      INTENT (IN) :: MA,MB
      CALL FMMOD(MA%MFM,MB%MFM,MTFM)
      IF (MTFM(2) /= 0) THEN
          IF ((MA%MFM(2) > 0 .AND. MA%MFM(-1) > 0 .AND.  &
               MB%MFM(2) > 0 .AND. MB%MFM(-1) < 0) .OR.  &
              (MA%MFM(2) > 0 .AND. MA%MFM(-1) < 0 .AND.  &
               MB%MFM(2) > 0 .AND. MB%MFM(-1) > 0)) THEN
              CALL FMADD_R1(MTFM,MB%MFM)
          ENDIF
      ENDIF
      CALL FMEQ(MTFM,FMMODULO_FM%MFM)
   END FUNCTION

   FUNCTION FMMODULO_IM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA,MB,FMMODULO_IM
      INTENT (IN) :: MA,MB
      CALL IMMOD(MA%MIM,MB%MIM,MTIM)
      IF (MTIM(2) /= 0) THEN
          IF ((MA%MIM(2) > 0 .AND. MA%MIM(-1) > 0 .AND.  &
               MB%MIM(2) > 0 .AND. MB%MIM(-1) < 0) .OR.  &
              (MA%MIM(2) > 0 .AND. MA%MIM(-1) < 0 .AND.  &
               MB%MIM(2) > 0 .AND. MB%MIM(-1) > 0)) THEN
              CALL IMADD(MTIM,MB%MIM,MUIM)
              CALL IMEQ(MUIM,MTIM)
          ENDIF
      ENDIF
      CALL IMEQ(MTIM,FMMODULO_IM%MIM)
   END FUNCTION

!                                                             NEAREST

   FUNCTION FMNEAREST_FM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMNEAREST_FM
      LOGICAL FMCOMP
      INTENT (IN) :: MA,MB
      IF (MA%MFM(2) == 0) THEN
          IF (MB%MFM(-1) > 0) THEN
              CALL FMBIG(MTFM)
              CALL FMI2M(1,MUFM)
              CALL FMDIV(MUFM,MTFM,FMNEAREST_FM%MFM)
          ELSE
              CALL FMBIG(MTFM)
              CALL FMI2M(-1,MUFM)
              CALL FMDIV(MUFM,MTFM,FMNEAREST_FM%MFM)
          ENDIF
      ELSE
          IF (MB%MFM(-1) > 0) THEN
              CALL FMULP(MA%MFM,MTFM)
              MTFM(-1) = 1
              CALL FMADD(MA%MFM,MTFM,MUFM)
              CALL FMULP(MUFM,MVFM)
              CALL FMABS(MVFM,MUFM)
              IF (FMCOMP(MTFM,'LE',MUFM)) THEN
                  CALL FMADD(MA%MFM,MTFM,FMNEAREST_FM%MFM)
              ELSE
                  CALL FMADD(MA%MFM,MUFM,FMNEAREST_FM%MFM)
              ENDIF
          ELSE
              CALL FMULP(MA%MFM,MTFM)
              MTFM(-1) = 1
              CALL FMSUB(MA%MFM,MTFM,MUFM)
              CALL FMULP(MUFM,MVFM)
              CALL FMABS(MVFM,MUFM)
              IF (FMCOMP(MTFM,'LE',MUFM)) THEN
                  CALL FMSUB(MA%MFM,MTFM,FMNEAREST_FM%MFM)
              ELSE
                  CALL FMSUB(MA%MFM,MUFM,FMNEAREST_FM%MFM)
              ENDIF
          ENDIF
      ENDIF
   END FUNCTION

!                                                                NINT

   FUNCTION FMNINT_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA
      TYPE ( IM ) FMNINT_FM
      INTENT (IN) :: MA
      CALL FMNINT(MA%MFM,MTFM)
      CALL IMFM2I(MTFM,FMNINT_FM%MIM)
   END FUNCTION

   FUNCTION FMNINT_IM(MA)
      USE FMVALS
      TYPE ( IM ) MA,FMNINT_IM
      INTENT (IN) :: MA
      CALL IMEQ(MA%MIM,FMNINT_IM%MIM)
   END FUNCTION

   FUNCTION FMNINT_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA
      TYPE ( IM ) FMNINT_ZM
      INTENT (IN) :: MA
      CALL ZMREAL(MA%MZM,MTFM)
      CALL FMNINT(MTFM,MUFM)
      CALL IMFM2I(MUFM,FMNINT_ZM%MIM)
   END FUNCTION

!                                                           PRECISION

   FUNCTION FMPRECISION_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA
      INTEGER FMPRECISION_FM
      INTENT (IN) :: MA
      FMPRECISION_FM = INT(LOG10(REAL(MBASE))*(NDIG-1) + 1)
   END FUNCTION

   FUNCTION FMPRECISION_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA
      INTEGER FMPRECISION_ZM
      INTENT (IN) :: MA
      FMPRECISION_ZM = INT(LOG10(REAL(MBASE))*(NDIG-1) + 1)
   END FUNCTION

!                                                               RADIX

   FUNCTION FMRADIX_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA
      INTEGER FMRADIX_FM
      INTENT (IN) :: MA
      FMRADIX_FM = INT(MBASE)
   END FUNCTION

   FUNCTION FMRADIX_IM(MA)
      USE FMVALS
      TYPE ( IM ) MA
      INTEGER FMRADIX_IM
      INTENT (IN) :: MA
      FMRADIX_IM = INT(MBASE)
   END FUNCTION

   FUNCTION FMRADIX_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA
      INTEGER FMRADIX_ZM
      INTENT (IN) :: MA
      FMRADIX_ZM = INT(MBASE)
   END FUNCTION

!                                                               RANGE

   FUNCTION FMRANGE_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA
      INTEGER FMRANGE_FM
      INTENT (IN) :: MA
      FMRANGE_FM = INT(MXEXP*LOG10(REAL(MBASE)))
   END FUNCTION

   FUNCTION FMRANGE_IM(MA)
      USE FMVALS
      TYPE ( IM ) MA
      INTEGER FMRANGE_IM
      INTENT (IN) :: MA
      FMRANGE_IM = INT(NDIGMX*LOG10(REAL(MBASE)))
   END FUNCTION

   FUNCTION FMRANGE_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA
      INTEGER FMRANGE_ZM
      INTENT (IN) :: MA
      FMRANGE_ZM = INT(MXEXP*LOG10(REAL(MBASE)))
   END FUNCTION

!                                                                REAL

   FUNCTION FMREAL_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMREAL_FM
      INTENT (IN) :: MA
      CALL FMEQ(MA%MFM,FMREAL_FM%MFM)
   END FUNCTION

   FUNCTION FMREAL_IM(MA)
      USE FMVALS
      TYPE ( FM ) FMREAL_IM
      TYPE ( IM ) MA
      INTENT (IN) :: MA
      CALL IMI2FM(MA%MIM,FMREAL_IM%MFM)
   END FUNCTION

   FUNCTION FMREAL_ZM(MA)
      USE FMVALS
      TYPE ( FM ) FMREAL_ZM
      TYPE ( ZM ) MA
      INTENT (IN) :: MA
      CALL ZMREAL(MA%MZM,FMREAL_ZM%MFM)
   END FUNCTION

!                                                           RRSPACING

   FUNCTION FMRRSPACING_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMRRSPACING_FM
      INTENT (IN) :: MA
      CALL FMABS(MA%MFM,MTFM)
      MTFM(1) = NDIG
      CALL FMEQ(MTFM,FMRRSPACING_FM%MFM)
   END FUNCTION

!                                                               SCALE

   FUNCTION FMSCALE_FM(MA,L)
      USE FMVALS
      TYPE ( FM ) MA,FMSCALE_FM
      INTEGER L
      INTENT (IN) :: MA,L
      CALL FMEQ(MA%MFM,MTFM)
      IF (ABS(MTFM(1)+L) < MXEXP) THEN
          MTFM(1) = MTFM(1) + L
          CALL FMEQ(MTFM,FMSCALE_FM%MFM)
      ELSE
          CALL FMI2M(INT(MBASE),MUFM)
          CALL FMIPWR(MUFM,L,MVFM)
          CALL FMMPY(MA%MFM,MVFM,FMSCALE_FM%MFM)
      ENDIF
   END FUNCTION

   FUNCTION FMSCALE_ZM(MA,L)
      USE FMVALS
      INTEGER L
      TYPE ( ZM ) MA,FMSCALE_ZM
      INTENT (IN) :: MA,L
      CALL ZMEQ(MA%MZM,MTZM)
      IF (ABS(MTZM(1)+L) < MXEXP .AND. &
          ABS(MTZM(KPTIMU+1)+L) < MXEXP) THEN
          MTZM(1) = MTZM(1) + L
          MTZM(KPTIMU+1) = MTZM(KPTIMU+1) + L
          CALL ZMEQ(MTZM,FMSCALE_ZM%MZM)
      ELSE
          CALL ZMI2M(INT(MBASE),MUZM)
          CALL ZMIPWR(MUZM,L,MVZM)
          CALL ZMMPY(MA%MZM,MVZM,FMSCALE_ZM%MZM)
      ENDIF
   END FUNCTION

!                                                         SETEXPONENT

   FUNCTION FMSETEXPONENT_FM(MA,L)
      USE FMVALS
      TYPE ( FM ) MA,FMSETEXPONENT_FM
      INTEGER L
      INTENT (IN) :: MA,L
      CALL FMEQ(MA%MFM,MTFM)
      MTFM(1) = L
      CALL FMEQ(MTFM,FMSETEXPONENT_FM%MFM)
   END FUNCTION

!                                                                SIGN

   FUNCTION FMSIGN_FM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMSIGN_FM
      INTENT (IN) :: MA,MB
      CALL FMSIGN(MA%MFM,MB%MFM,FMSIGN_FM%MFM)
   END FUNCTION

   FUNCTION FMSIGN_IM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA,MB,FMSIGN_IM
      INTENT (IN) :: MA,MB
      CALL IMSIGN(MA%MIM,MB%MIM,FMSIGN_IM%MIM)
   END FUNCTION

 END MODULE FMZM_8

 MODULE FMZM_9
    USE FMZM_1

   INTERFACE SIN
      MODULE PROCEDURE FMSIN_FM
      MODULE PROCEDURE FMSIN_ZM
   END INTERFACE

   INTERFACE SINH
      MODULE PROCEDURE FMSINH_FM
      MODULE PROCEDURE FMSINH_ZM
   END INTERFACE

   INTERFACE SPACING
      MODULE PROCEDURE FMSPACING_FM
   END INTERFACE

   INTERFACE SQRT
      MODULE PROCEDURE FMSQRT_FM
      MODULE PROCEDURE FMSQRT_ZM
   END INTERFACE

   INTERFACE TAN
      MODULE PROCEDURE FMTAN_FM
      MODULE PROCEDURE FMTAN_ZM
   END INTERFACE

   INTERFACE TANH
      MODULE PROCEDURE FMTANH_FM
      MODULE PROCEDURE FMTANH_ZM
   END INTERFACE

   INTERFACE TINY
      MODULE PROCEDURE FMTINY_FM
      MODULE PROCEDURE FMTINY_IM
      MODULE PROCEDURE FMTINY_ZM
   END INTERFACE

   INTERFACE TO_FM
      MODULE PROCEDURE FM_I
      MODULE PROCEDURE FM_R
      MODULE PROCEDURE FM_D
      MODULE PROCEDURE FM_Z
      MODULE PROCEDURE FM_C
      MODULE PROCEDURE FM_FM
      MODULE PROCEDURE FM_IM
      MODULE PROCEDURE FM_ZM
      MODULE PROCEDURE FM_ST
   END INTERFACE

   INTERFACE TO_IM
      MODULE PROCEDURE IM_I
      MODULE PROCEDURE IM_R
      MODULE PROCEDURE IM_D
      MODULE PROCEDURE IM_Z
      MODULE PROCEDURE IM_C
      MODULE PROCEDURE IM_FM
      MODULE PROCEDURE IM_IM
      MODULE PROCEDURE IM_ZM
      MODULE PROCEDURE IM_ST
   END INTERFACE

   INTERFACE TO_ZM
      MODULE PROCEDURE ZM_I
      MODULE PROCEDURE ZM_R
      MODULE PROCEDURE ZM_D
      MODULE PROCEDURE ZM_Z
      MODULE PROCEDURE ZM_C
      MODULE PROCEDURE ZM_FM
      MODULE PROCEDURE ZM_IM
      MODULE PROCEDURE ZM_ZM
      MODULE PROCEDURE ZM_ST
   END INTERFACE

   INTERFACE TO_INT
      MODULE PROCEDURE FM_2INT
      MODULE PROCEDURE IM_2INT
      MODULE PROCEDURE ZM_2INT
   END INTERFACE

   INTERFACE TO_SP
      MODULE PROCEDURE FM_2SP
      MODULE PROCEDURE IM_2SP
      MODULE PROCEDURE ZM_2SP
   END INTERFACE

   INTERFACE TO_DP
      MODULE PROCEDURE FM_2DP
      MODULE PROCEDURE IM_2DP
      MODULE PROCEDURE ZM_2DP
   END INTERFACE

   INTERFACE TO_SPZ
      MODULE PROCEDURE FM_2SPZ
      MODULE PROCEDURE IM_2SPZ
      MODULE PROCEDURE ZM_2SPZ
   END INTERFACE

   INTERFACE TO_DPZ
      MODULE PROCEDURE FM_2DPZ
      MODULE PROCEDURE IM_2DPZ
      MODULE PROCEDURE ZM_2DPZ
   END INTERFACE


   INTERFACE FM_FORMAT
      MODULE PROCEDURE FMFORMAT_FM
   END INTERFACE

   INTERFACE IM_FORMAT
      MODULE PROCEDURE IMFORMAT_IM
   END INTERFACE

   INTERFACE ZM_FORMAT
      MODULE PROCEDURE ZMFORMAT_ZM
   END INTERFACE

   INTERFACE GCD
      MODULE PROCEDURE GCD_IM
   END INTERFACE

   INTERFACE MULTIPLY_MOD
      MODULE PROCEDURE MULTIPLYMOD_IM
   END INTERFACE

   INTERFACE POWER_MOD
      MODULE PROCEDURE POWERMOD_IM
   END INTERFACE

   INTERFACE FM_RANDOM_SEED
      MODULE PROCEDURE FM_SEED
   END INTERFACE

   INTERFACE BERNOULLI
      MODULE PROCEDURE FMBERNOULLI_FM
   END INTERFACE

   INTERFACE BETA
      MODULE PROCEDURE FMBETA_FM
   END INTERFACE

   INTERFACE BINOMIAL
      MODULE PROCEDURE FMBINOMIAL_FM
   END INTERFACE

   INTERFACE FACTORIAL
      MODULE PROCEDURE FMFACTORIAL_FM
   END INTERFACE

   INTERFACE GAMMA
      MODULE PROCEDURE FMGAMMA_FM
   END INTERFACE

   INTERFACE INCOMPLETE_BETA
      MODULE PROCEDURE FMINCOMPLETE_BETA_FM
   END INTERFACE

   INTERFACE INCOMPLETE_GAMMA1
      MODULE PROCEDURE FMINCOMPLETE_GAMMA1_FM
   END INTERFACE

   INTERFACE INCOMPLETE_GAMMA2
      MODULE PROCEDURE FMINCOMPLETE_GAMMA2_FM
   END INTERFACE

   INTERFACE LOG_GAMMA
      MODULE PROCEDURE FMLOG_GAMMA_FM
   END INTERFACE

   INTERFACE POLYGAMMA
      MODULE PROCEDURE FMPOLYGAMMA_FM
   END INTERFACE

   INTERFACE POCHHAMMER
      MODULE PROCEDURE FMPOCHHAMMER_FM
   END INTERFACE

   INTERFACE PSI
      MODULE PROCEDURE FMPSI_FM
   END INTERFACE

 CONTAINS

!                                                                 SIN

   FUNCTION FMSIN_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMSIN_FM
      INTENT (IN) :: MA
      CALL FMSIN(MA%MFM,FMSIN_FM%MFM)
   END FUNCTION

   FUNCTION FMSIN_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMSIN_ZM
      INTENT (IN) :: MA
      CALL ZMSIN(MA%MZM,FMSIN_ZM%MZM)
   END FUNCTION

!                                                                SINH

   FUNCTION FMSINH_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMSINH_FM
      INTENT (IN) :: MA
      CALL FMSINH(MA%MFM,FMSINH_FM%MFM)
   END FUNCTION

   FUNCTION FMSINH_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMSINH_ZM
      INTENT (IN) :: MA
      CALL ZMSINH(MA%MZM,FMSINH_ZM%MZM)
   END FUNCTION

!                                                             SPACING

   FUNCTION FMSPACING_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMSPACING_FM
      INTENT (IN) :: MA
      CALL FMABS(MA%MFM,MTFM)
      CALL FMULP(MTFM,FMSPACING_FM%MFM)
   END FUNCTION

!                                                                SQRT

   FUNCTION FMSQRT_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMSQRT_FM
      INTENT (IN) :: MA
      CALL FMSQRT(MA%MFM,FMSQRT_FM%MFM)
   END FUNCTION

   FUNCTION FMSQRT_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMSQRT_ZM
      INTENT (IN) :: MA
      CALL ZMSQRT(MA%MZM,FMSQRT_ZM%MZM)
   END FUNCTION

!                                                                 TAN

   FUNCTION FMTAN_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMTAN_FM
      INTENT (IN) :: MA
      CALL FMTAN(MA%MFM,FMTAN_FM%MFM)
   END FUNCTION

   FUNCTION FMTAN_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMTAN_ZM
      INTENT (IN) :: MA
      CALL ZMTAN(MA%MZM,FMTAN_ZM%MZM)
   END FUNCTION

!                                                                TANH

   FUNCTION FMTANH_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMTANH_FM
      INTENT (IN) :: MA
      CALL FMTANH(MA%MFM,FMTANH_FM%MFM)
   END FUNCTION

   FUNCTION FMTANH_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMTANH_ZM
      INTENT (IN) :: MA
      CALL ZMTANH(MA%MZM,FMTANH_ZM%MZM)
   END FUNCTION

!                                                                TINY

   FUNCTION FMTINY_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMTINY_FM
      INTEGER J
      INTENT (IN) :: MA
      FMTINY_FM%MFM(-1) = 1
      FMTINY_FM%MFM(0) = NINT(NDIG*ALOGM2)
      FMTINY_FM%MFM(1) = -MXEXP
      FMTINY_FM%MFM(2) = 1
      DO J = 3, NDIG+1
         FMTINY_FM%MFM(J) = 0
      ENDDO
   END FUNCTION

   FUNCTION FMTINY_IM(MA)
      USE FMVALS
      TYPE ( IM ) MA,FMTINY_IM
      INTENT (IN) :: MA
      CALL IMI2M(1,FMTINY_IM%MIM)
   END FUNCTION

   FUNCTION FMTINY_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) MA,FMTINY_ZM
      INTEGER J
      INTENT (IN) :: MA
      MTFM(-1) = 1
      MTFM(0) = NINT(NDIG*ALOGM2)
      MTFM(1) = -MXEXP
      MTFM(2) = 1
      DO J = 3, NDIG+1
         MTFM(J) = 0
      ENDDO
      CALL ZMCMPX(MTFM,MTFM,FMTINY_ZM%MZM)
   END FUNCTION

!                                                               TO_FM

   FUNCTION FM_I(IVAL)
      USE FMVALS
      TYPE ( FM ) FM_I
      INTEGER IVAL
      INTENT (IN) :: IVAL
      CALL FMI2M(IVAL,FM_I%MFM)
   END FUNCTION

   FUNCTION FM_R(R)
      USE FMVALS
      TYPE ( FM ) FM_R
      REAL R
      INTENT (IN) :: R
      CALL FMSP2M(R,FM_R%MFM)
   END FUNCTION

   FUNCTION FM_D(D)
      USE FMVALS
      TYPE ( FM ) FM_D
      DOUBLE PRECISION D
      INTENT (IN) :: D
      CALL FMDP2M(D,FM_D%MFM)
   END FUNCTION

   FUNCTION FM_Z(Z)
      USE FMVALS
      TYPE ( FM ) FM_Z
      COMPLEX Z
      INTENT (IN) :: Z
      CALL FMSP2M(REAL(Z),FM_Z%MFM)
   END FUNCTION

   FUNCTION FM_C(C)
      USE FMVALS
      TYPE ( FM ) FM_C
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),FM_C%MFM)
   END FUNCTION

   FUNCTION FM_FM(MA)
      USE FMVALS
      TYPE ( FM ) FM_FM,MA
      INTENT (IN) :: MA
      CALL FMEQ(MA%MFM,FM_FM%MFM)
   END FUNCTION

   FUNCTION FM_IM(MA)
      USE FMVALS
      TYPE ( FM ) FM_IM
      TYPE ( IM ) MA
      INTENT (IN) :: MA
      CALL IMI2FM(MA%MIM,FM_IM%MFM)
   END FUNCTION

   FUNCTION FM_ST(ST)
      USE FMVALS
      TYPE ( FM ) FM_ST
      CHARACTER(*) :: ST
      INTENT (IN) :: ST
      CALL FMST2M(ST,FM_ST%MFM)
   END FUNCTION

   FUNCTION FM_ZM(MA)
      USE FMVALS
      TYPE ( FM ) FM_ZM
      TYPE ( ZM ) MA
      INTENT (IN) :: MA
      CALL ZMREAL(MA%MZM,FM_ZM%MFM)
   END FUNCTION

!                                                               TO_IM

   FUNCTION IM_I(IVAL)
      USE FMVALS
      TYPE ( IM ) IM_I
      INTEGER IVAL
      INTENT (IN) :: IVAL
      CALL IMI2M(IVAL,IM_I%MIM)
   END FUNCTION

   FUNCTION IM_R(R)
      USE FMVALS
      TYPE ( IM ) IM_R
      REAL R
      CHARACTER(25) :: ST
      INTENT (IN) :: R
      IF (ABS(R) < HUGE(1)) THEN
          IVAL = INT(R)
          CALL IMI2M(IVAL,IM_R%MIM)
      ELSE
          WRITE (ST,'(E25.16)') R
          CALL IMST2M(ST,IM_R%MIM)
      ENDIF
   END FUNCTION

   FUNCTION IM_D(D)
      USE FMVALS
      TYPE ( IM ) IM_D
      DOUBLE PRECISION D
      CHARACTER(25) :: ST
      INTENT (IN) :: D
      IF (ABS(D) < HUGE(1)) THEN
          IVAL = INT(D)
          CALL IMI2M(IVAL,IM_D%MIM)
      ELSE
          WRITE (ST,'(E25.16)') D
          CALL IMST2M(ST,IM_D%MIM)
      ENDIF
   END FUNCTION

   FUNCTION IM_Z(Z)
      USE FMVALS
      TYPE ( IM ) IM_Z
      COMPLEX Z
      REAL R
      CHARACTER(25) :: ST
      INTENT (IN) :: Z
      R = REAL(Z)
      IF (ABS(R) < HUGE(1)) THEN
          IVAL = INT(R)
          CALL IMI2M(IVAL,IM_Z%MIM)
      ELSE
          WRITE (ST,'(E25.16)') R
          CALL IMST2M(ST,IM_Z%MIM)
      ENDIF
   END FUNCTION

   FUNCTION IM_C(C)
      USE FMVALS
      TYPE ( IM ) IM_C
      COMPLEX (KIND(0.0D0)) :: C
      DOUBLE PRECISION D
      CHARACTER(25) :: ST
      INTENT (IN) :: C
      D = REAL(C)
      IF (ABS(D) < HUGE(1)) THEN
          IVAL = INT(D)
          CALL IMI2M(IVAL,IM_C%MIM)
      ELSE
          WRITE (ST,'(E25.16)') D
          CALL IMST2M(ST,IM_C%MIM)
      ENDIF
   END FUNCTION

   FUNCTION IM_FM(MA)
      USE FMVALS
      TYPE ( IM ) IM_FM
      TYPE ( FM ) MA
      INTENT (IN) :: MA
      CALL IMFM2I(MA%MFM,IM_FM%MIM)
   END FUNCTION

   FUNCTION IM_IM(MA)
      USE FMVALS
      TYPE ( IM ) IM_IM,MA
      INTENT (IN) :: MA
      CALL IMEQ(MA%MIM,IM_IM%MIM)
   END FUNCTION

   FUNCTION IM_ST(ST)
      USE FMVALS
      TYPE ( IM ) IM_ST
      CHARACTER(*) :: ST
      INTENT (IN) :: ST
      CALL IMST2M(ST,IM_ST%MIM)
   END FUNCTION

   FUNCTION IM_ZM(MA)
      USE FMVALS
      TYPE ( IM ) IM_ZM
      TYPE ( ZM ) MA
      INTENT (IN) :: MA
      CALL ZMREAL(MA%MZM,MTFM)
      CALL IMFM2I(MTFM,IM_ZM%MIM)
   END FUNCTION

!                                                               TO_ZM

   FUNCTION ZM_I(IVAL)
      USE FMVALS
      TYPE ( ZM ) ZM_I
      INTEGER IVAL
      INTENT (IN) :: IVAL
      CALL ZMI2M(IVAL,ZM_I%MZM)
   END FUNCTION

   FUNCTION ZM_R(R)
      USE FMVALS
      TYPE ( ZM ) ZM_R
      REAL R
      INTENT (IN) :: R
      CALL FMSP2M(R,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,ZM_R%MZM)
   END FUNCTION

   FUNCTION ZM_D(D)
      USE FMVALS
      TYPE ( ZM ) ZM_D
      DOUBLE PRECISION D
      INTENT (IN) :: D
      CALL FMDP2M(D,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,ZM_D%MZM)
   END FUNCTION

   FUNCTION ZM_Z(Z)
      USE FMVALS
      TYPE ( ZM ) ZM_Z
      COMPLEX Z
      INTENT (IN) :: Z
      CALL ZMZ2M(Z,ZM_Z%MZM)
   END FUNCTION

   FUNCTION ZM_C(C)
      USE FMVALS
      TYPE ( ZM ) ZM_C
      COMPLEX (KIND(0.0D0)) :: C
      INTENT (IN) :: C
      CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
      CALL FMDP2M(AIMAG(C),MUFM)
      CALL ZMCMPX(MTFM,MUFM,ZM_C%MZM)
   END FUNCTION

   FUNCTION ZM_FM(MA)
      USE FMVALS
      TYPE ( ZM ) ZM_FM
      TYPE ( FM ) MA
      INTENT (IN) :: MA
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MA%MFM,MUFM,ZM_FM%MZM)
   END FUNCTION

   FUNCTION ZM_IM(MA)
      USE FMVALS
      TYPE ( ZM ) ZM_IM
      TYPE ( IM ) MA
      INTENT (IN) :: MA
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMI2M(0,MUFM)
      CALL ZMCMPX(MTFM,MUFM,ZM_IM%MZM)
   END FUNCTION

   FUNCTION ZM_ST(ST)
      USE FMVALS
      TYPE ( ZM ) ZM_ST
      CHARACTER(*) :: ST
      INTENT (IN) :: ST
      CALL ZMST2M(ST,ZM_ST%MZM)
   END FUNCTION

   FUNCTION ZM_ZM(MA)
      USE FMVALS
      TYPE ( ZM ) ZM_ZM,MA
      INTENT (IN) :: MA
      CALL ZMEQ(MA%MZM,ZM_ZM%MZM)
   END FUNCTION

!                                                              TO_INT

   FUNCTION FM_2INT(MA)
      TYPE ( FM ) MA
      INTEGER FM_2INT
      INTENT (IN) :: MA
      CALL FMM2I(MA%MFM,FM_2INT)
   END FUNCTION

   FUNCTION IM_2INT(MA)
      TYPE ( IM ) MA
      INTEGER IM_2INT
      INTENT (IN) :: MA
      CALL IMM2I(MA%MIM,IM_2INT)
   END FUNCTION

   FUNCTION ZM_2INT(MA)
      TYPE ( ZM ) MA
      INTEGER ZM_2INT
      INTENT (IN) :: MA
      CALL ZMM2I(MA%MZM,ZM_2INT)
   END FUNCTION

!                                                               TO_SP

   FUNCTION FM_2SP(MA)
      TYPE ( FM ) MA
      REAL FM_2SP
      INTENT (IN) :: MA
      CALL FMM2SP(MA%MFM,FM_2SP)
   END FUNCTION

   FUNCTION IM_2SP(MA)
      TYPE ( IM ) MA
      REAL IM_2SP
      INTENT (IN) :: MA
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMM2SP(MTFM,IM_2SP)
   END FUNCTION

   FUNCTION ZM_2SP(MA)
      TYPE ( ZM ) MA
      REAL ZM_2SP
      INTENT (IN) :: MA
      CALL ZMREAL(MA%MZM,MTFM)
      CALL FMM2SP(MTFM,ZM_2SP)
   END FUNCTION

!                                                               TO_DP

   FUNCTION FM_2DP(MA)
      TYPE ( FM ) MA
      DOUBLE PRECISION FM_2DP
      INTENT (IN) :: MA
      CALL FMM2DP(MA%MFM,FM_2DP)
   END FUNCTION

   FUNCTION IM_2DP(MA)
      TYPE ( IM ) MA
      DOUBLE PRECISION IM_2DP
      INTENT (IN) :: MA
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMM2DP(MTFM,IM_2DP)
   END FUNCTION

   FUNCTION ZM_2DP(MA)
      TYPE ( ZM ) MA
      DOUBLE PRECISION ZM_2DP
      INTENT (IN) :: MA
      CALL ZMREAL(MA%MZM,MTFM)
      CALL FMM2DP(MTFM,ZM_2DP)
   END FUNCTION

!                                                              TO_SPZ

   FUNCTION FM_2SPZ(MA)
      TYPE ( FM ) MA
      COMPLEX FM_2SPZ
      REAL R
      INTENT (IN) :: MA
      CALL FMM2SP(MA%MFM,R)
      FM_2SPZ = CMPLX( R , 0.0 )
   END FUNCTION

   FUNCTION IM_2SPZ(MA)
      TYPE ( IM ) MA
      COMPLEX IM_2SPZ
      REAL R
      INTENT (IN) :: MA
      CALL IMI2FM(MA%MIM,MTFM)
      CALL FMM2SP(MTFM,R)
      IM_2SPZ = CMPLX( R , 0.0 )
   END FUNCTION

   FUNCTION ZM_2SPZ(MA)
      TYPE ( ZM ) MA
      COMPLEX ZM_2SPZ
      INTENT (IN) :: MA
      CALL ZMM2Z(MA%MZM,ZM_2SPZ)
   END FUNCTION

!                                                              TO_DPZ

   FUNCTION FM_2DPZ(MA)
      TYPE ( FM ) MA
      COMPLEX (KIND(0.0D0)) :: FM_2DPZ
      DOUBLE PRECISION D
      INTENT (IN) :: MA
      CALL FMM2DP(MA%MFM,D)
      FM_2DPZ = CMPLX( D , 0.0D0 , KIND(0.0D0) )
   END FUNCTION

   FUNCTION IM_2DPZ(MA)
      TYPE ( IM ) MA
      COMPLEX (KIND(0.0D0)) :: IM_2DPZ
      DOUBLE PRECISION D
      INTENT (IN) :: MA
      CALL IMM2DP(MA%MIM,D)
      IM_2DPZ = CMPLX( D , 0.0D0 , KIND(0.0D0) )
   END FUNCTION

   FUNCTION ZM_2DPZ(MA)
      TYPE ( ZM ) MA
      COMPLEX (KIND(0.0D0)) :: ZM_2DPZ
      DOUBLE PRECISION D1,D2
      INTENT (IN) :: MA
      CALL ZMREAL(MA%MZM,MTFM)
      CALL FMM2DP(MTFM,D1)
      CALL ZMIMAG(MA%MZM,MTFM)
      CALL FMM2DP(MTFM,D2)
      ZM_2DPZ = CMPLX( D1 , D2 , KIND(0.0D0) )
   END FUNCTION

!                                                         FM_RANDOM_SEED

      SUBROUTINE FM_SEED(PUT,GET,SIZE)

!  Interface routine for FM_RANDOM_SEED, used to initialize the random sequence
!  from FM_RANDOM_NUMBER.

!  Like the Fortran intrinsic function RANDOM_SEED, exactly one of the three
!  arguments must be present, and the call should be with an argument keyword.

!  CALL FM_RANDOM_SEED(SIZE=J)   returns J=7 to the calling program, indicating
!       that the seed array has length 7.

!  CALL FM_RANDOM_SEED(GET=SEED)   returns SEED(1) through SEED(7) as the current
!       seed for the generator, but see the comments in routine FM_RANDOM_NUMBER.

!  CALL FM_RANDOM_SEED(PUT=SEED)   initializes the FM_RANDOM_NUMBER generator.

!  The typical usage is to call FM_RANDOM_SEED once with PUT defined as an
!  integer array of length 7 containing seven seed values used to initialize
!  the generator.  This initializes the table used by the mixed congruential
!  generator.  Then each call to FM_RANDOM_NUMBER gets the next random value.

!  This example seeds the generator and then fills the double precision array R
!  with random values between 0 and 1.

!        SEED = (/ 314159,265358,979323,846264,338327,950288,419716 /)
!        CALL FM_RANDOM_SEED(PUT=SEED)
!        DO J = 1, N
!           CALL FM_RANDOM_NUMBER(R(J))
!        ENDDO

      USE FMVALS

      IMPLICIT NONE

      INTEGER, OPTIONAL, INTENT(IN)  :: PUT(7)
      INTEGER, OPTIONAL, INTENT(OUT) :: GET(7)
      INTEGER, OPTIONAL, INTENT(OUT) :: SIZE

      REAL (KIND(1.0D0)) :: MSAVE
      INTEGER J,K


      IF (PRESENT(SIZE)) THEN
          SIZE = 7
          RETURN
      ENDIF
      MSAVE = MBASE
      MBASE = MBRAND
      IF (PRESENT(PUT)) THEN
          K = 10**7
          CALL IMI2M(ABS(PUT(1)),MRNX)
          DO J = 2, 7
             CALL IMMPYI(MRNX,K,MTIM)
             CALL IMI2M(ABS(PUT(J)),M04)
             CALL IMADD(MTIM,M04,MRNX)
          ENDDO
          CALL IMST2M('2070613773952029032014000773560846464373793273739',M04)
          CALL IMMOD(MRNX,M04,MTIM)
          CALL IMEQ(MTIM,MRNX)
          START_RANDOM_SEQUENCE = 1
          MBASE = MSAVE
          RETURN
      ENDIF
      IF (PRESENT(GET)) THEN
          K = 10**7
          CALL IMI2M(K,M05)
          CALL IMEQ(MRNX,M04)
          DO J = 7, 1, -1
             CALL IMMOD(M04,M05,M06)
             CALL IMM2I(M06,GET(J))
             CALL IMDIVI(M04,K,MTIM)
             CALL IMEQ(MTIM,M04)
          ENDDO
          MBASE = MSAVE
          RETURN
      ENDIF
      END SUBROUTINE

!                                                         FM_FORMAT

   FUNCTION FMFORMAT_FM(FMT,MA)
      USE FMVALS
      CHARACTER(*) :: FMT
      TYPE ( FM ) MA
      CHARACTER(200) :: FMFORMAT_FM
      INTENT (IN) :: FMT,MA
      CALL FMFORM(FMT,MA%MFM,FMFORMAT_FM)
   END FUNCTION

!                                                         IM_FORMAT

   FUNCTION IMFORMAT_IM(FMT,MA)
      USE FMVALS
      CHARACTER(*) :: FMT
      CHARACTER(200) :: IMFORMAT_IM
      TYPE ( IM ) MA
      INTENT (IN) :: FMT,MA
      CALL IMFORM(FMT,MA%MIM,IMFORMAT_IM)
   END FUNCTION

!                                                         ZM_FORMAT

   FUNCTION ZMFORMAT_ZM(FMTR,FMTI,MA)
      USE FMVALS
      CHARACTER(*) :: FMTR,FMTI
      CHARACTER(200) :: ZMFORMAT_ZM
      TYPE ( ZM ) MA
      INTENT (IN) :: FMTR,FMTI,MA
      CALL ZMFORM(FMTR,FMTI,MA%MZM,ZMFORMAT_ZM)
   END FUNCTION

!                                                         GCD

   FUNCTION GCD_IM(MA,MB)
      USE FMVALS
      TYPE ( IM ) MA,MB,GCD_IM
      INTENT (IN) :: MA,MB
      CALL IMGCD(MA%MIM,MB%MIM,GCD_IM%MIM)
   END FUNCTION

!                                                         MULTIPLY_MOD

   FUNCTION MULTIPLYMOD_IM(MA,MB,MC)
      USE FMVALS
      TYPE ( IM ) MA,MB,MC,MULTIPLYMOD_IM
      INTENT (IN) :: MA,MB,MC
      CALL IMMPYM(MA%MIM,MB%MIM,MC%MIM,MULTIPLYMOD_IM%MIM)
   END FUNCTION

!                                                         POWER_MOD

   FUNCTION POWERMOD_IM(MA,MB,MC)
      USE FMVALS
      TYPE ( IM ) MA,MB,MC,POWERMOD_IM
      INTENT (IN) :: MA,MB,MC
      CALL IMPMOD(MA%MIM,MB%MIM,MC%MIM,POWERMOD_IM%MIM)
   END FUNCTION

!                                                         BERNOULLI

   FUNCTION FMBERNOULLI_FM(N)
      USE FMVALS
      TYPE ( FM ) FMBERNOULLI_FM
      INTEGER N
      INTENT (IN) :: N
      CALL FMI2M(1,MTFM)
      CALL FMBERN(N,MTFM,FMBERNOULLI_FM%MFM)
   END FUNCTION

!                                                         BETA

   FUNCTION FMBETA_FM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMBETA_FM
      INTENT (IN) :: MA,MB
      CALL FMBETA(MA%MFM,MB%MFM,FMBETA_FM%MFM)
   END FUNCTION

!                                                         BINOMIAL

   FUNCTION FMBINOMIAL_FM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMBINOMIAL_FM
      INTENT (IN) :: MA,MB
      CALL FMCOMB(MA%MFM,MB%MFM,FMBINOMIAL_FM%MFM)
   END FUNCTION

!                                                         FACTORIAL

   FUNCTION FMFACTORIAL_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMFACTORIAL_FM
      INTENT (IN) :: MA
      CALL FMFACT(MA%MFM,FMFACTORIAL_FM%MFM)
   END FUNCTION

!                                                         GAMMA

   FUNCTION FMGAMMA_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMGAMMA_FM
      INTENT (IN) :: MA
      CALL FMGAM(MA%MFM,FMGAMMA_FM%MFM)
   END FUNCTION

!                                                         INCOMPLETE_BETA

   FUNCTION FMINCOMPLETE_BETA_FM(MX,MA,MB)
      USE FMVALS
      TYPE ( FM ) MX,MA,MB,FMINCOMPLETE_BETA_FM
      INTENT (IN) :: MX,MA,MB
      CALL FMIBTA(MX%MFM,MA%MFM,MB%MFM,FMINCOMPLETE_BETA_FM%MFM)
   END FUNCTION

!                                                         INCOMPLETE_GAMMA1

   FUNCTION FMINCOMPLETE_GAMMA1_FM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMINCOMPLETE_GAMMA1_FM
      INTENT (IN) :: MA,MB
      CALL FMIGM1(MA%MFM,MB%MFM,FMINCOMPLETE_GAMMA1_FM%MFM)
   END FUNCTION

!                                                         INCOMPLETE_GAMMA2

   FUNCTION FMINCOMPLETE_GAMMA2_FM(MA,MB)
      USE FMVALS
      TYPE ( FM ) MA,MB,FMINCOMPLETE_GAMMA2_FM
      INTENT (IN) :: MA,MB
      CALL FMIGM2(MA%MFM,MB%MFM,FMINCOMPLETE_GAMMA2_FM%MFM)
   END FUNCTION

!                                                         LOG_GAMMA

   FUNCTION FMLOG_GAMMA_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMLOG_GAMMA_FM
      INTENT (IN) :: MA
      CALL FMLNGM(MA%MFM,FMLOG_GAMMA_FM%MFM)
   END FUNCTION

!                                                         POLYGAMMA

   FUNCTION FMPOLYGAMMA_FM(N,MA)
      USE FMVALS
      TYPE ( FM ) MA,FMPOLYGAMMA_FM
      INTEGER N
      INTENT (IN) :: N,MA
      CALL FMPGAM(N,MA%MFM,FMPOLYGAMMA_FM%MFM)
   END FUNCTION

!                                                         POCHHAMMER

   FUNCTION FMPOCHHAMMER_FM(MA,N)
      USE FMVALS
      TYPE ( FM ) MA,FMPOCHHAMMER_FM
      INTEGER N
      INTENT (IN) :: N,MA
      CALL FMPOCH(MA%MFM,N,FMPOCHHAMMER_FM%MFM)
   END FUNCTION

!                                                         PSI

   FUNCTION FMPSI_FM(MA)
      USE FMVALS
      TYPE ( FM ) MA,FMPSI_FM
      INTENT (IN) :: MA
      CALL FMPSI(MA%MFM,FMPSI_FM%MFM)
   END FUNCTION

 END MODULE FMZM_9

 MODULE FMZM

   USE FMZM_1
   USE FMZM_2
   USE FMZM_3
   USE FMZM_4
   USE FMZM_5
   USE FMZM_6
   USE FMZM_7
   USE FMZM_8
   USE FMZM_9

 END MODULE FMZM
SHAR_EOF
fi # end of overwriting check
cd ..
cd ..
cd ..
#       End of shell archive
exit 0