


!     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 (MA(-1) < 0) THEN
          MKSUM = MA(KPTMA) - IVAL
      ELSE
          MKSUM = MA(KPTMA) + IVAL
      ENDIF

      IF (MKSUM >= MBASE .OR. MKSUM < 0) GO TO 110
      IF (KPTMA == 2 .AND. MKSUM == 0) GO TO 110
      MA(KPTMA) = MKSUM
      GO TO 120

  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
      KL = M01(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)) THEN
                     IF (MA(J) < M01(J)) KLTFLG = 1
                     GO TO 120
                 ENDIF
              ENDDO
              KLTFLG = 2
          ENDIF
  120     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+1
             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)
          IF (IJSIGN < 0) THEN
              CALL ZMI2M(1,MZ01)
              CALL ZMDIV(MZ01,MB,MZ02)
              CALL ZMEQ(MZ02,MB)
          ENDIF
          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 FMABS(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 FMABS(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,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
