



!     FM 1.2                    David M. Smith                  2-07-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+2 words. A packed representation is

!  available to store the numbers in the user's program in compressed form.  In

!  this format, the NDIG (base MBASE) digits of the mantissa are packed two per

!  word to conserve storage.  Thus the external, packed form of a number

!  requires (NDIG+1)/2+2 words.



!  This version uses double precision arrays to hold the numbers.  Version 1.0

!  of FM used integer arrays, which are faster on some machines.  The package

!  can be changed to use integer arrays --- see section 11 on EFFICIENCY below.



!  The unpacked format of a floating multiple precision number is as follows.

!  A number MA is kept in an array with MA(1) containing the exponent, and

!  MA(2) through MA(NDIG+1) each containing one digit of the mantissa, expressed

!  in base MBASE.  The array is dimensioned to start at MA(0), with the

!  approximate number of bits of precision stored in MA(0).  This precision

!  value is intended to be used by FM functions that need to monitor

!  cancellation error in addition and subtraction.  The cancellation monitor

!  code is usually disabled for user calls, and FM functions only check for

!  cancellation when they must.  Tracking cancellation causes most routines to

!  run slower, with addition and subtraction being affected the most.  The

!  exponent is a power of MBASE and the implied radix point is immediately

!  before the first digit of the mantissa.  Every nonzero number is normalized

!  so that the second array element (the first digit of the mantissa) is

!  nonzero.



!  In both representations the sign of the number is carried on the second array

!  element only.  Elements 3,4,... are always nonnegative.  The exponent is a

!  signed integer and may be as large in magnitude as MXEXP.



!  For MBASE = 10,000 and NDIG = 4, the number -pi would have these

!  representations:

!                   Word 1         2         3         4         5



!         Unpacked:      1        -3      1415      9265      3590

!         Packed:        1    -31415  92653590



!  Word 0 would be 42 in both formats, indicating that the mantissa has about 42

!  bits of precision.



!  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 = 256, so on a 32-bit machine using

!  MBASE = 10**7 the maximum precision is about 7*255+1 = 1786 significant

!  digits.  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 = 256' to 'NDIGMX = 1434' in FMSAVE.f90

!  will define all the new array sizes.



!  If NDIG much greater than 256 is to be used and elementary functions will

!  be needed, they will be faster if array MJSUMS is larger.  The parameter

!  defining the size of MJSUMS is set in the standard version by

!      LJSUMS = 8*(LUNPCK+2)

!  The 8 means that up to eight concurrent sums can be used by the elementary

!  functions.  The approximate number needed for best speed is given by

!      0.051*Log(MBASE)*NDIG**0.333 + 1.85

!  For example, with MBASE=10**7 and NDIG=1434 this gives 11.  Changing

!  'LJSUMS = 8*(LUNPCK+2)' to 'LJSUMS = 11*(LUNPCK+2)' in FMSAVE.f90 will give

!  slightly better speed.



!  FM numbers in packed format have dimension 0:LPACK, and those in unpacked

!  format have dimension 0: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 each case it is permissible to use the same array more than once

!  in the calling sequence.  The statement MA = MA*MA can be written

!  CALL FMMPY(MA,MA,MA).



!  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



!  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



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



!  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



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



!  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.



!  FMSQRT(MA,MB)        MB = 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



!  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.



!  In each case it is permissible to use the same array more than

!  once in the calling sequence.  The statement

!  MA = MA*MA   may be written  CALL ZMMPY(MA,MA,MA).



!  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 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



!  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 DOUBLE PRECISION M....



!  For example, to change the package to use integer arithmetic internally, make

!  these two changes everywhere in the FM.f90 file.

!  change  'DOUBLE PRECISION M'  to  'INTEGER M',

!  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.



!  One similar change must be made throughout the file FMSAVE.f90.

!  change  'DOUBLE PRECISION, SAVE :: M'  to

!          'INTEGER, SAVE :: M'

!  Since many of these variables are initialized when they are declared, 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.



!  For module FMZM in file FMZM90.f90

!  change all  'DOUBLE PRECISION M'  to  'INTEGER M'



!  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.



!  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



      DOUBLE PRECISION 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,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 = -MXEXP2 - 5*NDIGMX

      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 = MEXPOV + 5*NDIGMX

      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



      DOUBLE PRECISION 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(2) = ABS(MB(2))

      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMACOS:   M01 - M06



      DOUBLE PRECISION MA2,MACCA,MACMAX,MXSAVE

      INTEGER 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



      MA2 = MA(2)

      MACCA = MA(0)

      CALL FMEQ2(MA,MB,NDSAVE,NDIG,0)

      MB(0) = NINT(NDIG*ALOGM2)



!             Use ACOS(X) = ATAN(SQRT(1-X*X)/X)



      MB(2) = ABS(MB(2))

      CALL FMI2M(1,M05)

      CALL FMSUB(M05,MB,M03)

      CALL FMADD(M05,MB,M04)

      CALL FMMPY(M03,M04,M04)

      CALL FMSQRT(M04,M04)

      CALL FMDIV(M04,MB,MB)



      CALL FMATAN(MB,MB)



      IF (MA2 < 0) THEN

          IF (KRAD == 1) THEN

              CALL FMPI(M05)

          ELSE

              CALL FMI2M(180,M05)

          ENDIF

          CALL FMSUB(M05,MB,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)

      CALL FMEXIT(MB,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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0: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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



      DOUBLE PRECISION MA0,MA1,MA2,MB0,MB1,MB2,MB2RD

      INTEGER J,JCOMP,JRSSAV,JSIGN,KRESLT,N1,NGUARD,NMWA

      REAL B2RDA,B2RDB



      IF (MBLOGS /= MBASE) CALL FMCONS

      JRSSAV = JRSIGN

      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) MC(2) = -MC(2)

                  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

      MA2 = MA(2)

      MB2 = MB(2)

      IF (KSUB == 1) MB2 = -MB2

      MA(2) = ABS(MA(2))

      MB(2) = ABS(MB(2))



!             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 (MA2 < 0) JSIGN = -1

          JRSIGN = JSIGN

          IF (MA2*MB2 > 0) THEN

              CALL FMADDP(MA,MB,NGUARD,NMWA)

          ELSE

              CALL FMADDN(MA,MB,NGUARD,NMWA)

          ENDIF

      ELSE

          IF (MB2 < 0) JSIGN = -1

          JRSIGN = JSIGN

          IF (MA2*MB2 > 0) THEN

              CALL FMADDP(MB,MA,NGUARD,NMWA)

          ELSE

              CALL FMADDN(MB,MA,NGUARD,NMWA)

          ENDIF

      ENDIF

      IF (KSUB == 1) MB2 = -MB2

      MB(2) = MB2

      MA(2) = MA2



!             Transfer to MC and fix the sign of the result.



      CALL FMMOVE(MWA,MC)

      IF (JSIGN < 0) MC(2) = -MC(2)



      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 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



      DOUBLE PRECISION MA(0:LUNPCK)

      INTEGER IVAL



!             Scratch array usage during FMADDI:   M01



      DOUBLE PRECISION MAEXP,MD2B,MKSUM

      INTEGER KPTMA



      NCALL = NCALL + 1

      IF (NTRACE /= 0) THEN

          NAMEST(NCALL) = 'FMADDI'

          CALL FMNTR(2,MA,MA,1,1)

          CALL FMNTRI(2,IVAL,0)

      ENDIF

      KFLAG = 0



      MAEXP = MA(1)

      IF (MAEXP <= 0 .OR. MAEXP > NDIG) GO TO 110

      KPTMA = INT(MAEXP) + 1

      IF (KPTMA > 2 .AND. MA(2) < 0) THEN

          MKSUM = MA(KPTMA) - IVAL

      ELSE

          MKSUM = MA(KPTMA) + IVAL

      ENDIF



      IF (MKSUM >= MBASE .OR. MKSUM <= (-MBASE)) GO TO 110

      IF (MA(2) < 0) THEN

          IF (KPTMA > 2) THEN

              IF (MKSUM >= 0) THEN

                  MA(KPTMA) = MKSUM

                  GO TO 120

              ELSE

                  GO TO 110

              ENDIF

          ELSE

              IF (MKSUM < 0) THEN

                  MA(KPTMA) = MKSUM

                  GO TO 120

              ELSE

                  GO TO 110

              ENDIF

          ENDIF

      ELSE

          IF (KPTMA > 2) THEN

              IF (MKSUM >= 0) THEN

                  MA(KPTMA) = MKSUM

                  GO TO 120

              ELSE

                  GO TO 110

              ENDIF

          ELSE

              IF (MKSUM > 0) THEN

                  MA(KPTMA) = MKSUM

                  GO TO 120

              ELSE

                  GO TO 110

              ENDIF

          ENDIF

      ENDIF



  110 CALL FMI2M(IVAL,M01)

      CALL FMADD2(MA,M01,MA)



  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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER NGUARD,NMWA

      DOUBLE PRECISION 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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER NGUARD,NMWA

      DOUBLE PRECISION 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

      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER NARGS,KRESLT



      DOUBLE PRECISION 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

              CALL FMIM(0,MA)

              KFLAG = -3

              CALL FMWARN

              MA(1) = MUNKNO

              MA(2) = 1

              MA(0) = NINT(NDIG*ALOGM2)

              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

                  CALL FMIM(0,MA)

                  KFLAG = -3

                  CALL FMWARN

                  MA(1) = MUNKNO

                  MA(2) = 1

                  MA(0) = NINT(NDIG*ALOGM2)

                  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) <= (-MBASE) .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

          CALL FMIM(0,MA)

          KFLAG = -4

          MA(1) = MUNKNO

          MA(2) = 1

          MA(0) = NINT(NDIG*ALOGM2)

          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) <= (-MBASE) .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

              CALL FMIM(0,MB)

              KFLAG = -4

              MB(1) = MUNKNO

              MB(2) = 1

              MB(0) = NINT(NDIG*ALOGM2)

              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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMASIN:   M01 - M06



      DOUBLE PRECISION MACCA,MACMAX,MXSAVE

      INTEGER 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,0)

      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(M03,M04,M04)

      CALL FMSQRT(M04,M04)

      CALL FMDIV(MB,M04,MB)



      CALL FMATAN(MB,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)

      CALL FMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)

      RETURN

      END SUBROUTINE FMASIN

      SUBROUTINE FMATAN(MA,MB)



!  MB = ARCTAN(MA)



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION X,XM

      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER NSTACK(19)



!             Scratch array usage during FMATAN:   M01 - M06



      DOUBLE PRECISION MA1,MA2,MACCA,MACMAX,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,0)

      M05(0) = NINT(NDIG*ALOGM2)



!             If MA >= 1 work with 1/MA.



      MA1 = MA(1)

      MA2 = MA(2)

      M05(2) = ABS(M05(2))

      IF (MA1 >= 1) THEN

          CALL FMI2M(1,MB)

          CALL FMDIV(MB,M05,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(M05,M06,M05)

          IF (M05(1) /= MUNKNO) M05(2) = -M05(2)

          CALL FMDIVI(M05,J,M03)

          NDIG = NDSAV1

          CALL FMADD(MB,M03,MB)

          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(M04,M03,M03)

             CALL FMSQRT(M03,M04)

             CALL FMDIV(M06,M04,M04)

             CALL FMSUB(M04,M05,M04)

             CALL FMMPY(M03,M04,M04)

             CALL FMSUB(MB,M04,MB)

          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(M06,MB,MB)

      ENDIF



!             Convert to degrees if necessary, round and return.



      KRAD = KRSAVE

      IF (KRAD == 0) THEN

          CALL FMMPYI(MB,180,MB)

          CALL FMDIV(MB,MPISAV,MB)

      ENDIF

      IF (MB(1) /= MUNKNO .AND. MA2 < 0) MB(2) = -MB(2)



      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)

      CALL FMEXIT(MB,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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



!             Scratch array usage during FMATN2:   M01 - M06



      DOUBLE PRECISION MACCA,MACCB,MACMAX,MXEXP1,MXSAVE

      INTEGER 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,0)

      M01(0) = NINT(NDIG*ALOGM2)

      CALL FMEQ2(MB,M02,NDSAVE,NDIG,0)

      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(2) > 0) THEN

          IF (KRAD == 0) THEN

              CALL FMI2M(90,MC)

          ELSE

              CALL FMPI(MC)

              CALL FMDIVI(MC,2,MC)

          ENDIF

          GO TO 110

      ENDIF



      IF (MB(2) == 0 .AND. MA(2) < 0) THEN

          IF (KRAD == 0) THEN

              CALL FMI2M(-90,MC)

          ELSE

              CALL FMPI(MC)

              CALL FMDIVI(MC,-2,MC)

          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(MC,2,MC)

          ENDIF

          IF (M01(2) < 0) MC(2) = -MC(2)

          GO TO 110

      ENDIF



      IF (MA(1) == MEXPUN .AND. (-MB(1)) < MXEXP1-NDIG-2 .AND.  &

                                 MB(2) < 0) THEN

          IF (KRAD == 0) THEN

              CALL FMI2M(180,MC)

          ELSE

              CALL FMPI(MC)

          ENDIF

          IF (M01(2) < 0) MC(2) = -MC(2)

          GO TO 110

      ENDIF



      IF (MB(1) == MEXPOV .AND. MA(1) < MXEXP1-NDIG-2 .AND.  &

                                MB(2) < 0) THEN

          IF (KRAD == 0) THEN

              CALL FMI2M(180,MC)

          ELSE

              CALL FMPI(MC)

          ENDIF

          IF (M01(2) < 0) MC(2) = -MC(2)

          GO TO 110

      ENDIF



      IF (MB(1) == MEXPUN .AND. MA(2) == 0) THEN

          IF (MB(2) < 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(MC,2,MC)

          ENDIF

          IF (M01(2) < 0) MC(2) = -MC(2)

          GO TO 110

      ENDIF



!             Determine the quadrant for the result, then use FMATAN.



      IF (MA(2) >= 0 .AND. MB(2) > 0) JQUAD = 1

      IF (MA(2) >= 0 .AND. MB(2) < 0) JQUAD = 2

      IF (MA(2) < 0 .AND. MB(2) < 0) JQUAD = 3

      IF (MA(2) < 0 .AND. MB(2) > 0) JQUAD = 4



      CALL FMDIV(M01,M02,MC)

      MC(2) = ABS(MC(2))

      CALL FMATAN(MC,MC)



      IF (JQUAD == 2 .OR. JQUAD == 3) THEN

          IF (KRAD == 0) THEN

              CALL FMI2M(180,M05)

              CALL FMSUB(M05,MC,MC)

          ELSE

              CALL FMPI(M05)

              CALL FMSUB(M05,MC,MC)

          ENDIF

      ENDIF



      IF ((JQUAD == 3 .OR. JQUAD == 4) .AND. MC(1) /= MUNKNO)  &

          MC(2) = -MC(2)



!             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)

      CALL FMEXIT(MC,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



      DOUBLE PRECISION MA(0: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)



      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



      DOUBLE PRECISION MA(0:LUNPCK)

      INTEGER NCAT



      DOUBLE PRECISION 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(2) < 0) NCAT = 1

          RETURN

      ENDIF



      IF (MA(1) == MEXPUN) THEN

          NCAT = 9

          IF (MA(2) < 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(2) < 0) NCAT = 4

          RETURN

      ENDIF



  110 MXEXP1 = INT(MXEXP)

      IF (MA(1) >= MXEXP1-NDIG+2) THEN

          NCAT = 14

          IF (MA(2) < 0) NCAT = 2

          RETURN

      ENDIF



      IF (MA(1) >= 1) THEN

          NCAT = 13

          IF (MA(2) < 0) NCAT = 3

          RETURN

      ENDIF



      IF (MA(1) >= -MXEXP1+NDIG) THEN

          NCAT = 11

          IF (MA(2) < 0) NCAT = 5

          RETURN

      ENDIF



      IF (MA(1) >= -MXEXP1) THEN

          NCAT = 10

          IF (MA(2) < 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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



!             Scratch array usage during FMCHSH:   M01 - M04



      DOUBLE PRECISION MA2,MACCA,MACMAX,MXSAVE

      INTEGER K,KASAVE,KOVUN,KRESLT,KWRNSV,NCSAVE,NDSAVE



      IF (MBLOGS /= MBASE) CALL FMCONS

      MACCA = MA(0)

      MA2 = MA(2)

      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,0)

          M04(0) = NINT(NDIG*ALOGM2)

          M04(2) = ABS(M04(2))

          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,0)

      M04(0) = NINT(NDIG*ALOGM2)

      M04(2) = ABS(M04(2))



      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(M03,M02,M03)

          CALL FMSQRT(M03,MC)

      ELSE

          CALL FMSINH(M04,MC)

          CALL FMSQR(MC,M03)

          CALL FMI2M(1,M02)

          CALL FMADD(M03,M02,M03)

          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 (MA2 < 0 .AND. MC(1) /= MUNKNO) MC(2) = -MC(2)

      CALL FMEQ2(MC,MC,NDIG,NDSAVE,1)

      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

      CALL FMEXIT(MB,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

      DOUBLE PRECISION MA(0:LUNPCK),MB(0: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)) 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) JCOMP = 1

          IF (MB(2) > 0) JCOMP = 3

          GO TO 110

      ENDIF

      IF (MB(2) == 0) THEN

          JCOMP = 1

          IF (MA(2) < 0) JCOMP = 3

          GO TO 110

      ENDIF

!             Check for opposite signs.



      IF (MA(2) > 0 .AND. MB(2) < 0) THEN

          JCOMP = 1

          GO TO 110

      ENDIF

      IF (MB(2) > 0 .AND. MA(2) < 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(2) < 0) THEN

          JCOMP = 3

      ELSE IF (JCOMP == 3 .AND. MB(2) < 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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMCOS:   M01 - M04



      DOUBLE PRECISION MACCA,MACMAX,MXSAVE

      INTEGER 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,0)

      MB(0) = NINT(NDIG*ALOGM2)

      MB(2) = ABS(MB(2))

      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,MB,JSIN,JCOS,JSWAP)

      KWARN = KWRNSV

      IF (MB(1) == MUNKNO) THEN

          IF (KRAD /= 1 .OR. JSWAP == 1) THEN

              CALL FMRDC(MWE,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(MWE,M02,M02)

          IF (M02(2) == 0) CALL FMULP(MWE,M02)

          CALL FMI2M(1,M04)

          CALL FMSQR(M02,M02)

          CALL FMDIVI(M02,2,M02)

          CALL FMSUB(M04,M02,M02)

          CALL FMSUB(M02,M04,M02)

          IF (M02(2) == 0) THEN

              CALL FMI2M(JCOS,MB)

          ELSE

              CALL FMRDC(MWE,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(MB,MPISAV,MB)

          CALL FMDIVI(MB,180,MB)

      ENDIF

      IF (MB(1) /= MUNKNO) THEN

          IF (JSWAP == 0) THEN

              CALL FMCOS2(MB,MB)

          ELSE

              IF (MB(1) < 0 .OR. NDIG <= 50) THEN

                  CALL FMSIN2(MB,MB)

              ELSE

                  CALL FMCOS2(MB,MB)

                  CALL FMI2M(1,M03)

                  CALL FMSQR(MB,MB)

                  CALL FMSUB(M03,MB,MB)

                  CALL FMSQRT(MB,MB)

              ENDIF

          ENDIF

      ENDIF



!             Append the sign, round, and return.



      IF (MB(1) /= MUNKNO .AND. JCOS == -1) MB(2) = -MB(2)

  110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)

      MB(0) = MIN(MB(0),MACCA,MACMAX)

      CALL FMEXIT(MB,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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMCOS2:   M01 - M04



!             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.



      DOUBLE PRECISION 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

          KFLAG = -9

          CALL FMWARN

          NDIG = NDSAVE

          CALL FMST2M('UNKNOWN',MB)

          KWARN = KWRNSV

          RETURN

      ENDIF

      NDSAV1 = NDIG



!             Divide the argument by 2**K2.



      CALL FMEQ2(MA,M02,NDSAVE,NDIG,0)

      KTWO = 1

      MAXVAL = MXBASE/2

      IF (K2 > 0) THEN

          DO J = 1, K2

             KTWO = 2*KTWO

             IF (KTWO > MAXVAL) THEN

                 CALL FMDIVI(M02,KTWO,M02)

                 KTWO = 1

             ENDIF

          ENDDO

          IF (KTWO > 1) CALL FMDIVI(M02,KTWO,M02)

      ENDIF



!             Split into J2 concurrent sums and reduce NDIG while

!             computing each term in the sum as the terms get smaller.



      CALL FMSQR(M02,M02)

      CALL FMEQ(M02,M03)

      M03(2) = -M03(2)

      NTERM = 2

      DO J = 1, J2

         NBOT = NTERM*(NTERM-1)

         CALL FMDIVI(M03,NBOT,M03)

         NTERM = NTERM + 2

         KPT = (J-1)*(NDIG+2)

         CALL FMEQ(M03,MJSUMS(KPT))

         M03(2) = -M03(2)

      ENDDO

      IF (M02(1) < -NDIG) GO TO 120

      CALL FMIPWR(M02,J2,MB)



  110 CALL FMMPY(M03,MB,M03)

      LARGE = INT(INTMAX/NTERM)

      DO J = 1, J2

         NBOT = NTERM*(NTERM-1)

         IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN

             CALL FMDIVI(M03,NTERM,M03)

             NBOT = NTERM - 1

             CALL FMDIVI(M03,NBOT,M03)

         ELSE

             CALL FMDIVI(M03,NBOT,M03)

         ENDIF

         KPT = (J-1)*(NDSAV1+2)

         NDIG = NDSAV1

         CALL FMADD(MJSUMS(KPT),M03,MJSUMS(KPT))

         IF (KFLAG /= 0) GO TO 120

         NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1))

         IF (NDIG < 2) NDIG = 2

         M03(2) = -M03(2)

         NTERM = NTERM + 2

      ENDDO

      GO TO 110



!             Next put the J2 separate sums back together.



  120 KFLAG = 0

      KPT = (J2-1)*(NDIG+2)

      CALL FMEQ(MJSUMS(KPT),MB)

      IF (J2 >= 2) THEN

          DO J = 2, J2

             CALL FMMPY(M02,MB,MB)

             KPT = (J2-J)*(NDIG+2)

             CALL FMADD(MB,MJSUMS(KPT),MB)

          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(MB,M03,M03)

                 CALL FMADD(M03,M03,MB)

              ENDDO

          ELSE

              DO J = 1, K2

                 CALL FMSQR(MB,M03)

                 CALL FMADD(MB,MB,M02)

                 CALL FMADD(M03,M02,M03)

                 CALL FMADD(M03,M03,MB)

              ENDDO

          ENDIF

      ENDIF

      CALL FMI2M(1,M03)

      CALL FMADD(M03,MB,MB)



      CALL FMEQ2(MB,MB,NDSAV1,NDSAVE,1)

      NDIG = NDSAVE

      KWARN = KWRNSV



      RETURN

      END SUBROUTINE FMCOS2

      SUBROUTINE FMCOSH(MA,MB)



!  MB = COSH(MA)



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMCOSH:   M01 - M03



      DOUBLE PRECISION MACCA,MACMAX,MXSAVE

      INTEGER 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,0)

      MB(0) = NINT(NDIG*ALOGM2)

      MB(2) = ABS(MB(2))

      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,MB)

      GO TO 120



  110 CALL FMEXP(MB,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(M01,MB,M01)

          CALL FMADD(MB,M01,MB)

      ENDIF

      CALL FMDIVI(MB,2,MB)



!             Round and return.



  120 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)

      MB(0) = MIN(MB(0),MACCA,MACMAX)

      CALL FMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)

      RETURN

      END SUBROUTINE FMCOSH

      SUBROUTINE FMCSH2(MA,MB)



!  Internal subroutine for MB = COSH(MA).



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMCSH2:   M01 - M03



!             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.



      DOUBLE PRECISION 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

          KFLAG = -9

          CALL FMWARN

          NDIG = NDSAVE

          CALL FMST2M('UNKNOWN',MB)

          KWARN = KWRNSV

          RETURN

      ENDIF

      NDSAV1 = NDIG

      CALL FMEQ2(MA,M02,NDSAVE,NDIG,0)



!             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(M02,KTWO,M02)

                 KTWO = 1

             ENDIF

          ENDDO

          IF (KTWO > 1) CALL FMDIVI(M02,KTWO,M02)

      ENDIF



!             Split into J2 concurrent sums and reduce NDIG while

!             computing each term in the sum as the terms get smaller.



      CALL FMSQR(M02,M02)

      CALL FMEQ(M02,M03)

      NTERM = 2

      DO J = 1, J2

         NBOT = NTERM*(NTERM-1)

         CALL FMDIVI(M03,NBOT,M03)

         NTERM = NTERM + 2

         KPT = (J-1)*(NDIG+2)

         CALL FMEQ(M03,MJSUMS(KPT))

      ENDDO

      IF (M02(1) < -NDIG) GO TO 120

      CALL FMIPWR(M02,J2,MB)



  110 CALL FMMPY(M03,MB,M03)

      LARGE = INT(INTMAX/NTERM)

      DO J = 1, J2

         NBOT = NTERM*(NTERM-1)

         IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN

             CALL FMDIVI(M03,NTERM,M03)

             NBOT = NTERM - 1

             CALL FMDIVI(M03,NBOT,M03)

         ELSE

             CALL FMDIVI(M03,NBOT,M03)

         ENDIF

         KPT = (J-1)*(NDSAV1+2)

         NDIG = NDSAV1

         CALL FMADD(MJSUMS(KPT),M03,MJSUMS(KPT))

         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+2)

      CALL FMEQ(MJSUMS(KPT),MB)

      IF (J2 >= 2) THEN

          DO J = 2, J2

             CALL FMMPY(M02,MB,MB)

             KPT = (J2-J)*(NDIG+2)

             CALL FMADD(MB,MJSUMS(KPT),MB)

          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(MB,M03,M03)

                 CALL FMADD(M03,M03,MB)

              ENDDO

          ELSE

              DO J = 1, K2

                 CALL FMSQR(MB,M03)

                 CALL FMADD(MB,MB,M02)

                 CALL FMADD(M03,M02,M03)

                 CALL FMADD(M03,M03,MB)

              ENDDO

          ENDIF

      ENDIF

      CALL FMI2M(1,M03)

      CALL FMADD(M03,MB,MB)



      CALL FMEQ2(MB,MB,NDSAV1,NDSAVE,1)

      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



!             Scratch array usage during FMCSSN:   M01 - M05



      DOUBLE PRECISION MA2,MACCA,MACMAX,MXSAVE

      INTEGER JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,KWRNSV,NCSAVE,  &

              NDSAVE,NDSV



      IF (MBLOGS /= MBASE) CALL FMCONS

      MACCA = MA(0)

      MA2 = MA(2)

      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,0)

          M05(0) = NINT(NDIG*ALOGM2)

          M05(2) = ABS(M05(2))

          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,0)

      MB(0) = NINT(NDIG*ALOGM2)

      MB(2) = ABS(MB(2))

      CALL FMEQ(MB,MWE)



!             Reduce the argument, convert to radians if the input is

!             in degrees, and evaluate the functions.



      CALL FMRDC(MB,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(MB,MPISAV,MB)

          CALL FMDIVI(MB,180,MB)

      ENDIF

      IF (MB(1) /= MUNKNO) THEN

          IF (JSWAP == 0) THEN

              IF (MB(1) < 0) THEN

                  CALL FMSIN2(MB,MC)

                  MC(2) = JSIN*MC(2)

                  CALL FMSQR(MC,M03)

                  CALL FMI2M(1,M02)

                  CALL FMSUB(M02,M03,M03)

                  CALL FMSQRT(M03,MB)

                  MB(2) = JCOS*MB(2)

              ELSE

                  CALL FMCOS2(MB,MB)

                  MB(2) = JCOS*MB(2)

                  CALL FMSQR(MB,M03)

                  CALL FMI2M(1,M02)

                  CALL FMSUB(M02,M03,M03)

                  CALL FMSQRT(M03,MC)

                  MC(2) = JSIN*MC(2)

              ENDIF

          ELSE

              IF (MB(1) < 0) THEN

                  CALL FMSIN2(MB,MB)

                  MB(2) = JCOS*MB(2)

                  CALL FMSQR(MB,M03)

                  CALL FMI2M(1,M02)

                  CALL FMSUB(M02,M03,M03)

                  CALL FMSQRT(M03,MC)

                  MC(2) = JSIN*MC(2)

              ELSE

                  CALL FMCOS2(MB,MC)

                  MC(2) = JSIN*MC(2)

                  CALL FMSQR(MC,M03)

                  CALL FMI2M(1,M02)

                  CALL FMSUB(M02,M03,M03)

                  CALL FMSQRT(M03,MB)

                  MB(2) = JCOS*MB(2)

              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 (MA2 < 0 .AND. MC(1) /= MUNKNO) MC(2) = -MC(2)

      CALL FMEQ2(MC,MC,NDIG,NDSAVE,1)

      MB(0) = MIN(MB(0),MACCA,MACMAX)

      IF (KOVUN == 2) THEN

          KWRNSV = KWARN

          KWARN = 0

      ENDIF

      CALL FMEXIT(MB,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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



!             Scratch array usage during FMDIM:   M01 - M02



      DOUBLE PRECISION MACCA,MACCB,MACMAX,MXSAVE

      INTEGER 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,0)

      M01(0) = NINT(NDIG*ALOGM2)

      CALL FMEQ2(MB,M02,NDSAVE,NDIG,0)

      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)

      CALL FMEXIT(MC,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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0: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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



      DOUBLE PRECISION MA2,MA2P,MACCA,MACCB,MB1,MB2,MB2P,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

      MA2P = ABS(MA(2))

      MB2P = ABS(MB(2))

      N1 = NDIG + 1

      NG = NDIG + NGUARD



!             Save the sign of MA and MB and then work only with

!             positive numbers.



      MA2 = MA(2)

      MB1 = MB(1)

      MB2 = MB(2)

      IF ((MA2 > 0 .AND. MB2 > 0) .OR. (MA2 < 0 .AND. MB2 < 0)) THEN

          JRSIGN = 1

      ELSE

          JRSIGN = -1

      ENDIF

      MWA(1) = MA(1) - MB(1) + 1

      MA(2) = MA2P

      MB(1) = 0

      MB(2) = MB2P



      IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN

          IF (NDIGL /= NDIG .OR. MBASEL /= MBASE) THEN

              MBASEL = MBASE

              NDIGL = NDIG

              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 + 1 - 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+1

             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+1+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+1+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.



      MA(2) = MA2

      MB(1) = MB1

      MB(2) = MB2

      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



      IF (MA2*MB2 < 0) MC(2) = -MC(2)



      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 FMDIV3(MB,NG)



!  Internal division routine.  Divide MA/MB and return the

!  quotient in MWA.



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MB(0:LUNPCK)



      DOUBLE PRECISION XB,XBR,XBASE,XMWA

      DOUBLE PRECISION 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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK),  &

                       MD(0:LUNPCK),ME(0:LUNPCK)



      DOUBLE PRECISION MA2,MA2P,MACCA,MACCB,MACCC,MAXMWA,MB2,  &

                       MB2P,MBM1,MC1,MC2,MC2P,MCARRY,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.



      MA2 = MA(2)

      MB2 = MB(2)

      MC1 = MC(1)

      MC2 = MC(2)

      MA(2) = MA2P

      MB(2) = MB2P

      MWA(3) = MA(2)

      MWD(3) = MB(2)

      MC(1) = 0

      MC(2) = MC2P



!             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.



      MA(2) = MA2

      MB(2) = MB2

      MC(1) = MC1

      MC(2) = MC2

      IF ((MA2 > 0 .AND. MC2 > 0) .OR. (MA2 < 0 .AND. MC2 < 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 ((MB2 > 0 .AND. MC2 > 0) .OR. (MB2 < 0 .AND. MC2 < 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



      IF (MA2*MC2 < 0) MD(2) = -MD(2)

      IF (MB2*MC2 < 0) ME(2) = -ME(2)



      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER IVAL



!             Scratch array usage during FMDIVI:   M01



      DOUBLE PRECISION 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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER IVAL



!             Scratch array usage during FMDIVN:   M01



      DOUBLE PRECISION MA1,MA2,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(2) = MA(2)*IVAL

          IF (MA(1) == MEXPOV) KFLAG = -5

          IF (MA(1) == MEXPUN) KFLAG = -6

          JRSIGN = JRSSAV

          RETURN

      ENDIF



      IF (MA(1) == MEXPUN) THEN

          MA2 = MA(2)

          CALL FMIM(0,MB)

          MB(1) = MEXPUN

          MB(2) = 1

          MB(0) = NINT(NDIG*ALOGM2)

          IF ((MA2 < 0 .AND. IVAL > 0) .OR.  &

              (MA2 > 0 .AND. IVAL < 0))      MB(2) = -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.



      MA2 = MA(2)

      MA(2) = ABS(MA(2))



!             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.



      MA(2) = MA2

      MLR = 2*MWA(NDIG+2) + 1

      IF ((MA2 > 0 .AND. IVAL > 0) .OR. (MA2 < 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



      IF ((MA2 < 0 .AND. IVAL > 0) .OR. (MA2 > 0 .AND. IVAL < 0))  &

           MB(2) = -MB(2)



      JRSIGN = JRSSAV

      RETURN

      END SUBROUTINE FMDIVN

      SUBROUTINE FMDM(X,MA)



!  Internal routine for converting double precision to multiple

!  precision.  Called by FMDPM.



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION X

      DOUBLE PRECISION MA(0:LUNPCK)



      DOUBLE PRECISION ONE,XBASE,Y,YT

      DOUBLE PRECISION 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(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(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,Y)

         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 IF (X < 0.0) MA(2) = -MA(2)

      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

      DOUBLE PRECISION MA(0:LUNPCK)



!             Scratch array usage during FMDM2:   M01 - M04



      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,MA,KRESLT)

              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(M02,M04,M02)

      JEXP = JEXP + 1

      CALL FMADD(M02,M03,M02)

      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 IF (X < 0.0) MA(2) = -MA(2)

      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 double precision 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

      DOUBLE PRECISION MA(0:LUNPCK)



!             Scratch array usage during FMDP2M:  M01 - M04



      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

      DOUBLE PRECISION MA(0: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(MA,4096,MA)

              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

      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK),MXSAVE

      INTEGER KNAM,NARGS,KRESLT,NDSAVE,KASAVE,KOVUN



      DOUBLE PRECISION 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(MC,2,MC)

              IF (KRESLT >= 14) CALL FMDIVI(MC,4,MC)

              CALL FMEQ2(MC,MC,NDIG,NDSAVE,1)

              NDIG = NDSAVE

              IF (KRESLT == 9 .OR. KRESLT == 14) MC(2) = -MC(2)

              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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



      INTEGER J



      DO J = 0, 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,KSAME)



!  Set MB (having NDB digits) equal to MA (having NDA digits).



!  If MA and MB are the same array, setting KSAME = 1 before calling

!  FMEQ2 gives faster performance.



!  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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER NDA,NDB,KSAME



      DOUBLE PRECISION M2,MACCA,MB2,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



!             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

      IF (KSAME /= 1) THEN

          DO J = 1, N1

             MB(J) = MA(J)

          ENDDO

      ENDIF

      IF (KROUND == -1 .AND. NCALL <= 1) THEN

          IF (MA(2) > 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(2) < 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.



      MB2 = MB(2)

      MB(2) = ABS(MB(2))

      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 (MB2 < 0) MB(2) = -MB(2)

      GO TO 150



!             MA and MB have the same precision.



  130 IF (KSAME /= 1) THEN

          DO J = 1, NDA+1

             MB(J) = MA(J)

          ENDDO

      ENDIF

      GO TO 150



!             Extend to NDB digits by padding with zeros.



  140 IF (KSAME /= 1) THEN

          DO J = 1, NDA+1

             MB(J) = MA(J)

          ENDDO

      ENDIF

      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 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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER NDA,NDB



      CALL FMEQ2(MA,MB,NDA,NDB,0)



      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



      DOUBLE PRECISION MT(0:LUNPCK),MC(0:LUNPCK),MXSAVE

      INTEGER NDSAVE,KASAVE,KOVUN



      INTEGER KFSAVE,KWRNSV



      KWRNSV = KWARN

      KWARN = 0

      MXEXP = MXSAVE

      KFSAVE = KFLAG

      CALL FMEQ2(MT,MC,NDIG,NDSAVE,0)

      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      CHARACTER(155) :: STRING



!             Scratch array usage during FMEXP:   M01 - M03



      DOUBLE PRECISION M1,MA1,MA2,MACCA,MACMAX,MXSAVE

      INTEGER IEXTRA,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)



      MACCA = MA(0)

      CALL FMEQ2(MA,MB,NDSAVE,NDIG,0)

      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 (MA2 > 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(2) = ABS(MB(2))

      CALL FMINT(MB,M02)

      CALL FMSUB(MB,M02,MB)



!             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(MB,MB,NDIG,NDIG+IEXTRA,1)

          ENDIF

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWARN

              NDIG = NDIG - IEXTRA

              CALL FMST2M('UNKNOWN',MB)

              CALL FMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)

              RETURN

          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,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,MB)

          CALL FMIPWR(MESAV,KT,M03)

          CALL FMMPY(MB,M03,MB)

      ELSE IF (MB(2) /= 0 .AND. KT == 0 .AND. NMETHD == 1) THEN

          CALL FMEXP2(MB,MB)

      ELSE IF (MB(2) /= 0 .AND. KT > 0 .AND. NMETHD == 2) THEN

          NDSV = NDIG

          NDIG = MIN(NDIG+NGRD21,NDG2MX)

          CALL FMEQ2(MB,MB,NDSV,NDIG,1)

          IF (MB(1) >= 0) THEN

              CALL FMCSH2(MB,MB)

              CALL FMSQR(MB,M03)

              CALL FMI2M(-1,M02)

              CALL FMADD(M03,M02,M03)

              CALL FMSQRT(M03,M03)

              CALL FMADD(MB,M03,MB)

          ELSE

              CALL FMSNH2(MB,MB)

              CALL FMSQR(MB,M03)

              CALL FMI2M(1,M02)

              CALL FMADD(M03,M02,M03)

              CALL FMSQRT(M03,M03)

              CALL FMADD(MB,M03,MB)

          ENDIF

          NDIG = NDSV

          CALL FMIPWR(MESAV,KT,M03)

          CALL FMMPY(MB,M03,MB)

      ELSE IF (MB(2) /= 0 .AND. KT == 0 .AND. NMETHD == 2) THEN

          NDSV = NDIG

          NDIG = MIN(NDIG+NGRD21,NDG2MX)

          CALL FMEQ2(MB,MB,NDSV,NDIG,1)

          IF (MB(1) >= 0) THEN

              CALL FMCSH2(MB,MB)

              CALL FMSQR(MB,M03)

              CALL FMI2M(-1,M02)

              CALL FMADD(M03,M02,M03)

              CALL FMSQRT(M03,M03)

              CALL FMADD(MB,M03,MB)

          ELSE

              CALL FMSNH2(MB,MB)

              CALL FMSQR(MB,M03)

              CALL FMI2M(1,M02)

              CALL FMADD(M03,M02,M03)

              CALL FMSQRT(M03,M03)

              CALL FMADD(MB,M03,MB)

          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 (MA2 < 0) THEN

          CALL FMI2M(1,M02)

          CALL FMDIV(M02,MB,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)

      CALL FMEXIT(MB,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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMEXP2:   M01 - M03



!             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.



      DOUBLE PRECISION 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

              KFLAG = -9

              CALL FMWARN

              NDIG = NDSAVE

              CALL FMST2M('UNKNOWN',MB)

              RETURN

          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(M02,NBOT,M02)

          IF (NTOP > 1) THEN

              CALL FMMPYI(M02,NTOP,M03)

              NDIG = NDSAV1

              CALL FMADD(MB,M03,MB)

              NDIG = NDSAV1 - INT(MB(1)-M03(1))

          ELSE

              NDIG = NDSAV1

              CALL FMADD(MB,M02,MB)

              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

          KFLAG = -9

          CALL FMWARN

          NDIG = NDSAVE

          CALL FMST2M('UNKNOWN',MB)

          RETURN

      ENDIF

      NDSAV1 = NDIG



!             Halve the argument K2 times.



      CALL FMEQ2(MA,M02,NDSAVE,NDIG,0)

      KTWO = 1

      MAXVAL = MXBASE/2

      IF (K2 > 0) THEN

          DO J = 1, K2

             KTWO = 2*KTWO

             IF (KTWO > MAXVAL) THEN

                 CALL FMDIVI(M02,KTWO,M02)

                 KTWO = 1

             ENDIF

          ENDDO

          IF (KTWO > 1) CALL FMDIVI(M02,KTWO,M02)

      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(MB,NTERM,MB)

         NTERM = NTERM + 1

         KPT = (J-1)*(NDIG+2)

         CALL FMEQ(MB,MJSUMS(KPT))

      ENDDO

      IF (M02(1) < -NDIG) GO TO 150

      CALL FMIPWR(M02,J2,M03)



  140 CALL FMMPY(MB,M03,MB)

      DO J = 1, J2

         CALL FMDIVI(MB,NTERM,MB)

         KPT = (J-1)*(NDSAV1+2)

         NDIG = NDSAV1

         CALL FMADD(MJSUMS(KPT),MB,MJSUMS(KPT))

         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+2)

      CALL FMEQ(MJSUMS(KPT),M03)

      IF (J2 >= 2) THEN

          DO J = 2, J2

             CALL FMMPY(M02,M03,M03)

             KPT = (J2-J)*(NDIG+2)

             CALL FMADD(M03,MJSUMS(KPT),M03)

          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(MB,M03,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(MB,MB,NDSAV1,NDSAVE,1)

      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

      DOUBLE PRECISION MA(0:LUNPCK)



!             Scratch array usage during FMFORM:   M01 - M02



      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

      DOUBLE PRECISION MA(0:LUNPCK)



!             Scratch array usage during FMFPRT:   M01 - M02



      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



      DOUBLE PRECISION MA(0: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



      DOUBLE PRECISION MA(0:LUNPCK)

      INTEGER IVAL



      DOUBLE PRECISION X

      DOUBLE PRECISION 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

          MA(2) = IVAL

          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



      IF (IVAL < 0) MA(2) = -MA(2)



  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



      DOUBLE PRECISION MA(0:LUNPCK)

      INTEGER IVAL



      DOUBLE PRECISION X

      DOUBLE PRECISION 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

          MA(2) = IVAL

          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



      IF (IVAL < 0) MA(2) = -MA(2)



  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)

      DOUBLE PRECISION MA(0:LUNPCK)



      DOUBLE PRECISION MLV2(0:LUNPCK),MLV3(0:LUNPCK),MLV4(0:LUNPCK),  &

                       MLV5(0:LUNPCK)



      DOUBLE PRECISION 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) = 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) = 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 IF (NCALL <= 2) THEN

          K = NGRD52

          NDIG = MAX(NDIG+K,2)

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              NCALL = NCALL - 1

              CALL FMWARN

              NCALL = NCALL + 1

              MA(1) = MUNKNO

              MA(2) = 1

              MA(0) = NINT(NDSAVE*ALOGM2)

              DO J = 2, NDSAVE

                 MA(J+1) = 0

              ENDDO

              GO TO 150

          ENDIF

      ENDIF

      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,  &

                      MLV3,MLV4,MLV5)

          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(MLV3,MA,MLV3)

                     NDIG = NDSAV1

                     CALL FMIM(KF1,MLV2)

                     NDIG = INT(MAX(M2,MIN(MAX(MLV3(1),MLV2(1))+1,MNDSV1)))

                     IF (KF1 /= 0) CALL FMADD2(MLV3,MLV2,MLV3)

                     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(MLV4,MA,MLV4)

                     NDIG = NDSAV1

                     CALL FMIM(KF2,MLV2)

                     NDIG = INT(MAX(M2,MIN(MAX(MLV4(1),MLV2(1))+1,MNDSV1)))

                     IF (KF2 /= 0) CALL FMADD2(MLV4,MLV2,MLV4)

                     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(MLV5,MA,MLV5)

                     NDIG = NDSAV1

                     CALL FMIM(KEXP,MLV2)

                     NDIG = INT(MAX(M2,MIN(MAX(MLV5(1),MLV2(1))+1,MNDSV1)))

                     IF (KEXP /= 0) CALL FMADD2(MLV5,MLV2,MLV5)

                     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(MLV3,MA,MLV3)

              NDIG = NDSAV1

              CALL FMIM(KF1,MLV2)

              NDIG = INT(MAX(M2,MIN(MAX(MLV3(1),MLV2(1))+1,MNDSV1)))

              IF (KF1 /= 0) CALL FMADD2(MLV3,MLV2,MLV3)

              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(MLV4,MA,MLV4)

              NDIG = NDSAV1

              CALL FMIM(KF2,MLV2)

              NDIG = INT(MAX(M2,MIN(MAX(MLV4(1),MLV2(1))+1,MNDSV1)))

              IF (KF2 /= 0) CALL FMADD2(MLV4,MLV2,MLV4)

              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(MLV5,MA,MLV5)

              NDIG = NDSAV1

              CALL FMIM(KEXP,MLV2)

              NDIG = INT(MAX(M2,MIN(MAX(MLV5(1),MLV2(1))+1,MNDSV1)))

              IF (KEXP /= 0) CALL FMADD2(MLV5,MLV2,MLV5)

              NDIG = NDSAV1

          ENDIF

      ENDIF



      IF (KSIGNX == -1) MLV5(2) = -MLV5(2)

      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 FMMPY2(MLV2,MLV2,MLV2)

          IF (MOD(K,2) == 1) THEN

              NDIG = INT(MAX(M2,MIN(MLV2(1)+MA(1),MNDSV1)))

              CALL FMMPY2(MLV2,MA,MA)

          ENDIF

          IF (K > 1) GO TO 120

          NDIG = NDSAV1

          CALL FMDIV2(MLV4,MA,MLV4)

      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 FMMPY2(MLV2,MLV2,MLV2)

          IF (MOD(K,2) == 1) THEN

              NDIG = INT(MAX(M2,MIN(MLV2(1)+MLV5(1),MNDSV1)))

              CALL FMMPY2(MLV2,MLV5,MLV5)

          ENDIF

          IF (K > 1) GO TO 130

          NDIG = NDSAV1

          IF (KEXP < 0) THEN

              CALL FMIM(1,MLV2)

              CALL FMDIV2(MLV2,MLV5,MLV5)

          ENDIF

      ENDIF

      CALL FMADD2(MLV3,MLV4,MA)

      IF (MLV5(2) /= 0) CALL FMMPY2(MA,MLV5,MA)

      IF (KSIGN == -1) MA(2) = -MA(2)

  140 CALL FMEQ2(MA,MA,NDIG,NDSAVE,1)

      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)

      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,  &

                        MLV3,MLV4,MLV5)



!  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)

      DOUBLE PRECISION MA(0:LUNPCK)

      DOUBLE PRECISION MLV3(0:LUNPCK),MLV4(0:LUNPCK),MLV5(0: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) = 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(MLV3,KSHIFT,MLV3)

          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(MA,MLV5,MA)

      MA(2) = KSIGN*MA(2)



      RETURN



!             Error in converting the number.



  110 CALL FMIM(0,MA)

      MA(1) = MUNKNO

      MA(2) = 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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



      DOUBLE PRECISION 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

      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER IVAL



!             Scratch array usage during FMIPWR:   M01



      DOUBLE PRECISION 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(2) < 0) JSIGN = -1

          CALL FMIM(0,MB)

          IF (IVAL > 0) THEN

              CALL FMST2M('OVERFLOW',MB)

              MB(2) = JSIGN**MOD(IVAL,2)

              KFLAG = -5

          ELSE

              CALL FMST2M('UNDERFLOW',MB)

              MB(2) = 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(2) < 0) JSIGN = -1

          CALL FMIM(0,MB)

          IF (IVAL > 0) THEN

              CALL FMST2M('UNDERFLOW',MB)

              MB(2) = JSIGN**MOD(IVAL,2)

              KFLAG = -6

          ELSE

              CALL FMST2M('OVERFLOW',MB)

              MB(2) = 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

          KFLAG = -9

          CALL FMWARN

          NDIG = NDSAVE

          CALL FMST2M('UNKNOWN',MB)

          IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)

          NCALL = NCALL - 1

          RETURN

      ENDIF



!             Initialize.



      K = ABS(IVAL)

      KWRNSV = KWARN

      KWARN = 0

      MACCA = MA(0)

      CALL FMEQ2(MA,M01,NDSAVE,NDIG,0)

      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(MB,M01,MB)

          GO TO 120

      ENDIF

      IF (K == 4) THEN

          CALL FMSQR(M01,MB)

          CALL FMSQR(MB,MB)

          GO TO 120

      ENDIF

      IF (K == 5) THEN

          CALL FMSQR(M01,MB)

          CALL FMSQR(MB,MB)

          CALL FMMPY(MB,M01,MB)

          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(M01,M01)

      IF (MOD(K,2) == 1) CALL FMMPY(M01,MB,MB)

      IF (K > 1) GO TO 110



!             Invert if the exponent is negative.



  120 IF (IVAL < 0) THEN

          CALL FMI2M(1,M01)

          CALL FMDIV(M01,MB,MB)

      ENDIF

      KWARN = KWRNSV



!             Round the result and return.



      CALL FMEQ2(MB,MB,NDIG,NDSAVE,1)

      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMLG10:   M01 - M05



      DOUBLE PRECISION MACCA,MACMAX,MXSAVE

      INTEGER K,KASAVE,KOVUN,KRESLT,NDSAVE



      IF (MBLOGS /= MBASE) CALL FMCONS

      IF (ABS(MA(1)) > MEXPAB .OR. MA(2) <= 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,0)

      MB(0) = NINT(NDIG*ALOGM2)



      CALL FMLN(MB,MB)

      IF (MBASE /= MBSLI .OR. NDIG > NDIGLI) THEN

          CALL FMLNI(10,M03)

      ELSE

          CALL FMADD(MLN1,MLN3,M03)

      ENDIF

      CALL FMDIV(MB,M03,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)

      CALL FMEXIT(MB,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

      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER NSTACK(19)



!             Scratch array usage during FMLN:   M01 - M05



      DOUBLE PRECISION 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) 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,0)

          M03(0) = NINT(NDIG*ALOGM2)



          CALL FMI2M(-1,M01)

          CALL FMADD(M03,M01,M03)



!             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(M02,MB,M02)

          CALL FMDIVI(M02,KBOT,M01)

          NDIG = NDSAV1

          CALL FMADD(M04,M01,M04)

          NDIG = MAX(2,NDSAV1 - INT(M04(1)-M01(1)))

          KBOT = KBOT + 1

          CALL FMDIVI(M02,KBOT,M01)

          NDIG = NDSAV1

          CALL FMADD(M05,M01,M05)

          NDIG = MAX(2,NDSAV1 - INT(M04(1)-M01(1)))

          IF (KFLAG /= 1) GO TO 110



          NDIG = NDSAV1

          CALL FMMPY(M05,M03,M05)

          CALL FMSUB(M04,M05,MB)

          GO TO 140

      ENDIF



      MA1 = MA(1)

      MACCA = MA(0)

      CALL FMEQ2(MA,M05,NDSAVE,NDIG,0)

      M05(0) = NINT(NDIG*ALOGM2)



!             Compute IEXTRA, the number of extra digits required.



      CALL FMI2M(1,M04)

      CALL FMSUB(M04,M05,M04)

      IEXTRA = MAX(0-INT(M04(1)),0)

      IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN

          CALL FMEQ2(M05,M05,NDIG,NDIG+IEXTRA,1)

      ENDIF

      NDIG = NDIG + IEXTRA

      IF (NDIG > NDG2MX) THEN

          KFLAG = -9

          CALL FMWARN

          NDIG = NDSAVE

          CALL FMST2M('UNKNOWN',MB)

          CALL FMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)

          RETURN

      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 FMADD(M05,M05,M05)

          Y = 2.0D0*Y

      ELSE

          K2 = 2**K2EXP

          CALL FMDIVI(M05,K2,M05)

          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(M02,MB,MB)

         CALL FMADD(M04,MB,M04)

      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(M04,MB,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(MB,M04,MB)

      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)

      CALL FMEXIT(MB,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



      DOUBLE PRECISION MA(0:LUNPCK)

      INTEGER IVAL



!             Scratch array usage during FMLNI:   M01 - M03



      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(MLN1,-72,MLN1)

              CALL FMMPYI(MLN2,-27,MA)

              CALL FMADD(MLN1,MA,MLN1)

              CALL FMMPYI(MLN3,19,MA)

              CALL FMADD(MLN1,MA,MLN1)

              CALL FMMPYI(MLN4,-31,MA)

              CALL FMADD(MLN1,MA,MLN1)



!                Get Ln(3).



              CALL FMMPYI(MLN2,-3,MLN2)

              CALL FMMPYI(MLN1,19,MA)

              CALL FMADD(MLN2,MA,MLN2)

              CALL FMSUB(MLN2,MLN3,MLN2)

              CALL FMADD(MLN2,MLN4,MLN2)

              CALL FMDIVI(MLN2,12,MLN2)



!                Get Ln(5).



              CALL FMSUB(MLN3,MLN1,MLN3)

              CALL FMMPYI(MLN2,27,MA)

              CALL FMADD(MLN3,MA,MLN3)

              CALL FMMPYI(MLN4,-4,MA)

              CALL FMADD(MLN3,MA,MLN3)

              CALL FMDIVI(MLN3,18,MLN3)



!                Get Ln(7).



              CALL FMSUB(MLN1,MLN4,MLN4)

              CALL FMMPYI(MLN2,7,MA)

              CALL FMADD(MLN4,MA,MLN4)

              CALL FMMPYI(MLN3,-4,MA)

              CALL FMADD(MLN4,MA,MLN4)

          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(M02,M01,M02)

      CALL FMMPYI(MLN3,K5,M01)

      CALL FMADD(M02,M01,M02)

      CALL FMMPYI(MLN4,K7,M01)

      IF (NT /= IVAL) CALL FMADD(M02,MA,M02)

      CALL FMADD(M02,M01,MA)



!             Round and move the result to MA.



      KACCSW = KASAVE

      CALL FMEQ2(MA,MA,NDIG,NDSAVE,1)

      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

      DOUBLE PRECISION MA(0:LUNPCK)



!             Scratch array usage during FMLNI2:   M01 - M02



      INTEGER J,NDSAVE



      CALL FMI2M(INT1,M02)

      CALL FMDIVI(M02,INT2,M02)

      CALL FMEQ(M02,MA)

      NDSAVE = NDIG

      J = 1



  110 J = J + 1

      IF (INT1 /= 1) CALL FMMPYI(M02,INT1,M02)

      CALL FMDIVI(M02,INT2,M02)

      CALL FMDIVI(M02,J,M01)

      NDIG = NDSAVE

      CALL FMADD(MA,M01,MA)

      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)

      MA(2) = -MA(2)

      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



      DOUBLE PRECISION MA(0: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



      DOUBLE PRECISION MA(0: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



      DOUBLE PRECISION MA(0: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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0: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



      DOUBLE PRECISION MA(0:LUNPCK)

      DOUBLE PRECISION X



      DOUBLE PRECISION Y,YT,XBASE,RZERO,ONE,PMAX,DLOGDP

      DOUBLE PRECISION MA1,MA2

      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

          MA(1) = MA(1) - 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

          MA(1) = MA(1) + 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



      MA2 = MA(2)

      MA(2) = ABS(MA2)

      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**MA(1)

      IF (MA2 < 0) X = -X

      MA(2) = MA2



!             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

      MA(1) = MA1

      RETURN

      END SUBROUTINE FMMD

      SUBROUTINE FMMI(MA,IVAL)



!  IVAL = MA.  Internal FM to integer conversion routine.



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0: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(2) < 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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0: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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



!             Scratch array usage during FMMOD:   M01 - M03



      DOUBLE PRECISION 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,0)

          M01(0) = NINT(NDIG*ALOGM2)

      ELSE



!             Special cases when MB is a small integer.



          CALL FMEQ2(MA,M02,NDSAVE,NDIG,0)

          M02(0) = NINT(NDIG*ALOGM2)

          CALL FMEQ2(MB,M03,NDSAVE,NDIG,0)

          M03(0) = NINT(NDIG*ALOGM2)



          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)

                      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)

              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,0)

          M02(0) = NINT(NDIG*ALOGM2)

          CALL FMEQ2(MB,M03,NDSAVE,NDIG,0)

          M03(0) = NINT(NDIG*ALOGM2)



          M02(2) = ABS(M02(2))

          M03(2) = ABS(M03(2))

          CALL FMDIV(M02,M03,M01)

          CALL FMINT(M01,M01)

          CALL FMMPY(M01,M03,M01)

          CALL FMSUB(M02,M01,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(M01,M03,M01)

          ENDIF

          NTRACE = NTRSAV

          IF (M01(2) < 0) CALL FMADD(M01,M03,M01)

          IF (MA(2) < 0 .AND. M01(1) /= MUNKNO) M01(2) = -M01(2)

      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



      DOUBLE PRECISION MA(0: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



      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0: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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



      DOUBLE PRECISION MA2,MACCA,MACCB,MB2,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.



      MA2 = MA(2)

      MB2 = MB(2)

      MA(2) = ABS(MA(2))

      MB(2) = ABS(MB(2))



!             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) THEN

              MBASEL = MBASE

              NDIGL = NDIG

              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 + 1 - 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+1)

                    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+1)

                    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.



      MA(2) = MA2

      MB(2) = MB2

      IF ((MA2 > 0 .AND. MB2 > 0) .OR. (MA2 < 0 .AND. MB2 < 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



      IF (MA2*MB2 < 0) MC(2) = -MC(2)



      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 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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER NGUARD,KSHIFT



      DOUBLE PRECISION 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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK),  &

                       MD(0:LUNPCK),ME(0:LUNPCK)



      DOUBLE PRECISION MA2,MACCA,MACCB,MACCC,MAXMWA,MB2,MBJ,MBKJ,  &

                       MBM1,MBNORM,MC2,MCJ,MCKJ,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.



      MA2 = MA(2)

      MB2 = MB(2)

      MC2 = MC(2)

      MA(2) = ABS(MA(2))

      MB(2) = ABS(MB(2))

      MC(2) = ABS(MC(2))



      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.



      MA(2) = MA2

      MB(2) = MB2

      MC(2) = MC2

      IF ((MA2 > 0 .AND. MB2 > 0) .OR. (MA2 < 0 .AND. MB2 < 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 ((MA2 > 0 .AND. MC2 > 0) .OR. (MA2 < 0 .AND. MC2 < 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



      IF (MA2*MB2 < 0) MD(2) = -MD(2)

      IF (MA2*MC2 < 0) ME(2) = -ME(2)



      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK),  &

                       MD(0:LUNPCK),ME(0:LUNPCK),MF(0:LUNPCK),  &

                       MG(0:LUNPCK)



      DOUBLE PRECISION MA2,MACCA,MACCB,MACCC,MACCD,MAXJ,MAXMWA,MB2,MBJ,  &

                       MBKJ,MBM1,MBNORM,MC2,MCJ,MCKJ,MD2,MD2B,MDJ,MDKJ,  &

                       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.



      MA2 = MA(2)

      MB2 = MB(2)

      MC2 = MC(2)

      MD2 = MD(2)

      MA(2) = ABS(MA(2))

      MB(2) = ABS(MB(2))

      MC(2) = ABS(MC(2))

      MD(2) = ABS(MD(2))



      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.



      MA(2) = MA2

      MB(2) = MB2

      MC(2) = MC2

      MD(2) = MD2

      IF ((MA2 > 0 .AND. MB2 > 0) .OR. (MA2 < 0 .AND. MB2 < 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 ((MA2 > 0 .AND. MC2 > 0) .OR. (MA2 < 0 .AND. MC2 < 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 ((MA2 > 0 .AND. MD2 > 0) .OR. (MA2 < 0 .AND. MD2 < 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



      IF (MA2*MB2 < 0) ME(2) = -ME(2)

      IF (MA2*MC2 < 0) MF(2) = -MF(2)

      IF (MA2*MD2 < 0) MG(2) = -MG(2)



      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER IVAL



!             Scratch array usage during FMMPYI:   M01



      DOUBLE PRECISION MA2,MACCA,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 = 0, N1

             MB(J) = MA(J)

          ENDDO

          IF (MA(1) == MEXPOV) KFLAG = -5

          IF (MA(1) == MEXPUN) KFLAG = -6

          MB(2) = MA(2)*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

          MA2 = MA(2)

          KFLAG = -5

          CALL FMST2M('OVERFLOW',MB)

          IF ((MA2 < 0 .AND. IVAL > 0) .OR.  &

              (MA2 > 0 .AND. IVAL < 0))      MB(2) = -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 MA2 = MA(2)

      MA(2) = ABS(MA(2))

      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)

          MA(2) = MA2

          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.



      MA(2) = MA2

      IF ((MA2 > 0 .AND. IVAL > 0) .OR. (MA2 < 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.



      IF ((IVAL > 0 .AND. MA2 < 0) .OR. (IVAL < 0 .AND.MA2 > 0))  &

           MB(2) = -MB(2)



      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 FMNINT(MA,MB)



!  MB = NINT(MA)  --  MB is returned as the nearest integer to MA.



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMNINT:   M01



      DOUBLE PRECISION MA2,MXSAVE

      INTEGER 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,0)

      IF (NDSAVE > INT(MA(1))) THEN

          MA2 = MA(2)

          MB(2) = ABS(MB(2))

          CALL FMI2M(1,M01)

          CALL FMDIVI(M01,2,M01)

          CALL FMADD(MB,M01,MB)

          CALL FMINT(MB,MB)

          IF (MA2 < 0) MB(2) = -MB(2)

      ENDIF

      KWARN = KWRNSV



!             Round the result and return.



      CALL FMEXIT(MB,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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0: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



      DOUBLE PRECISION MA(0: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(J)),J=1,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



      DOUBLE PRECISION MA(0:LUNPCK)

      INTEGER LB

      CHARACTER LINE(LB)



      CHARACTER KCHAR

      DOUBLE PRECISION MD(0:LUNPCK),MT(0:LUNPCK),MS(0:LUNPCK)

      DOUBLE PRECISION 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(2) < 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(2) < 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,MS)

          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,MS,NDSAVE,NDIG,0)

             MS(2) = ABS(MS(2))

             GO TO 130

         ENDIF

      ENDDO



      IF (MBLOGS /= MBASE) CALL FMCONS

      CALL FMIM(INT(MBSAVE),MD)

      NDS2 = NDSAVE + 1

      CALL FMIM(1,MT)

      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,MS)

      NDIGMS = NDIG



      DO J = 3, KPT

         KDIGIT = INT(MA(J))

         IF (MBSAVE == 2) THEN

             NDIG = MIN(NDIGMS,MAX(2,INT(MS(1))+1))

             CALL FMADD2(MS,MS,MS)

         ELSE

             NDIG = MIN(NDIGMS,MAX(2,INT(MS(1)+MD(1))))

             CALL FMMPY2(MS,MD,MS)

         ENDIF



         IF (KDIGIT > 0) THEN

             IF (KMT /= KDIGIT) THEN

                 NDIG = MIN(NDIGMS,MAX(2,INT(MD(1))))

                 CALL FMIM(KDIGIT,MT)

                 KMT = KDIGIT

             ENDIF

             NDIG = MIN(NDIGMS,MAX(2,INT(MAX(MS(1),MT(1)))+1))

             CALL FMADD2(MS,MT,MS)

         ENDIF

      ENDDO



!             Convert the exponent.



      NDIG = NDIGMS

      CALL FMIM(1,MT)

      K = ABS(INT(MA(1))-KEXPSH)

      IF (MOD(K,2) == 1) THEN

          CALL FMEQ(MD,MT)

      ELSE

          CALL FMIM(1,MT)

      ENDIF



  120 K = K/2

      M2 = 2

      MNDGMS = NDIGMS

      NDIG = INT(MIN(MNDGMS,MAX(M2,MD(1)*M2)))

      IF (K > 0) CALL FMMPY2(MD,MD,MD)

      IF (MOD(K,2) == 1) THEN

          NDIG = INT(MIN(MNDGMS,MAX(M2,MT(1)+MD(1))))

          CALL FMMPY2(MT,MD,MT)

      ENDIF

      IF (K > 1) GO TO 120



      NDIG = NDIGMS

      IF (MA(1)-KEXPSH < 0) THEN

          CALL FMDIV2(MS,MT,MS)

      ELSE

          CALL FMMPY2(MS,MT,MS)

      ENDIF



!             Now MS 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 MS(2).



  130 MS1 = MS(1)

  140 MEXP10 = NPOWER*MS(1)

      KMS2SD = NPOWER

      K = INT(MBASE)

      DO J = 1, NPOWER

         K = K/10

         IF (MS(2) < K .AND. MS(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. MS(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(MS(NWORD)),NVAL)

          IF (NWORD < NDIG+1) THEN

              X = REAL(DBLE(X) + DBLE(MS(NWORD+1))/DBLE(MBASE))

          ENDIF

          X = X/NVAL

          IF (X < 0.5) GO TO 150

          MS2 = MS(2)

          MS(NWORD) = INT(MS(NWORD)/NVAL)*NVAL

          MS(NWORD+1) = 0

          MS(NWORD+2) = 0

          MS(NWORD) = MS(NWORD) + NVAL

          IF (MS(NWORD) >= MBASE) THEN

              NWORD1 = NWORD - 1

              NWORD2 = NWORD - 2

              IF (NWORD > 2) THEN

                  CALL FMEQ2(MS,MS,NWORD1,NWORD2,1)

              ELSE

                  MS(1) = MS(1) + 1

                  MS(2) = INT(MS(2)/MBASE)

                  MS(3) = 0

              ENDIF

          ENDIF

          IF (MS(1) /= MS1 .OR. MS(2) /= MS2) GO TO 140

      ENDIF



!             Build the base 10 character string.



  150 IF (MA(2) < 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(MS(L))/K

         MS(L) = MOD(INT(MS(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



      DOUBLE PRECISION MA(0:LUNPCK),MP(0:LPACK)



      INTEGER J,KP



      KP = 2

      MP(0) = MA(0)

      MP(1) = MA(1)

      MP(2) = ABS(MA(2))*MBASE + MA(3)

      IF (MA(2) < 0) MP(2) = -MP(2)

      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



      DOUBLE PRECISION MA(0:LUNPCK)



!             Scratch array usage during FMPI:   M01 - M04



      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,0)

          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,0)

          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



      DOUBLE PRECISION MPI(0:LUNPCK)



!             Scratch array usage during FMPI2:   M01 - M04



      DOUBLE PRECISION X

      DOUBLE PRECISION 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(M02,J,M02)

          J = J + 1

          CALL FMMPYI(M02,J,M02)

          J = J + 1

          CALL FMMPYI(M02,J,M02)

      ELSE IF (J*(J+1) > LARGE) THEN

          K = J*(J+1)

          CALL FMMPYI(M02,K,M02)

          J = J + 2

          CALL FMMPYI(M02,J,M02)

      ELSE

          K = J*(J+1)*(J+2)

          CALL FMMPYI(M02,K,M02)

      ENDIF



      J = N + 1

      LARGE = INT(MXBASE)/J

      IF (J > LARGE) THEN

          CALL FMDIVI(M02,J,M02)

          CALL FMDIVI(M02,J,M02)

          CALL FMDIVI(M02,J,M02)

      ELSE IF (J*J > LARGE) THEN

          K = J*J

          CALL FMDIVI(M02,K,M02)

          CALL FMDIVI(M02,J,M02)

      ELSE

          K = J*J*J

          CALL FMDIVI(M02,K,M02)

      ENDIF



!             Break 4/396**4 into 1/(2178*2178*1296).



      J = 2178

      LARGE = INT(MXBASE)/J

      IF (J > LARGE) THEN

          CALL FMDIVI(M02,J,M02)

          CALL FMDIVI(M02,J,M02)

          CALL FMDIVI(M02,1296,M02)

      ELSE

          K = J*J

          CALL FMDIVI(M02,K,M02)

          CALL FMDIVI(M02,1296,M02)

      ENDIF



      NDIGRD = NDIG

      NDIG = NDSAVE

      CALL FMADD(M03,M04,M04)

      NDIG = NDIGRD

      CALL FMMPY(M02,M04,M01)



      NDIG = NDSAVE

      CALL FMADD(MPI,M01,MPI)

      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(M04,M01,M04)

         CALL FMDIVI(M04,2,M04)

      ENDDO

      M04(0) = NINT(NDIG*ALOGM2)

      CALL FMI2M(9801,M03)

      CALL FMMPY(MPI,M04,MPI)

      CALL FMDIV(M03,MPI,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



      DOUBLE PRECISION MA(0: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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



!             Scratch array usage during FMPWR:   M01 - M06



      DOUBLE PRECISION MACCA,MACCB,MACMAX,MXSAVE

      INTEGER IEXTRA,INTMB,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) 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

          KFLAG = -9

          CALL FMWARN

          NDIG = NDSAVE

          CALL FMST2M('UNKNOWN',MC)

          CALL FMEXIT(MC,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)

          RETURN

      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,0)

      M06(0) = NINT(NDIG*ALOGM2)



      IF (KFL == 0) THEN

          CALL FMIPWR(M06,INTMB,MC)

      ELSE IF (M06(2) <= 0) THEN

          CALL FMST2M('UNKNOWN',MC)

          KFLAG = -4

      ELSE

          CALL FMLN(M06,M06)

          MACCB = MB(0)

          CALL FMEQ2(MB,M02,NDSAVE,NDIG,0)

          M02(0) = NINT(NDIG*ALOGM2)

          CALL FMMPY(M06,M02,M06)

          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)

      CALL FMEXIT(MC,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 MRNA(0:LUNPCK),MRNM(0:LUNPCK),MRNC(0:LUNPCK),MSAVE

      SAVE MRNA,MRNM,MRNC

      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,MRNX)

             CALL IMADD(MRNX,MRNC,MRNX)

             CALL IMMOD(MRNX,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,MRNX)

          CALL IMADD(MRNX,MRNC,MRNX)

          CALL IMMOD(MRNX,MRNM,MRNX)

          CALL IMM2DP(MRNX,DPX)

          Y = DPX*DPM

      ENDIF



!             Get the next number in the sequence.



  120 CALL IMMPYM(MRNA,MRNX,MRNM,MRNX)

      POS_OF_LAST_DIGIT = INT(MRNX(1)) + 1

      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,MRNX)

          IF (IMCOMP(MRNX,'GE',MRNM)) CALL IMSUB(MRNX,MRNM,MRNX)

      ELSE IF (LAST_DIGIT_OF_X < JBASE) THEN

          MRNX(POS_OF_LAST_DIGIT) = MRNX(POS_OF_LAST_DIGIT) + 1

      ELSE

          CALL IMADD(MRNX,MRNC,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,MB,JSIN,JCOS,JSWAP)



!  Reduce MA using various trigonometric identities to an equivalent

!  angle MB 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(MB)

!                    COS(MA) = JCOS*COS(MB)



!  JSWAP = 1 means   SIN(MA) = JSIN*COS(MB)

!                    COS(MA) = JCOS*SIN(MB)



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER JSIN,JCOS,JSWAP



!             Scratch array usage during FMRDC:   M01 - M04



      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',MB)

          RETURN

      ENDIF

      MA(0) = 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

          CALL FMEQ(MA,MB)

          IF (MB(2) < 0) THEN

              MB(2) = -MB(2)

              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,0)

          IF (MA(2) < 0) JSIN = -1

          M04(2) = ABS(M04(2))

          IF (M04(1) == 0) THEN

              CALL FMM2DP(M04,X)

              IF (X <= 0.75) THEN

                  NDIG = NDSAVE

                  CALL FMEQ(M04,MB)

                  RETURN

              ENDIF

          ENDIF

          CALL FMADD(MPISAV,MPISAV,M02)

          IF (FMCOMP(M04,'GE',M02)) THEN

              CALL FMDIV(M04,M02,M01)

              CALL FMINT(M01,M01)

              CALL FMMPY(M01,M02,M01)

              CALL FMSUB(M04,M01,M04)

          ENDIF

          CALL FMEQ(MPISAV,M03)

          IF (FMCOMP(M04,'GE',M03)) THEN

              JSIN = -JSIN

              CALL FMSUB(M02,M04,M04)

          ENDIF

          CALL FMDIVI(M02,4,M02)

          IF (FMCOMP(M04,'GE',M02)) THEN

              JCOS = -JCOS

              CALL FMSUB(M03,M04,M04)

          ENDIF

          CALL FMDIVI(M03,4,M03)

          IF (FMCOMP(M04,'GE',M03)) THEN

              JSWAP = 1

              CALL FMSUB(M02,M04,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',MB)

                  RETURN

              ENDIF

              JSIN = 1

              JCOS = 1

              JSWAP = 0

              MA(0) = MA(0) + NINT(ALOGM2*REAL(-M04(1)))

              GO TO 110

          ENDIF



      ELSE



          CALL FMEQ2(MA,M04,NDSAVE,NDIG,0)

          IF (MA(2) < 0) JSIN = -1

          M04(2) = ABS(M04(2))

          IF (M04(1) == 0) THEN

              CALL FMM2DP(M04,X)

              IF (X <= 44.0) THEN

                  NDIG = NDSAVE

                  CALL FMEQ(M04,MB)

                  RETURN

              ENDIF

          ENDIF

          CALL FMI2M(360,M02)

          IF (FMCOMP(M04,'GE',M02)) THEN

              CALL FMDIV(M04,M02,M01)

              CALL FMINT(M01,M01)

              CALL FMMPY(M01,M02,M01)

              CALL FMSUB(M04,M01,M04)

          ENDIF

          CALL FMI2M(180,M03)

          IF (FMCOMP(M04,'GE',M03)) THEN

              JSIN = -JSIN

              CALL FMSUB(M02,M04,M04)

          ENDIF

          CALL FMI2M(90,M02)

          IF (FMCOMP(M04,'GE',M02)) THEN

              JCOS = -JCOS

              CALL FMSUB(M03,M04,M04)

          ENDIF

          CALL FMI2M(45,M03)

          IF (FMCOMP(M04,'GE',M03)) THEN

              JSWAP = 1

              CALL FMSUB(M02,M04,M04)

          ENDIF



      ENDIF



!             Round the result and return.



      CALL FMEQ2(M04,MB,NDIG,NDSAVE,0)

      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



      DOUBLE PRECISION MA(0: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,0)

      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



      DOUBLE PRECISION MW(LMWA)

      INTEGER ND,NGUARD,KSHIFT



      DOUBLE PRECISION 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

                  RETURN

              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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER IVAL,JVAL



!             Scratch array usage during FMRPWR:   M01 - M03



      DOUBLE PRECISION X,F

      DOUBLE PRECISION MA1,MA2,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))

          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))

          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



      MA1 = MA(1)

      MA2 = MA(2)

      MACCA = MA(0)

      CALL FMEQ2(MA,M02,NDSAVE,NDIG,0)

      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 (MA2 < 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. MA2 > 0) THEN

              CALL FMST2M('OVERFLOW',MB)

              KFLAG = -5

          ELSE IF (IJSIGN == -1 .AND. MA2 > 0) THEN

              CALL FMST2M('UNDERFLOW',MB)

              KFLAG = -6

          ELSE IF (IJSIGN == 1 .AND. MA2 < 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. MA2 < 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. MA2 > 0) THEN

              CALL FMST2M('UNDERFLOW',MB)

              KFLAG = -6

          ELSE IF (IJSIGN == -1 .AND. MA2 > 0) THEN

              CALL FMST2M('OVERFLOW',MB)

              KFLAG = -5

          ELSE IF (IJSIGN == 1 .AND. MA2 < 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. MA2 < 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(M01,M02,M02)

          ENDIF

      ENDIF



!             Generate the first approximation to ABS(MA)**(1/JVAL2).



      MA1 = M02(1)

      M02(1) = 0

      M02(2) = ABS(M02(2))

      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(M02,M03,M03)

         CALL FMMPYI(MB,LVAL,MB)

         CALL FMADD(MB,M03,MB)

         CALL FMDIVI(MB,JVAL2,MB)

      ENDDO



      IF (MB(1) /= MUNKNO .AND. MA2 < 0) MB(2) = -MB(2)

      CALL FMIPWR(MB,IJSIGN*IVAL2,MB)

      IF (INVERT == 1) THEN

          CALL FMI2M(1,M01)

          CALL FMDIV(M01,MB,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

      CALL FMEXIT(MB,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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)

      INTEGER KRESLT



      DOUBLE PRECISION 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

              MC(2) = -MC(2)

              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(2) = -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(2) = -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(20) :: STRING

      CHARACTER(6) :: VARNAME

      INTEGER IVAL,J,KPTEQ,KPT1,KPT2

      DOUBLE PRECISION DVAL

      DOUBLE PRECISION 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

      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0: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(2) >= 0) THEN

          CALL FMEQ(MA,MC)

          MC(2) = ABS(MC(2))

      ELSE

          CALL FMEQ(MA,MC)

          MC(2) = -ABS(MC(2))

      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMSIN:   M01 - M04



      DOUBLE PRECISION MA2,MACCA,MACMAX,MXSAVE

      INTEGER 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)

      MA2 = MA(2)

      CALL FMEQ2(MA,MB,NDSAVE,NDIG,0)

      MB(0) = NINT(NDIG*ALOGM2)

      MB(2) = ABS(MB(2))

      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,MB,JSIN,JCOS,JSWAP)

      KWARN = KWRNSV

      IF (MB(1) == MUNKNO) THEN

          IF (KRAD /= 1 .OR. JSWAP == 0) THEN

              CALL FMRDC(MWE,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(M04,2,M04)

          CALL FMNINT(M04,M03)

          CALL FMMPY(M03,MPISAV,M02)

          CALL FMDIVI(M02,2,M02)

          CALL FMSUB(MWE,M02,M02)

          IF (M02(2) == 0) CALL FMULP(MWE,M02)

          CALL FMI2M(1,M04)

          CALL FMSQR(M02,M02)

          CALL FMDIVI(M02,2,M02)

          CALL FMSUB(M04,M02,M02)

          CALL FMSUB(M02,M04,M02)

          IF (M02(2) == 0) THEN

              CALL FMI2M(JSIN,MB)

          ELSE

              CALL FMRDC(MWE,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(MB,MPISAV,MB)

          CALL FMDIVI(MB,180,MB)

      ENDIF

      IF (MB(1) /= MUNKNO) THEN

          IF (JSWAP == 0) THEN

              IF (MB(1) < 0 .OR. NDIG <= 50) THEN

                  CALL FMSIN2(MB,MB)

              ELSE

                  CALL FMCOS2(MB,MB)

                  CALL FMI2M(1,M03)

                  CALL FMSQR(MB,MB)

                  CALL FMSUB(M03,MB,MB)

                  CALL FMSQRT(MB,MB)

              ENDIF

          ELSE

              CALL FMCOS2(MB,MB)

          ENDIF

      ENDIF



!             Append the sign, round, and return.



      IF (JSIN == -1 .AND. MB(1) /= MUNKNO) MB(2) = -MB(2)

  110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)

      MB(0) = MIN(MB(0),MACCA,MACMAX)

      IF (MA2 < 0 .AND. MB(1) /= MUNKNO) MB(2) = -MB(2)

      CALL FMEXIT(MB,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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMSIN2:   M01 - M04



!             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.



      DOUBLE PRECISION 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

          KFLAG = -9

          CALL FMWARN

          NDIG = NDSAVE

          CALL FMST2M('UNKNOWN',MB)

          KWARN = KWRNSV

          RETURN

      ENDIF

      NDSAV1 = NDIG



!             Divide the argument by 3**K2.



      CALL FMEQ2(MA,M02,NDSAVE,NDIG,0)

      KTHREE = 1

      MAXVAL = MXBASE/3

      IF (K2 > 0) THEN

          DO J = 1, K2

             KTHREE = 3*KTHREE

             IF (KTHREE > MAXVAL) THEN

                 CALL FMDIVI(M02,KTHREE,M02)

                 KTHREE = 1

             ENDIF

          ENDDO

          IF (KTHREE > 1) CALL FMDIVI(M02,KTHREE,M02)

      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(M03,NBOT,M03)

         NTERM = NTERM + 2

         KPT = (J-1)*(NDIG+2)

         CALL FMEQ(M03,MJSUMS(KPT))

         M03(2) = -M03(2)

      ENDDO

      CALL FMSQR(M02,M02)

      IF (M02(1) < -NDIG) GO TO 120

      CALL FMIPWR(M02,J2,MB)



  110 CALL FMMPY(M03,MB,M03)

      LARGE = INT(INTMAX/NTERM)

      DO J = 1, J2

         NBOT = NTERM*(NTERM-1)

         IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN

             CALL FMDIVI(M03,NTERM,M03)

             NBOT = NTERM - 1

             CALL FMDIVI(M03,NBOT,M03)

         ELSE

             CALL FMDIVI(M03,NBOT,M03)

         ENDIF

         KPT = (J-1)*(NDSAV1+2)

         NDIG = NDSAV1

         CALL FMADD(MJSUMS(KPT),M03,MJSUMS(KPT))

         IF (KFLAG /= 0) GO TO 120

         NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1))

         IF (NDIG < 2) NDIG = 2

         M03(2) = -M03(2)

         NTERM = NTERM + 2

      ENDDO

      GO TO 110



!             Next put the J2 separate sums back together.



  120 KFLAG = 0

      KPT = (J2-1)*(NDIG+2)

      CALL FMEQ(MJSUMS(KPT),MB)

      IF (J2 >= 2) THEN

          DO J = 2, J2

             CALL FMMPY(M02,MB,MB)

             KPT = (J2-J)*(NDIG+2)

             CALL FMADD(MB,MJSUMS(KPT),MB)

          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(M03,-4,M03)

             CALL FMADD(M02,M03,M03)

             CALL FMMPY(M03,MB,MB)

          ENDDO

      ENDIF



      CALL FMEQ2(MB,MB,NDSAV1,NDSAVE,1)

      NDIG = NDSAVE

      KWARN = KWRNSV



      RETURN

      END SUBROUTINE FMSIN2

      SUBROUTINE FMSINH(MA,MB)



!  MB = SINH(MA)



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMSINH:   M01 - M03



      DOUBLE PRECISION MA2,MACCA,MACMAX,MXSAVE

      INTEGER 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)

      MA2 = MA(2)

      CALL FMEQ2(MA,MB,NDSAVE,NDIG,0)

      MB(0) = NINT(NDIG*ALOGM2)


      MB(2) = ABS(MB(2))

      IF (MA2 == 0) THEN

          CALL FMEQ(MA,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

      IF (MB(1) < 0 .OR. NDIG <= 50) THEN

          CALL FMSNH2(MB,MB)

      ELSE

          CALL FMCSH2(MB,MB)

          CALL FMI2M(1,M03)

          CALL FMSQR(MB,MB)

          CALL FMSUB(MB,M03,MB)

          CALL FMSQRT(MB,MB)

      ENDIF

      GO TO 120



  110 CALL FMEXP(MB,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(M01,MB,M01)

          CALL FMSUB(MB,M01,MB)

      ENDIF

      CALL FMDIVI(MB,2,MB)



!             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 (MA2 < 0 .AND. MB(1) /= MUNKNO) MB(2) = -MB(2)

      CALL FMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)

      RETURN

      END SUBROUTINE FMSINH

      SUBROUTINE FMSNH2(MA,MB)



!  Internal subroutine for MB = SINH(MA).



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMSNH2:   M01 - M03



!             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.



      DOUBLE PRECISION 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

          KFLAG = -9

          CALL FMWARN

          NDIG = NDSAVE

          CALL FMST2M('UNKNOWN',MB)

          KWARN = KWRNSV

          RETURN

      ENDIF

      NDSAV1 = NDIG



!             Divide the argument by 3**K2.



      CALL FMEQ2(MA,M02,NDSAVE,NDIG,0)

      KTHREE = 1

      MAXVAL = MXBASE/3

      IF (K2 > 0) THEN

          DO J = 1, K2

             KTHREE = 3*KTHREE

             IF (KTHREE > MAXVAL) THEN

                 CALL FMDIVI(M02,KTHREE,M02)

                 KTHREE = 1

             ENDIF

          ENDDO

          IF (KTHREE > 1) CALL FMDIVI(M02,KTHREE,M02)

      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(M03,NBOT,M03)

         NTERM = NTERM + 2

         KPT = (J-1)*(NDIG+2)

         CALL FMEQ(M03,MJSUMS(KPT))

      ENDDO

      CALL FMSQR(M02,M02)

      IF (M02(1) < -NDIG) GO TO 120

      CALL FMIPWR(M02,J2,MB)



  110 CALL FMMPY(M03,MB,M03)

      LARGE = INT(INTMAX/NTERM)

      DO J = 1, J2

         NBOT = NTERM*(NTERM-1)

         IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN

             CALL FMDIVI(M03,NTERM,M03)

             NBOT = NTERM - 1

             CALL FMDIVI(M03,NBOT,M03)

         ELSE

             CALL FMDIVI(M03,NBOT,M03)

         ENDIF

         KPT = (J-1)*(NDSAV1+2)

         NDIG = NDSAV1

         CALL FMADD(MJSUMS(KPT),M03,MJSUMS(KPT))

         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+2)

      CALL FMEQ(MJSUMS(KPT),MB)

      IF (J2 >= 2) THEN

          DO J = 2, J2

             CALL FMMPY(M02,MB,MB)

             KPT = (J2-J)*(NDIG+2)

             CALL FMADD(MB,MJSUMS(KPT),MB)

          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(M03,4,M03)

             CALL FMADD(M02,M03,M03)

             CALL FMMPY(M03,MB,MB)

          ENDDO

      ENDIF



      CALL FMEQ2(MB,MB,NDSAV1,NDSAVE,1)

      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

      DOUBLE PRECISION MA(0: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(MA,4096,MA)

              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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0: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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



      DOUBLE PRECISION MA2,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)

      MA2 = MA(2)

      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

      MA(2) = ABS(MA(2))



!             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.



      MA(2) = MA2

      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 JRSIGN = JRSSAV

      RETURN

      END SUBROUTINE FMSQR2

      SUBROUTINE FMSQRT(MA,MB)



!  MB = SQRT(MA)



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMSQRT:   M01 - M02



      DOUBLE PRECISION X,XB

      DOUBLE PRECISION 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) 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,0)

      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(MB,M01,MB)

         CALL FMDIVI(MB,2,MB)

      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

      CALL FMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,0)

      RETURN

      END SUBROUTINE FMSQRT

      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

      DOUBLE PRECISION MA(0:LUNPCK)



      INTEGER J,LB,KFSAVE



      IF (MBLOGS /= MBASE) CALL FMCONS

      NCALL = NCALL + 1

      NAMEST(NCALL) = 'FMST2M'

      LB = LEN(STRING)

      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0: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 FMTAN(MA,MB)



!  MB = TAN(MA)



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMTAN:   M01 - M04



      DOUBLE PRECISION MA2,MACCA,MACMAX,MXSAVE

      INTEGER 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)

      MA2 = MA(2)

      CALL FMEQ2(MA,MB,NDSAVE,NDIG,0)

      MB(0) = NINT(NDIG*ALOGM2)

      MB(2) = ABS(MB(2))



!             Reduce the argument, convert to radians if the input is

!             in degrees, and evaluate the function.



      CALL FMRDC(MB,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(MB,MPISAV,MB)

          CALL FMDIVI(MB,180,MB)

      ENDIF

      IF (MB(1) /= MUNKNO) THEN

          IF (JSWAP == 0) THEN

              IF (MB(1) < 0) THEN

                  CALL FMSIN2(MB,MB)

                  MB(2) = JSIN*MB(2)

                  CALL FMSQR(MB,M03)

                  CALL FMI2M(1,M02)

                  CALL FMSUB(M02,M03,M03)

                  CALL FMSQRT(M03,M04)

                  M04(2) = JCOS*M04(2)

                  CALL FMDIV(MB,M04,MB)

              ELSE

                  CALL FMCOS2(MB,MB)

                  MB(2) = JCOS*MB(2)

                  CALL FMSQR(MB,M03)

                  CALL FMI2M(1,M02)

                  CALL FMSUB(M02,M03,M03)

                  CALL FMSQRT(M03,M04)

                  M04(2) = JSIN*M04(2)

                  CALL FMDIV(M04,MB,MB)

              ENDIF

          ELSE

              IF (MB(1) < 0) THEN

                  CALL FMSIN2(MB,MB)

                  MB(2) = JCOS*MB(2)

                  CALL FMSQR(MB,M03)

                  CALL FMI2M(1,M02)

                  CALL FMSUB(M02,M03,M03)

                  CALL FMSQRT(M03,M04)

                  M04(2) = JSIN*M04(2)

                  CALL FMDIV(M04,MB,MB)

              ELSE

                  CALL FMCOS2(MB,MB)

                  MB(2) = JSIN*MB(2)

                  CALL FMSQR(MB,M03)

                  CALL FMI2M(1,M02)

                  CALL FMSUB(M02,M03,M03)

                  CALL FMSQRT(M03,M04)

                  M04(2) = JCOS*M04(2)

                  CALL FMDIV(MB,M04,MB)

              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 (MA2 < 0 .AND. MB(1) /= MUNKNO) MB(2) = -MB(2)

      CALL FMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)

      RETURN

      END SUBROUTINE FMTAN

      SUBROUTINE FMTANH(MA,MB)



!  MB = TANH(MA)



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMTANH:   M01 - M03



      DOUBLE PRECISION MA2,MACCA,MACMAX,MXSAVE

      INTEGER 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

      MA2 = MA(2)



      MACCA = MA(0)

      CALL FMEQ2(MA,MB,NDSAVE,NDIG,0)

      MB(0) = NINT(NDIG*ALOGM2)

      MB(2) = ABS(MB(2))

      IF (MA(2) == 0) THEN

          CALL FMEQ(MA,MB)

          GO TO 110

      ENDIF



      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,MB)

          CALL FMSQR(MB,MB)

          CALL FMI2M(1,M02)

          CALL FMSUB(MB,M02,M03)

          CALL FMADD(MB,M02,M02)

          CALL FMDIV(M03,M02,MB)

          GO TO 110

      ENDIF

      IF (MB(1) >= 0 .AND. MB(2) /= 0) THEN

          CALL FMCOSH(MB,MB)

          IF (MB(1) > NDIG) THEN

              IF (MA2 > 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(M03,M02,M03)

          CALL FMSQRT(M03,M03)

          CALL FMDIV(M03,MB,MB)

      ELSE

          CALL FMSINH(MB,MB)

          CALL FMSQR(MB,M03)

          CALL FMI2M(1,M02)

          CALL FMADD(M03,M02,M03)

          CALL FMSQRT(M03,M03)

          CALL FMDIV(MB,M03,MB)

      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 (MA2 < 0 .AND. MB(1) /= MUNKNO) MB(2) = -MB(2)

      CALL FMEXIT(MB,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



      DOUBLE PRECISION MA(0:LUNPCK)



      IF (NCALL <= 0) RETURN

      IF (MA(1) > MXEXP+1) THEN

          IF (MA(2) > 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(0) = NINT(NDIG*ALOGM2)

          ENDIF

          KFLAG = -5

      ENDIF

      IF (MA(1) < -MXEXP) THEN

          IF (MA(2) > 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(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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



      DOUBLE PRECISION 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

      IF (MA(2) < 0) 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

          CALL FMMOVE(MWA,MB)

          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



      DOUBLE PRECISION MA(0:LUNPCK),MP(0:LPACK)



      INTEGER J,KP



      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

      IF (MP(2) < 0) MA(2) = -MA(2)

      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,*) ' Values of the FM global parameters.'

      WRITE (KW,*) ' '

      WRITE (KW,*) ' KPTIMP = ',KPTIMP

      WRITE (KW,*) ' KPTIMU = ',KPTIMU

      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,*) ' NBITS  = ',NBITS

      WRITE (KW,*) ' NDG2MX = ',NDG2MX

      WRITE (KW,*) ' NDIGMX = ',NDIGMX

      WRITE (KW,*) ' '

      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,*) ' 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,*) ' 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,*) ' NCALL  = ',NCALL

      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,*) ' 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

      DOUBLE PRECISION MA(0: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,0)

      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:

!  '(0:LUNPCK)' to '(0: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

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMABS(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPABS

      SUBROUTINE FPACOS(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMACOS(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPACOS

      SUBROUTINE FPADD(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMADD(MPA,MPB,MPA)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPADD

      SUBROUTINE FPADDI(MA,L)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0: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

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMASIN(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPASIN

      SUBROUTINE FPATAN(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMATAN(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPATAN

      SUBROUTINE FPATN2(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMATN2(MPA,MPB,MPA)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPATN2

      SUBROUTINE FPBIG(MA)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK)

      CALL FMBIG(MPA)

      CALL FMPACK(MPA,MA)

      RETURN

      END SUBROUTINE FPBIG

      SUBROUTINE FPCHSH(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMCHSH(MPA,MPB,MPA)

      CALL FMPACK(MPB,MB)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPCHSH

      FUNCTION FPCOMP(MA,LREL,MB)

      USE FMVALS

      IMPLICIT NONE

      LOGICAL FPCOMP,FMCOMP

      CHARACTER(*) :: LREL

      DOUBLE PRECISION MA(0:LPACK),MB(0: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

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMCOS(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPCOS

      SUBROUTINE FPCOSH(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMCOSH(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPCOSH

      SUBROUTINE FPCSSN(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMCSSN(MPA,MPB,MPA)

      CALL FMPACK(MPB,MB)

      CALL FMPACK(MPA,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

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMDIM(MPA,MPB,MPA)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPDIM

      SUBROUTINE FPDIV(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMDIV(MPA,MPB,MPA)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPDIV

      SUBROUTINE FPDIVI(MA,IVAL,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      INTEGER IVAL

      CALL FMUNPK(MA,MPA)

      CALL FMDIVI(MPA,IVAL,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPDIVI

      SUBROUTINE FPDP2M(X,MA)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION X

      DOUBLE PRECISION MA(0:LPACK)

      CALL FMDP2M(X,MPA)

      CALL FMPACK(MPA,MA)

      RETURN

      END SUBROUTINE FPDP2M

      SUBROUTINE FPDPM(X,MA)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION X

      DOUBLE PRECISION MA(0:LPACK)

      CALL FMDPM(X,MPA)

      CALL FMPACK(MPA,MA)

      RETURN

      END SUBROUTINE FPDPM

      SUBROUTINE FPEQ(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMEQ(MPA,MPB)

      CALL FMPACK(MPB,MB)

      RETURN

      END SUBROUTINE FPEQ

      SUBROUTINE FPEQU(MA,MB,NDA,NDB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      INTEGER NDA,NDB

      INTEGER NDASAV,NDBSAV,NDGSAV

      NDGSAV = NDIG

      NDASAV = NDA

      NDBSAV = NDB

      NDIG = NDASAV

      CALL FMUNPK(MA,MPA)

      CALL FMEQ2(MPA,MPA,NDASAV,NDBSAV,1)

      NDIG = NDBSAV

      CALL FMPACK(MPA,MB)

      NDA = NDASAV

      NDB = NDBSAV

      NDIG = NDGSAV

      RETURN

      END SUBROUTINE FPEQU

      SUBROUTINE FPEXP(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMEXP(MPA,MPA)

      CALL FMPACK(MPA,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

      DOUBLE PRECISION MA(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMFORM(FORM,MPA,STRING)

      RETURN

      END SUBROUTINE FPFORM

      SUBROUTINE FPFPRT(FORM,MA)

      USE FMVALS

      IMPLICIT NONE

      CHARACTER(*) :: FORM

      DOUBLE PRECISION MA(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMFPRT(FORM,MPA)

      RETURN

      END SUBROUTINE FPFPRT

      SUBROUTINE FPI2M(IVAL,MA)

      USE FMVALS

      IMPLICIT NONE

      INTEGER IVAL

      DOUBLE PRECISION MA(0: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)

      DOUBLE PRECISION MA(0:LPACK)

      CALL FMINP(LINE,MPA,LA,LB)

      CALL FMPACK(MPA,MA)

      RETURN

      END SUBROUTINE FPINP

      SUBROUTINE FPINT(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMINT(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPINT

      SUBROUTINE FPIPWR(MA,IVAL,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      INTEGER IVAL

      CALL FMUNPK(MA,MPA)

      CALL FMIPWR(MPA,IVAL,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPIPWR

      SUBROUTINE FPLG10(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMLG10(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPLG10

      SUBROUTINE FPLN(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMLN(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPLN

      SUBROUTINE FPLNI(IVAL,MA)

      USE FMVALS

      IMPLICIT NONE

      INTEGER IVAL

      DOUBLE PRECISION MA(0:LPACK)

      CALL FMLNI(IVAL,MPA)

      CALL FMPACK(MPA,MA)

      RETURN

      END SUBROUTINE FPLNI

      SUBROUTINE FPM2DP(MA,X)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK)

      DOUBLE PRECISION X

      CALL FMUNPK(MA,MPA)

      CALL FMM2DP(MPA,X)

      RETURN

      END SUBROUTINE FPM2DP

      SUBROUTINE FPM2I(MA,IVAL)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK)

      INTEGER IVAL

      CALL FMUNPK(MA,MPA)

      CALL FMM2I(MPA,IVAL)

      RETURN

      END SUBROUTINE FPM2I

      SUBROUTINE FPM2SP(MA,X)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK)

      REAL X

      CALL FMUNPK(MA,MPA)

      CALL FMM2SP(MPA,X)

      RETURN

      END SUBROUTINE FPM2SP

      SUBROUTINE FPMAX(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMMAX(MPA,MPB,MPA)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPMAX

      SUBROUTINE FPMIN(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMMIN(MPA,MPB,MPA)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPMIN

      SUBROUTINE FPMOD(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMMOD(MPA,MPB,MPA)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPMOD

      SUBROUTINE FPMPY(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMMPY(MPA,MPB,MPA)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPMPY

      SUBROUTINE FPMPYI(MA,IVAL,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      INTEGER IVAL

      CALL FMUNPK(MA,MPA)

      CALL FMMPYI(MPA,IVAL,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPMPYI

      SUBROUTINE FPNINT(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMNINT(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPNINT

      SUBROUTINE FPOUT(MA,LINE,LB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0: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

      DOUBLE PRECISION MA(0:LPACK)

      CALL FMPI(MPA)

      CALL FMPACK(MPA,MA)

      RETURN

      END SUBROUTINE FPPI

      SUBROUTINE FPPRNT(MA)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMPRNT(MPA)

      RETURN

      END SUBROUTINE FPPRNT

      SUBROUTINE FPPWR(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMPWR(MPA,MPB,MPA)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPPWR

      SUBROUTINE FPREAD(KREAD,MA)

      USE FMVALS

      IMPLICIT NONE

      INTEGER KREAD

      DOUBLE PRECISION MA(0:LPACK)

      CALL FMREAD(KREAD,MPA)

      CALL FMPACK(MPA,MA)

      RETURN

      END SUBROUTINE FPREAD

      SUBROUTINE FPRPWR(MA,KVAL,JVAL,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      INTEGER KVAL,JVAL

      CALL FMUNPK(MA,MPA)

      CALL FMRPWR(MPA,KVAL,JVAL,MPA)

      CALL FMPACK(MPA,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

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMSIGN(MPA,MPB,MPA)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPSIGN

      SUBROUTINE FPSIN(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMSIN(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPSIN

      SUBROUTINE FPSINH(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMSINH(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPSINH

      SUBROUTINE FPSP2M(X,MA)

      USE FMVALS

      IMPLICIT NONE

      REAL X

      DOUBLE PRECISION MA(0:LPACK)

      CALL FMSP2M(X,MPA)

      CALL FMPACK(MPA,MA)

      RETURN

      END SUBROUTINE FPSP2M

      SUBROUTINE FPSQR(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMSQR(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPSQR

      SUBROUTINE FPSQRT(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMSQRT(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPSQRT

      SUBROUTINE FPST2M(STRING,MA)

      USE FMVALS

      IMPLICIT NONE

      CHARACTER(*) :: STRING

      DOUBLE PRECISION MA(0:LPACK)

      CALL FMST2M(STRING,MPA)

      CALL FMPACK(MPA,MA)

      RETURN

      END SUBROUTINE FPST2M

      SUBROUTINE FPSUB(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMSUB(MPA,MPB,MPA)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPSUB

      SUBROUTINE FPTAN(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMTAN(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPTAN

      SUBROUTINE FPTANH(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMTANH(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPTANH

      SUBROUTINE FPULP(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMULP(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPULP

      SUBROUTINE FPVARS

      CALL FMVARS

      RETURN

      END SUBROUTINE FPVARS

      SUBROUTINE FPWRIT(KWRITE,MA)

      USE FMVALS

      IMPLICIT NONE

      INTEGER KWRITE

      DOUBLE PRECISION MA(0: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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0: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(2) = ABS(MB(2))

      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



      DOUBLE PRECISION MDA,MDAB,MDB

      INTEGER J,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(2)

          ELSE IF (MA(2) < 0) THEN

              MDA = MA(2)*MBASE - MA(3)

          ELSE

              MDA = MA(2)*MBASE + MA(3)

          ENDIF

          IF (MB(1) <= 1) THEN

              MDB = MB(2)

          ELSE IF (MB(2) < 0) THEN

              MDB = MB(2)*MBASE - MB(3)

          ELSE

              MDB = 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(2) = 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(2) = AINT (MDAB/MBASE)

              MC(3) = ABS(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

              MDA = 1

              IF ((SIGN(MDA,MA(2)) == SIGN(MDA,MB(2))) .OR.  &

                  (MB(2) == 0)) THEN

                  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

              MDA = 1

              IF ((SIGN(MDA,MB(2)) == SIGN(MDA,MA(2))) .OR.  &

                  (MA(2) == 0)) THEN

                  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



      IF (MA(1) > MB(1)) THEN

          NDIG = INT(MA(1)) + 1

          IF (NDIG < 2 .OR. NDIG > NDG2MX) NDIG = 2

          MA(NDIG+1) = 0

          DO J = INT(MB(1))+2, NDIG+1

             MB(J) = 0

          ENDDO

      ELSE

          NDIG = INT(MB(1)) + 1

          IF (NDIG < 2 .OR. NDIG > NDG2MX) NDIG = 2

          MB(NDIG+1) = 0

          DO J = INT(MA(1))+2, NDIG+1

             MA(J) = 0

          ENDDO

      ENDIF



      CALL FMADD2(MA,MB,MC)



  120 IF (MC(1) > NDIGMX) THEN

          IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN

              IF (MC(2) > 0) THEN

                  CALL IMST2M('OVERFLOW',MC)

              ELSE

                  CALL IMST2M('-OVERFLOW',MC)

              ENDIF

              KFLAG = -5

              NAMEST(NCALL) = 'IMADD '

              CALL FMWARN

          ENDIF

      ENDIF



  130 IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)

      NCALL = NCALL - 1

      NDIG = NDSAVE

      RETURN

      END SUBROUTINE IMADD

      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

      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER NARGS



      DOUBLE PRECISION 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) <= (-MBASE) .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) <= (-MBASE) .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



      DOUBLE PRECISION MA(0: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)



      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

      DOUBLE PRECISION MA(0:LUNPCK),MB(0: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

              IF (MA(1) <= 1) MA(3) = 0

              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

              IF (MB(1) <= 1) MB(3) = 0

              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)) 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) JCOMP = 1

          IF (MB(2) > 0) JCOMP = 3

          GO TO 110

      ENDIF

      IF (MB(2) == 0) THEN

          JCOMP = 1

          IF (MA(2) < 0) JCOMP = 3

          GO TO 110

      ENDIF

!             Check for opposite signs.



      IF (MA(2) > 0 .AND. MB(2) < 0) THEN

          JCOMP = 1

          GO TO 110

      ENDIF

      IF (MB(2) > 0 .AND. MA(2) < 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(2) < 0) THEN

          JCOMP = 3

      ELSE IF (JCOMP == 3 .AND. MB(2) < 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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0: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)) 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(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(2) > 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 (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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



!             Scratch array usage during IMDIV:   M01 - M03



      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 (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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during IMDIVI:   M01 - M03



      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 (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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK),  &

                       MD(0:LUNPCK)



!             Scratch array usage during IMDIVR:   M01 - M02



      DOUBLE PRECISION MDA,MDAB,MDB,MDR

      DOUBLE PRECISION XB,XBR,XBASE,XMWA

      DOUBLE PRECISION MA2,MA2P,MACCA,MACCB,MAXMWA,MB1,MB2,MB2P,  &

                       MBM1,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(2) == 1) THEN

              CALL IMEQ(MA,MC)

              MD(1) = 0

              MD(2) = 0

              MD(3) = 0

              MD(0) = NINT(NDG2MX*ALOGM2)

              GO TO 160

          ELSE IF (MB(2) == -1) THEN

              CALL IMEQ(MA,MC)

              IF (MC(1) /= MUNKNO) MC(2) = -MC(2)

              MD(1) = 0

              MD(2) = 0

              MD(3) = 0

              MD(0) = NINT(NDG2MX*ALOGM2)

              GO TO 160

          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 160

      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(2)

          ELSE IF (MA(2) < 0) THEN

              MDA = MA(2)*MBASE - MA(3)

          ELSE

              MDA = MA(2)*MBASE + MA(3)

          ENDIF

          IF (MB(1) <= 1) THEN

              MDB = MB(2)

          ELSE IF (MB(2) < 0) THEN

              MDB = MB(2)*MBASE - MB(3)

          ELSE

              MDB = MB(2)*MBASE + MB(3)

          ENDIF

          MDAB = AINT (MDA / MDB)

          MDR = MDA - MDAB*MDB

          IF (ABS(MDAB) < MBASE) THEN

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

              MC(1) = 1

              IF (MDAB == 0) MC(1) = 0

              MC(2) = MDAB

              MC(3) = 0

          ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN

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

              MC(1) = 2

              MC(2) = AINT (MDAB/MBASE)

              MC(3) = ABS(MDAB - MBASE*MC(2))

          ELSE

              GO TO 110

          ENDIF

          IF (ABS(MDR) < MBASE) THEN

              MD(0) = MC(0)

              MD(1) = 1

              IF (MDR == 0) MD(1) = 0

              MD(2) = MDR

              MD(3) = 0

              GO TO 160

          ELSE IF (ABS(MDR) < MBASE*MBASE) THEN

              MD(0) = MC(0)

              MD(1) = 2

              MD(2) = AINT (MDR/MBASE)

              MD(3) = ABS(MDR - MBASE*MD(2))

              GO TO 160

          ENDIF

      ENDIF



  110 KLTFLG = 0

      MA2 = MA(2)

      MB2 = MB(2)

      KL = INT(MB(1))

      IF (KL > NDG2MX) KL = 2

      DO J = 0, KL+1

         M01(J) = MB(J)

      ENDDO

      M01(2) = ABS(M01(2))

      IF (KL == 1) M01(3) = 0

      IF (MA(1) == M01(1) .AND. ABS(MA(2)) <= M01(2)) THEN

          MA(2) = ABS(MA(2))

          IF (IMCOMP(MA,'EQ',M01)) THEN

              KLTFLG = 2

          ELSE IF (IMCOMP(MA,'LT',M01)) THEN

              KLTFLG = 1

          ENDIF

          MA(2) = MA2

      ENDIF

      IF (MA(1) < MB(1) .OR. KLTFLG >= 1) THEN

          IF (KLTFLG /= 2) THEN

              CALL IMEQ(MA,MD)

              MD(2) = ABS(MD(2))

              CALL IMI2M(0,MC)

          ELSE

              CALL IMI2M(1,MC)

              CALL IMI2M(0,MD)

          ENDIF

          GO TO 150

      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

      MA2P = ABS(MA(2))

      MB2P = ABS(MB(2))

      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.



      MA2 = MA(2)

      MB1 = MB(1)

      MB2 = MB(2)

      MA(2) = MA2P

      MWA(3) = MA(2)

      MB(1) = 0

      MB(2) = MB2P



!             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.



  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 = 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 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



      LCRRCT = 0

  130 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 130

      ELSE IF (MWA(KA) >= MBASE) THEN

          LCRRCT = LCRRCT + 1

          DO J = KA, KB

             MWA(J) = MWA(J) - MB(J-JB)

          ENDDO

          GO TO 130

      ENDIF



      MA(2) = MA2

      MB(1) = MB1

      MB(2) = MB2



      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)



      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 140

             ENDIF

          ENDDO

          MD(1) = 0

          MD(2) = 0

      ENDIF

  140 IF (MD(1) <= 1) MD(3) = 0

      MD(0) = MIN(MACCA,MACCB)



!             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,MD)

              LCRRCT = LCRRCT + 1

          ENDIF

      ENDIF

      IF (LCRRCT /= 0) THEN

          CALL IMI2M(LCRRCT,M02)

          CALL IMADD(M02,MC,MC)

      ENDIF



  150 IF (MA2 < 0 .AND. MB2 > 0) THEN

          IF (MC(1) /= MUNKNO) MC(2) = -MC(2)

          IF (MD(1) /= MUNKNO) MD(2) = -MD(2)

      ELSE IF (MA2 > 0 .AND. MB2 < 0)  THEN

          IF (MC(1) /= MUNKNO) MC(2) = -MC(2)

      ELSE IF (MA2 < 0 .AND. MB2 < 0)  THEN

          IF (MD(1) /= MUNKNO) MD(2) = -MD(2)

      ENDIF



  160 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

                  IF (MD(1) <= 1) MD(3) = 0

                  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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during IMDVIR:   M01 - M03



      DOUBLE PRECISION MA2,MDA,MDAB,MDB,MDR,MKT,MODINT,MVALP

      INTEGER IDIV,IREM,J,JDIV,KA,KL,KLTFLG,KPT,N1,NDSAVE,  &

              NMVAL,NTRSAV,NV2

      LOGICAL IMCOMP



      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) = IDIV

          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

          IF (IDIV < 0) M01(2) = -M01(2)

      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 140

      ENDIF

      IF (JDIV == 1 .AND. MA(1) /= MUNKNO) THEN

          IF (IDIV == 1) THEN

              CALL IMEQ(MA,MB)

              IREM = 0

              GO TO 140

          ELSE

              CALL IMEQ(MA,MB)

              IF (MB(1) /= MUNKNO) MB(2) = -MB(2)

              IREM = 0

              GO TO 140

          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 140

      ENDIF

      IF (MA(1) <= 2) THEN

          IF (MA(1) <= 1) THEN

              MDA = MA(2)

          ELSE IF (MA(2) < 0) THEN

              MDA = MA(2)*MBASE - MA(3)

          ELSE

              MDA = 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

              MB(2) = MDAB

              MB(3) = 0

          ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN

              MB(0) = MA(0)

              MB(1) = 2

              MB(2) = AINT (MDAB/MBASE)

              MB(3) = ABS(MDAB - MBASE*MB(2))

          ELSE

              GO TO 110

          ENDIF

          IREM = INT(MDR)

          GO TO 140

      ENDIF



  110 MA2 = MA(2)

      M01(2) = ABS(M01(2))

      IF (MA(1) <= M01(1)) THEN

          IF (MA(1) == M01(1) .AND. ABS(MA(2)) <= M01(2)) THEN

              MA(2) = ABS(MA(2))

              IF (IMCOMP(MA,'EQ',M01)) THEN

                  KLTFLG = 2

              ELSE IF (IMCOMP(MA,'LT',M01)) THEN

                  KLTFLG = 1

              ENDIF

              MA(2) = MA2

          ENDIF

          IF (MA(1) < M01(1) .OR. KLTFLG >= 1) THEN

              IF (KLTFLG /= 2) THEN

                  CALL IMM2I(MA,IREM)

                  IREM = ABS(IREM)

                  CALL IMI2M(0,MB)

              ELSE

                  CALL IMI2M(1,MB)

                  IREM = 0

              ENDIF

              GO TO 130

          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,M03)

          CALL IMM2I(M03,IREM)

          GO TO 140

      ENDIF



!             Work with positive numbers.



      MA(2) = ABS(MA(2))



!             Find the first significant digit of the quotient.



      MKT = MA(2)

      IF (MKT >= MVALP) THEN

          KPT = 2

          GO TO 120

      ENDIF

      DO J = 3, N1

         MKT = MKT*MBASE + MA(J)

         IF (MKT >= MVALP) THEN

             KPT = J

             GO TO 120

         ENDIF

      ENDDO



      CALL IMM2I(MA,IREM)

      CALL IMI2M(0,MB)

      GO TO 140



!             Do the rest of the division.



  120 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)



  130 IF (MA2 < 0 .AND. IDIV > 0) THEN

          IF (MB(1) /= MUNKNO) MB(2) = -MB(2)

          IREM = -IREM

      ELSE IF (MA2 > 0 .AND. IDIV < 0)  THEN

          IF (MB(1) /= MUNKNO) MB(2) = -MB(2)

      ELSE IF (MA2 < 0 .AND. IDIV < 0)  THEN

          IREM = -IREM

      ENDIF



  140 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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



      INTEGER J,KDG



      KDG = MAX(2,INT(MA(1))) + 1

      IF (KDG > LUNPCK) KDG = 3

      DO J = 0, 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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



      INTEGER NTRSAV



      NCALL = NCALL + 1

      KFLAG = 0

      NTRSAV = NTRACE

      NTRACE = 0

      CALL FMEQ(MA,MB)

      CALL FMINT(MB,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

      ENDIF

      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

      DOUBLE PRECISION MA(0:LUNPCK)



!             Scratch array usage during IMFORM:   M01 - M02



      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

      IF (MA(1) <= 1) MA(3) = 0



      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

      DOUBLE PRECISION MA(0:LUNPCK)



!             Scratch array usage during IMFPRT:   M01 - M02



      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

      IF (MA(1) <= 1) MA(3) = 0



      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



!             Scratch array usage during IMGCD:   M01 - M05



      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,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 (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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0: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

      IF (MA(1) <= 1) MA(3) = 0

      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



      DOUBLE PRECISION MA(0: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

      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)

      DOUBLE PRECISION MA(0:LUNPCK)



      NCALL = NCALL + 1

      KFLAG = 0

      NDSAVE = NDIG

      NAMEST(NCALL) = 'IMINP '



      NDIG = NDIGMX

      CALL FMINP(LINE,MA,LA,LB)

      KFSAVE = KFLAG

      CALL FMINT(MA,MA)

      KFLAG = KFSAVE



      IF (MA(1) > NDG2MX .AND. MA(1) < MEXPOV) THEN

          KFLAG = -9

          NDIG = INT(MA(1))

          CALL FMWARN

          MA(0) = NINT(NDG2MX*ALOGM2)

          MA(1) = MUNKNO

          MA(2) = 1

          MA(3) = 0

      ENDIF



      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



      DOUBLE PRECISION MA(0: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

      IF (MA(1) <= 1) MA(3) = 0

      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



      DOUBLE PRECISION MA(0: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

      IF (MA(1) <= 1) MA(3) = 0

      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0: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



      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0: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



      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



!             Scratch array usage during IMMOD:   M01 - M03



      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 (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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



      DOUBLE PRECISION MDAB

      INTEGER J,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(2) * MB(2)

          IF (ABS(MDAB) < MBASE) THEN

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

              MC(1) = 1

              IF (MDAB == 0) MC(1) = 0

              MC(2) = MDAB

              MC(3) = 0

              GO TO 120

          ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN

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

              MC(1) = 2

              MC(2) = AINT (MDAB/MBASE)

              MC(3) = ABS(MDAB - MBASE*MC(2))

              GO TO 120

          ENDIF

      ENDIF



!             Check for special cases.



  110 KOVFL = 0

      IF (MA(1) == MEXPOV .OR. MB(1) == MEXPOV) KOVFL = 1

      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) THEN

          CALL IMEQ(MA,MC)

          GO TO 120

      ELSE IF (MB(1) == 1 .AND. MB(2) == -1) THEN

          CALL IMEQ(MA,MC)

          IF (MC(1) /= MUNKNO) MC(2) = -MC(2)

          GO TO 120

      ELSE IF (MA(1) == 1 .AND. MA(2) == 1) THEN

          CALL IMEQ(MB,MC)

          GO TO 120

      ELSE IF (MA(1) == 1 .AND. MA(2) == -1) THEN

          CALL IMEQ(MB,MC)

          IF (MC(1) /= MUNKNO) MC(2) = -MC(2)

          GO TO 120

      ELSE IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN

          KFLAG = -4

          CALL IMST2M('UNKNOWN',MC)

          GO TO 130

      ENDIF



      NDIG = INT(MA(1) + MB(1))

      IF (NDIG < 2) NDIG = 2

      IF (NDIG > NDG2MX) NDIG = NDG2MX

      IF (MA(1) == MEXPOV .OR. MB(1) == MEXPOV) NDIG = 2



      DO J = INT(MA(1))+2, NDIG+1

         MA(J) = 0

      ENDDO

      DO J = INT(MB(1))+2, NDIG+1

         MB(J) = 0

      ENDDO



      CALL FMMPY2(MA,MB,MC)



      IF (NDIG > NDIGMX) NDIG = 2

  120 IF (MC(1) > NDIGMX) THEN

          IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN

              IF (MC(2) > 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 (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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



      DOUBLE PRECISION 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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during IMMPYI:   M01



      DOUBLE PRECISION MA2,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

      MA2 = MA(2)



      IF (MA(1) <= 1) THEN

          MDAB = MA(2) * IVAL

          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) = ABS(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) MB(2) = -MB(2)

          GO TO 120

      ELSE IF (MA(1) == 1 .AND. MA(2) == 1) THEN

          CALL IMI2M(IVAL,MB)

          GO TO 120

      ELSE IF (MA(1) == 1 .AND. MA(2) == -1) THEN

          CALL IMI2M(IVAL,MB)

          IF (MB(1) /= MUNKNO) MB(2) = -MB(2)

          GO TO 120

      ELSE IF (MA(1) == MEXPOV) THEN

          KFLAG = -5

          CALL IMST2M('OVERFLOW',MB)

          GO TO 110

      ENDIF



!             Work with positive numbers.



      MA(2) = ABS(MA(2))

      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 FMMPY.



      IF (KSHIFT > NDIG .OR. MVAL > MAXINT/MBASE .OR.  &

          NMVAL /= ABS(IVAL) .OR. NV2 /= ABS(IVAL)-1) THEN

          MA(2) = MA2

          NDIG = 4

          CALL FMIM(IVAL,M01)

          NDIG = INT(MA(1) + M01(1))

          IF (NDIG < 2) NDIG = 2

          IF (NDIG > NDG2MX) NDIG = NDG2MX

          DO J = INT(MA(1))+2, NDIG+1

             MA(J) = 0

          ENDDO

          IF (NDIG > 4) CALL FMIM(IVAL,M01)

          CALL FMMPY2(MA,M01,MB)

          GO TO 130

      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).



      MA(2) = MA2

      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 IF ((IVAL > 0 .AND. MA2 < 0) .OR. (IVAL < 0 .AND.MA2 > 0))  &

           MB(2) = -MB(2)



  120 IF (MB(1) > NDIGMX) THEN

          IF (NCALL == 1 .OR. MB(1) > NDG2MX) THEN

              IF (MB(2) > 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 (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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK),  &

                       MD(0:LUNPCK)



!             Scratch array usage during IMMPYM:   M01 - M02



      DOUBLE PRECISION MA2,MAXMWA,MB2,MBM1,MC1,MC2,MC2P,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

                  IF (MC(1) <= 1) MC(3) = 0

                  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(2) * MB(2)

          IF (MC(1) <= 2) THEN

              IF (MC(2) == 0) GO TO 110

              IF (MC(1) <= 1) THEN

                  MDC = MC(2)

              ELSE IF (MC(2) < 0) THEN

                  MDC = MC(2)*MBASE - MC(3)

              ELSE

                  MDC = 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(2) = 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(2) = AINT (MDAB/MBASE)

              MD(3) = ABS(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. ABS(MC(2)) == 1) THEN

          CALL IMI2M(0,MD)

          GO TO 170

      ELSE IF (MB(1) == 1 .AND. MB(2) == 1) THEN

          CALL IMMOD(MA,MC,MD)

          GO TO 160

      ELSE IF (MB(1) == 1 .AND. MB(2) == -1) THEN

          CALL IMMOD(MA,MC,MD)

          IF (MD(1) /= MUNKNO) MD(2) = -MD(2)

          GO TO 160

      ELSE IF (MA(1) == 1 .AND. MA(2) == 1) THEN

          CALL IMMOD(MB,MC,MD)

          GO TO 160

      ELSE IF (MA(1) == 1 .AND. MA(2) == -1) THEN

          CALL IMMOD(MB,MC,MD)

          IF (MD(1) /= MUNKNO) MD(2) = -MD(2)

          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.



      MA2 = MA(2)

      MB2 = MB(2)

      MA(2) = ABS(MA(2))

      MB(2) = ABS(MB(2))



      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

      MC2 = MC(2)

      KL = INT(MC(1))

      IF (KL > LMWA) KL = 2

      DO J = 0, KL+1

         M01(J) = MC(J)

      ENDDO

      M01(2) = ABS(M01(2))

      IF (MWA(1) == M01(1) .AND. ABS(MWA(3)) <= M01(2)) THEN

          DO J = 4, N1

             M02(J-1) = MWA(J)

          ENDDO

          M02(2) = ABS(MWA(3))

          M02(1) = MWA(1)

          IF (IMCOMP(M02,'EQ',M01)) THEN

              KLTFLG = 2

          ELSE IF (IMCOMP(M02,'LT',M01)) THEN

              KLTFLG = 1

          ENDIF

      ENDIF

      IF (MWA(1) < MC(1) .OR. KLTFLG >= 1) THEN

          IF (KLTFLG /= 2) THEN

              DO J = 3, N1+1

                 MD(J-1) = MWA(J)

              ENDDO

              MD(1) = MWA(1)

              MD(0) = MIN(MA(0),MB(0),MC(0))

          ELSE

              CALL IMI2M(0,MD)

          ENDIF

          GO TO 150

      ENDIF



      NDIG = INT(MWA(1))

      IF (NDIG < 2) NDIG = 2



!             NGUARD is the number of guard digits used.



      NGUARD = 1

      MC2P = ABS(MC(2))

      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)

      MC2 = MC(2)

      MC(1) = 0

      MC(2) = MC2P



!             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



      MA(2) = MA2

      MB(2) = MB2

      MC(1) = MC1

      MC(2) = MC2



      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

          IF (IMCOMP(MD,'GE',M01)) CALL IMSUB(MD,M01,MD)

      ENDIF



  150 IF (MA2*MB2 < 0 .AND. MC2 > 0) THEN

          IF (MD(1) /= MUNKNO) MD(2) = -MD(2)

      ELSE IF (MA2*MB2 < 0 .AND. MC2 < 0)  THEN

          IF (MD(1) /= MUNKNO) MD(2) = -MD(2)

      ENDIF



      IF (NDIG > NDIGMX) NDIG = 2

  160 IF (MD(1) == MUNKNO) THEN

          KFLAG = -4

          NAMEST(NCALL) = 'IMMPYM'

          CALL FMWARN

      ENDIF



  170 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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during IMNTR:   M01 - M02



      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

          IF (MA(1) <= 1) MA(3) = 0

          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

              IF (MB(1) <= 1) MB(3) = 0

              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



      DOUBLE PRECISION MA(0: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(J)),J=1,N1)



      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)

      DOUBLE PRECISION MA(0: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

      IF (MA(1) <= 1) MA(3) = 0

      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



      DOUBLE PRECISION MA(0:LUNPCK),MP(0: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)

      IF (MA(2) < 0) MP(2) = -MP(2)

      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK),  &

                       MD(0:LUNPCK)



!             Scratch array usage during IMPMOD:   M01 - M06



      DOUBLE PRECISION MACCA,MACCB,MB2

      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

                  IF (MC(1) <= 1) MC(3) = 0

                  NTRSAV = NTRACE

                  IF (NTRACE < -2) NTRACE = -2

                  CALL IMNTRJ(MC,NDIG)

                  NTRACE = NTRSAV

                  NDIG = NDSAVE

              ELSE

                  CALL IMPRNT(MC)

              ENDIF

          ENDIF

      ENDIF

      MB2 = MB(2)

      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(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)

          NCALL = NCALL - 1

          RETURN

      ENDIF



      IF (MB2 == 0) THEN

          CALL IMI2M(1,MD)

          IF (NTRACE /= 0) CALL IMNTR(1,MD,MD,1)

          NCALL = NCALL - 1

          RETURN

      ENDIF



      IF (MB(1) == 1 .AND. ABS(MB2) == 1) THEN

          KWRNSV = KWARN

          KWARN = 0

          IF (MB2 == 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)

          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)

          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,M06,IREM)



!             This is the multiplication loop.



  110 CALL IMDVIR(M06,2,M06,IREM)

      CALL IMMPYM(M05,M05,M04,M05)

      IF (IREM == 1) CALL IMMPYM(M05,MD,M04,MD)

      IF (M06(2) > 0 .AND. MD(2) /= 0) GO TO 110



      IF (MB2 < 0) THEN

          CALL IMI2M(1,M05)

          CALL IMDIVR(M05,MD,MD,M06)

      ENDIF

      KWARN = KWRNSV

      MD(0) = MIN(MACCA,MACCB)

      IF (KFLAG < 0) THEN

          NAMEST(NCALL) = 'IMPMOD'

          CALL FMWARN

      ENDIF

      IF (NTRACE /= 0) CALL IMNTR(1,MD,MD,1)

      NCALL = NCALL - 1

      RETURN

      END SUBROUTINE IMPMOD

      SUBROUTINE IMPRNT(MA)



!  Print MA in base 10 format.



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK)



      INTEGER JF1SAV,JF2SAV,NDSAVE



      NDSAVE = NDIG

      JF1SAV = JFORM1

      JF2SAV = JFORM2

      JFORM1 = 2

      JFORM2 = 0

      NDIG = MAX(2,INT(MA(1)))

      IF (MA(1) <= 1) MA(3) = 0

      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



!             Scratch array usage during IMPWR:   M01 - M06



      DOUBLE PRECISION MA2,MACCA,MACCB,MB2

      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

      MA2 = MA(2)

      MB2 = MB(2)

      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(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 (MB2 == 0) THEN

          CALL IMI2M(1,MC)

          GO TO 130

      ENDIF



      IF (MA(1) == 1 .AND. ABS(MA2) == 1) THEN

          KWARN = 0

          IF (MA2 == 1) THEN

              CALL IMI2M(1,MC)

          ELSE

              CALL IMI2M(2,M05)

              CALL IMDIVR(MB,M05,M05,M06)

              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. ABS(MB2) == 1) THEN

          KWARN = 0

          IF (MB2 == 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 (MB2 < 0) THEN

              CALL IMI2M(0,MC)

          ELSE IF (MA2 > 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(2) < 0) JSIGN = -1

          IF (MB2 > 0) THEN

              CALL IMDVIR(MB,2,MC,IREM)

              CALL IMST2M('OVERFLOW',MC)

              MC(2) = 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,M06,IREM)



!             This is the multiplication loop.



  110 CALL IMDVIR(M06,2,M06,IREM)

      CALL IMSQR(M05,M05)

      IF (IREM == 1) CALL IMMPY(M05,MC,MC)

      IF (M05(1) == MEXPOV) THEN

          CALL IMEQ(M05,MC)

          IF (MA2 < 0 .AND. IREMB == 1) MC(2) = -1

          GO TO 120

      ENDIF

      IF (M06(2) > 0) GO TO 110



  120 IF (MB2 < 0) THEN

          CALL IMI2M(1,M05)

          CALL IMDIVR(M05,MC,MC,M06)

      ENDIF



      MC(0) = MIN(MACCA,MACCB)

      IF (MC(1) > NDIGMX) THEN

          IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN

              IF (MC(2) > 0) THEN

                  CALL IMST2M('OVERFLOW',MC)

              ELSE

                  CALL IMST2M('-OVERFLOW',MC)

              ENDIF

              KFLAG = -5

              KWARN = KWRNSV

              NAMEST(NCALL) = 'IMPWR '

              CALL FMWARN

          ENDIF

      ENDIF



  130 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



      DOUBLE PRECISION MA(0:LUNPCK)

      INTEGER KREAD



      INTEGER NDSAVE,KWRNSV



      NCALL = NCALL + 1

      NDSAVE = NDIG

      NDIG = NDIGMX

      CALL FMREAD(KREAD,MA)

      KWRNSV = KWARN

      KWARN = 0

      CALL FMNINT(MA,MA)

      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0: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

      IF (MA(1) <= 1) MA(3) = 0

      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(2) >= 0) THEN

          CALL IMEQ(MA,MC)

          MC(2) = ABS(MC(2))

      ELSE

          CALL IMEQ(MA,MC)

          MC(2) = -ABS(MC(2))

      ENDIF



      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



      DOUBLE PRECISION MDAB

      INTEGER J,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) = ABS(MDAB - MBASE*MB(2))

              GO TO 120

          ENDIF

      ENDIF



!             Check for special cases.



  110 KOVFL = 0

      IF (MA(1) == MEXPOV) KOVFL = 1

      IF (MA(1) == 1 .AND. ABS(MA(2)) == 1) THEN

          CALL IMI2M(1,MB)

          GO TO 120

      ELSE IF (MA(1) == MUNKNO) THEN

          KFLAG = -4

          CALL IMST2M('UNKNOWN',MB)

          GO TO 130

      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 < 2) NDIG = 2

      IF (NDIG > NDG2MX) NDIG = NDG2MX

      IF (MA(1) == MEXPOV .OR. MB(1) == MEXPOV) NDIG = 2



      DO J = INT(MA(1))+2, NDIG+1

         MA(J) = 0

      ENDDO



      CALL FMSQR2(MA,MB)



      IF (NDIG > NDIGMX) NDIG = 2

  120 IF (MB(1) > NDIGMX) THEN

          IF (NCALL == 1 .OR. MB(1) > NDG2MX) THEN

              IF (MB(2) > 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 (NTRACE /= 0) CALL IMNTR(1,MB,MB,1)

      NCALL = NCALL - 1

      NDIG = NDSAVE

      RETURN

      END SUBROUTINE IMSQR

      SUBROUTINE IMST2M(STRING,MA)



!  MA = STRING



!  Convert a character string to IM format.



      USE FMVALS

      IMPLICIT NONE



      CHARACTER(*) :: STRING

      DOUBLE PRECISION MA(0:LUNPCK)



      INTEGER J,LB,KFSAVE



      IF (MBLOGS /= MBASE) CALL FMCONS

      NCALL = NCALL + 1

      NAMEST(NCALL) = 'IMST2M'

      LB = LEN(STRING)

      KFSAVE = KFLAG



      DO J = 1, LB

         CMBUFF(J) = STRING(J:J)

      ENDDO



      CALL IMINP(CMBUFF,MA,1,LB)



      IF (KFSAVE /= 0) KFLAG = KFSAVE

      NCALL = NCALL - 1

      RETURN

      END SUBROUTINE IMST2M

      SUBROUTINE IMSUB(MA,MB,MC)



!  MC = MA - MB



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



      DOUBLE PRECISION MDA,MDAB,MDB

      INTEGER J,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(2)

          ELSE IF (MA(2) < 0) THEN

              MDA = MA(2)*MBASE - MA(3)

          ELSE

              MDA = MA(2)*MBASE + MA(3)

          ENDIF

          IF (MB(1) <= 1) THEN

              MDB = MB(2)

          ELSE IF (MB(2) < 0) THEN

              MDB = MB(2)*MBASE - MB(3)

          ELSE

              MDB = 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(2) = 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(2) = AINT (MDAB/MBASE)

              MC(3) = ABS(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

              MDA = 1

              IF ((SIGN(MDA,MA(2)) == SIGN(MDA,-MB(2))) .OR.  &

                  (MB(2) == 0)) THEN

                  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

              MDA = 1

              IF ((SIGN(MDA,-MB(2)) == SIGN(MDA,MA(2))) .OR.  &

                  (MA(2) == 0)) THEN

                  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



      IF (MA(1) > MB(1)) THEN

          NDIG = INT(MA(1)) + 1

          IF (NDIG < 2 .OR. NDIG > NDG2MX) NDIG = 2

          MA(NDIG+1) = 0

          DO J = INT(MB(1))+2, NDIG+1

             MB(J) = 0

          ENDDO

      ELSE

          NDIG = INT(MB(1)) + 1

          IF (NDIG < 2 .OR. NDIG > NDG2MX) NDIG = 2

          MB(NDIG+1) = 0

          DO J = INT(MA(1))+2, NDIG+1

             MA(J) = 0

          ENDDO

      ENDIF



!             FMADD2 will negate MB and add.



      KSUB = 1

      CALL FMADD2(MA,MB,MC)

      KSUB = 0



  120 IF (MC(1) > NDIGMX) THEN

          IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN

              IF (MC(2) > 0) THEN

                  CALL IMST2M('OVERFLOW',MC)

              ELSE

                  CALL IMST2M('-OVERFLOW',MC)

              ENDIF

              KFLAG = -5

              NAMEST(NCALL) = 'IMSUB '

              CALL FMWARN

          ENDIF

      ENDIF



  130 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



      DOUBLE PRECISION MA(0:LUNPCK),MP(0: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

      IF (MP(2) < 0) MA(2) = -MA(2)

      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

      DOUBLE PRECISION MA(0: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

      DOUBLE PRECISION MA(0:LPACK),MB(0: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

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMUNPK(MB,MPB)

      CALL IMADD(MPA,MPB,MPA)

      CALL IMPACK(MPA,MC)

      RETURN

      END SUBROUTINE IPADD

      SUBROUTINE IPBIG(MA)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0: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

      DOUBLE PRECISION MA(0:LPACK),MB(0: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

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMUNPK(MB,MPB)

      CALL IMDIM(MPA,MPB,MPA)

      CALL IMPACK(MPA,MC)

      RETURN

      END SUBROUTINE IPDIM

      SUBROUTINE IPDIV(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMUNPK(MB,MPB)

      CALL IMDIV(MPA,MPB,MPA)

      CALL IMPACK(MPA,MC)

      RETURN

      END SUBROUTINE IPDIV

      SUBROUTINE IPDIVI(MA,IVAL,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      INTEGER IVAL

      CALL IMUNPK(MA,MPA)

      CALL IMDIVI(MPA,IVAL,MPA)

      CALL IMPACK(MPA,MB)

      RETURN

      END SUBROUTINE IPDIVI

      SUBROUTINE IPDIVR(MA,MB,MC,MD)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK),  &

                       MD(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMUNPK(MB,MPB)

      CALL IMDIVR(MPA,MPB,MPA,MPB)

      CALL IMPACK(MPA,MC)

      CALL IMPACK(MPB,MD)

      RETURN

      END SUBROUTINE IPDIVR

      SUBROUTINE IPDVIR(MA,IVAL,MB,IREM)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      INTEGER IVAL,IREM

      CALL IMUNPK(MA,MPA)

      CALL IMDVIR(MPA,IVAL,MPA,IREM)

      CALL IMPACK(MPA,MB)

      RETURN

      END SUBROUTINE IPDVIR

      SUBROUTINE IPEQ(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0: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

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL IMFM2I(MPA,MPA)

      CALL IMPACK(MPA,MB)

      RETURN

      END SUBROUTINE IPFM2I

      SUBROUTINE IPFORM(FORM,MA,STRING)

      USE FMVALS

      IMPLICIT NONE

      CHARACTER(*) :: FORM,STRING

      DOUBLE PRECISION MA(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMFORM(FORM,MPA,STRING)

      RETURN

      END SUBROUTINE IPFORM

      SUBROUTINE IPFPRT(FORM,MA)

      USE FMVALS

      IMPLICIT NONE

      CHARACTER(*) :: FORM

      DOUBLE PRECISION MA(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMFPRT(FORM,MPA)

      RETURN

      END SUBROUTINE IPFPRT

      SUBROUTINE IPGCD(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMUNPK(MB,MPB)

      CALL IMGCD(MPA,MPB,MPA)

      CALL IMPACK(MPA,MC)

      RETURN

      END SUBROUTINE IPGCD

      SUBROUTINE IPI2FM(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMI2FM(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE IPI2FM

      SUBROUTINE IPI2M(IVAL,MA)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0: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)

      DOUBLE PRECISION MA(0:LPACK)

      CALL IMINP(LINE,MPA,LA,LB)

      CALL IMPACK(MPA,MA)

      RETURN

      END SUBROUTINE IPINP

      SUBROUTINE IPM2DP(MA,DVAL)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK)

      DOUBLE PRECISION DVAL

      CALL IMUNPK(MA,MPA)

      CALL IMM2DP(MPA,DVAL)

      RETURN

      END SUBROUTINE IPM2DP

      SUBROUTINE IPM2I(MA,IVAL)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK)

      INTEGER IVAL

      CALL IMUNPK(MA,MPA)

      CALL IMM2I(MPA,IVAL)

      RETURN

      END SUBROUTINE IPM2I

      SUBROUTINE IPMAX(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMUNPK(MB,MPB)

      CALL IMMAX(MPA,MPB,MPA)

      CALL IMPACK(MPA,MC)

      RETURN

      END SUBROUTINE IPMAX

      SUBROUTINE IPMIN(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMUNPK(MB,MPB)

      CALL IMMIN(MPA,MPB,MPA)

      CALL IMPACK(MPA,MC)

      RETURN

      END SUBROUTINE IPMIN

      SUBROUTINE IPMOD(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMUNPK(MB,MPB)

      CALL IMMOD(MPA,MPB,MPA)

      CALL IMPACK(MPA,MC)

      RETURN

      END SUBROUTINE IPMOD

      SUBROUTINE IPMPY(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMUNPK(MB,MPB)

      CALL IMMPY(MPA,MPB,MPA)

      CALL IMPACK(MPA,MC)

      RETURN

      END SUBROUTINE IPMPY

      SUBROUTINE IPMPYI(MA,IVAL,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      INTEGER IVAL

      CALL IMUNPK(MA,MPA)

      CALL IMMPYI(MPA,IVAL,MPA)

      CALL IMPACK(MPA,MB)

      RETURN

      END SUBROUTINE IPMPYI

      SUBROUTINE IPMPYM(MA,MB,MC,MD)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK),  &

                       MD(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMUNPK(MB,MPB)

      CALL IMUNPK(MC,MPC)

      CALL IMMPYM(MPA,MPB,MPC,MPC)

      CALL IMPACK(MPC,MD)

      RETURN

      END SUBROUTINE IPMPYM

      SUBROUTINE IPOUT(MA,LINE,LB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0: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

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK),  &

                       MD(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMUNPK(MB,MPB)

      CALL IMUNPK(MC,MPC)

      CALL IMPMOD(MPA,MPB,MPC,MPA)

      CALL IMPACK(MPA,MD)

      RETURN

      END SUBROUTINE IPPMOD

      SUBROUTINE IPPRNT(MA)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMPRNT(MPA)

      RETURN

      END SUBROUTINE IPPRNT

      SUBROUTINE IPPWR(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMUNPK(MB,MPB)

      CALL IMPWR(MPA,MPB,MPA)

      CALL IMPACK(MPA,MC)

      RETURN

      END SUBROUTINE IPPWR

      SUBROUTINE IPREAD(KREAD,MA)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK)

      INTEGER KREAD

      CALL IMREAD(KREAD,MPA)

      CALL IMPACK(MPA,MA)

      RETURN

      END SUBROUTINE IPREAD

      SUBROUTINE IPSIGN(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMUNPK(MB,MPB)

      CALL IMSIGN(MPA,MPB,MPA)

      CALL IMPACK(MPA,MC)

      RETURN

      END SUBROUTINE IPSIGN

      SUBROUTINE IPSQR(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0: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

      DOUBLE PRECISION MA(0:LPACK)

      CALL IMST2M(STRING,MPA)

      CALL IMPACK(MPA,MA)

      RETURN

      END SUBROUTINE IPST2M

      SUBROUTINE IPSUB(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL IMUNPK(MA,MPA)

      CALL IMUNPK(MB,MPB)

      CALL IMSUB(MPA,MPB,MPA)

      CALL IMPACK(MPA,MC)

      RETURN

      END SUBROUTINE IPSUB

      SUBROUTINE IPWRIT(KWRITE,MA)

      USE FMVALS

      IMPLICIT NONE

      INTEGER KWRITE

      DOUBLE PRECISION MA(0: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



      DOUBLE PRECISION MA(0:LUNPKZ),MBFM(0:LUNPCK)



!             Scratch array usage during ZMABS:   M01 - M02, MZ01



      DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXEXP1,MXSAVE

      INTEGER KASAVE,KOVUN,KRESLT,NDSAVE



      CALL ZMENTR('ZMABS ',MA,MA,1,MZ01,KRESLT,NDSAVE,MXSAVE,KASAVE,  &

                  KOVUN)

      IF (KRESLT /= 0) THEN

          CALL FMEQ(MZ01,MBFM)

          RETURN

      ENDIF

      MARZ = MA(0)

      MAIZ = MA(KPTIMU)

      KACCSW = 0

      CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1)



!             Check for special cases.



      MXEXP1 = INT(MXEXP2/2.01D0)

      IF (MA(2) == 0) THEN

          CALL FMABS(MA(KPTIMU),MBFM)

          GO TO 110

      ELSE IF (MA(KPTIMU+2) == 0) THEN

          CALL FMABS(MA,MBFM)

          GO TO 110

      ELSE IF (MA(1) == MEXPOV .OR. MA(KPTIMU+1) == MEXPOV) THEN

          CALL FMI2M(1,MBFM)

          MBFM(1) = MAX(MA(1),MA(KPTIMU+1))

          GO TO 110

      ELSE IF (MA(1) == MEXPUN) THEN

          IF (MA(KPTIMU+1) > -MXEXP1+NDIG+1) THEN

              CALL FMABS(MA(KPTIMU),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(MA,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(MA,MBFM)

              GO TO 110

          ELSE IF (MA(KPTIMU+1) > MA(1)+NDIG+1) THEN

              CALL FMABS(MA(KPTIMU),MBFM)

              GO TO 110

          ENDIF

      ENDIF



      CALL FMSQR(MA,M01)

      CALL FMSQR(MA(KPTIMU),M02)

      CALL FMADD(M01,M02,MBFM)

      CALL FMSQRT(MBFM,MBFM)



  110 MACCMB = MBFM(0)

      MA(0) = MARZ

      MA(KPTIMU) = MAIZ

      MBFM(0) = MIN(MACCMB,MARZ,MAIZ)

      CALL ZMEXI2(MBFM,MBFM,NDSAVE,MXSAVE,KASAVE,KOVUN,1)

      RETURN

      END SUBROUTINE ZMABS

      SUBROUTINE ZMACOS(MA,MB)



!  MB = ACOS(MA).



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



!             Scratch array usage during ZMACOS:  M01 - M06, MZ01 - MZ03



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)



!             Check for special cases.



      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN

          CALL FMPI(MZ01)

          CALL FMDIVI(MZ01,2,MZ01)

          CALL FMI2M(0,MZ01(KPTIMU))

          GO TO 110

      ELSE IF (MA(KPTIMU+2) == 0) THEN

          CALL FMACOS(MA,MZ01)

          IF (KFLAG == 0) THEN

              CALL FMI2M(0,MZ01(KPTIMU))

              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(MZ01,2,MZ01)

          CALL FMI2M(0,MZ01(KPTIMU))

          CALL ZMSUB(MZ01,MA,MZ01)

          GO TO 110

      ENDIF



      CALL ZMI2M(1,MZ03)

      CALL ZMSUB(MZ03,MA,MZ02)

      CALL ZMADD(MZ03,MA,MZ03)

      CALL ZMMPY(MZ02,MZ03,MZ02)

      CALL ZMSQRT(MZ02,MZ02)

      DO J = 0, NDIG+1

         MZ03(J) = MZ02(KPTIMU+J)

         MZ03(KPTIMU+J) = MZ02(J)

      ENDDO

      IF (MZ03(1) /= MUNKNO) MZ03(2) = -MZ03(2)



      IF ((MA(2) /= 0 .AND. MZ03(1) == MA(1) .AND.  &

           MZ03(2) == MA(2)) .OR.  &

          (MA(KPTIMU+2) /= 0 .AND. MZ03(KPTIMU+1) == MA(KPTIMU+1)  &

           .AND. MZ03(KPTIMU+2) == MA(KPTIMU+2)) ) THEN

          CALL ZMADD(MA,MZ03,MZ03)



          CALL FMSQR(MZ03,M04)

          CALL FMSQR(MZ03(KPTIMU),M05)

          CALL FMADD(M04,M05,M06)

          CALL FMI2M(1,M03)

          CALL FMSUB(M06,M03,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(MA,MA,NDSAVE,NDIG,1)

              CALL ZMI2M(1,MZ03)

              CALL ZMSUB(MZ03,MA,MZ02)

              CALL ZMADD(MZ03,MA,MZ03)

              CALL ZMMPY(MZ02,MZ03,MZ02)

              CALL ZMSQRT(MZ02,MZ02)

              DO J = 0, NDIG+1

                 MZ03(J) = MZ02(KPTIMU+J)

                 MZ03(KPTIMU+J) = MZ02(J)

              ENDDO

              IF (MZ03(1) /= MUNKNO) MZ03(2) = -MZ03(2)

              CALL ZMADD(MA,MZ03,MZ03)

          ENDIF



          CALL ZMLN(MZ03,MZ03)

          DO J = 0, NDIG+1

             MZ01(J) = MZ03(KPTIMU+J)

             MZ01(KPTIMU+J) = MZ03(J)

          ENDDO

          IF (MZ01(KPTIMU+1) /= MUNKNO) MZ01(KPTIMU+2) = -MZ01(KPTIMU+2)

      ELSE

          CALL ZMSUB(MA,MZ03,MZ03)



          CALL FMSQR(MZ03,M04)

          CALL FMSQR(MZ03(KPTIMU),M05)

          CALL FMADD(M04,M05,M06)

          CALL FMI2M(1,M03)

          CALL FMSUB(M06,M03,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(MA,MA,NDSAVE,NDIG,1)

              CALL ZMI2M(1,MZ03)

              CALL ZMSUB(MZ03,MA,MZ02)

              CALL ZMADD(MZ03,MA,MZ03)

              CALL ZMMPY(MZ02,MZ03,MZ02)

              CALL ZMSQRT(MZ02,MZ02)

              DO J = 0, NDIG+1

                 MZ03(J) = MZ02(KPTIMU+J)

                 MZ03(KPTIMU+J) = MZ02(J)

              ENDDO

              IF (MZ03(1) /= MUNKNO) MZ03(2) = -MZ03(2)

              CALL ZMSUB(MA,MZ03,MZ03)

          ENDIF



          CALL ZMLN(MZ03,MZ03)

          DO J = 0, NDIG+1

             MZ01(J) = MZ03(KPTIMU+J)

             MZ01(KPTIMU+J) = MZ03(J)

          ENDDO

          IF (MZ01(1) /= MUNKNO) MZ01(2) = -MZ01(2)

      ENDIF



  110 MACCMB = MZ01(0)

      MA(0) = MARZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,0)

      RETURN

      END SUBROUTINE ZMACOS

      SUBROUTINE ZMADD(MA,MB,MC)



!  MC = MA + MB



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ)



      INTEGER KASAVE,KF1,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV

      DOUBLE PRECISION 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

      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),MB(KPTIMU),MC(KPTIMU))



      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



      DOUBLE PRECISION MA(0:LUNPKZ)

      INTEGER INTEG



      INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV

      DOUBLE PRECISION MXSAVE



      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR.  &

          KDEBUG >= 1) THEN

          CALL ZMENTR('ZMADDI',MA,MA,1,MA,KRESLT,NDSAVE,MXSAVE,KASAVE,  &

                      KOVUN)

          IF (KRESLT /= 0) RETURN

          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



      DOUBLE PRECISION MA(0:LUNPKZ),MBFM(0:LUNPCK)



!             Scratch array usage during ZMARG:   M01 - M06, MZ01



      DOUBLE PRECISION MXSAVE

      INTEGER KASAVE,KOVUN,KRESLT,NDSAVE



      CALL ZMENTR('ZMARG ',MA,MA,1,MZ01,KRESLT,NDSAVE,MXSAVE,KASAVE,  &

                  KOVUN)

      IF (KRESLT /= 0) THEN

          CALL FMEQ(MZ01,MBFM)

          RETURN

      ENDIF

      KACCSW = 0

      CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1)



      CALL FMATN2(MA(KPTIMU),MA,MBFM)



      CALL ZMEXI2(MBFM,MBFM,NDSAVE,MXSAVE,KASAVE,KOVUN,1)

      RETURN

      END SUBROUTINE ZMARG

      SUBROUTINE ZMASIN(MA,MB)



!  MB = ASIN(MA).



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



!             Scratch array usage during ZMASIN:  M01 - M06, MZ01 - MZ03



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)



!             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(MA,MZ01)

          GO TO 110

      ELSE IF (MA(KPTIMU+2) == 0) THEN

          CALL FMASIN(MA,MZ01)

          IF (KFLAG == 0) THEN

              CALL FMI2M(0,MZ01(KPTIMU))

              GO TO 110

          ENDIF

      ENDIF



      CALL ZMI2M(1,MZ03)

      CALL ZMSUB(MZ03,MA,MZ02)

      CALL ZMADD(MZ03,MA,MZ03)

      CALL ZMMPY(MZ02,MZ03,MZ02)

      CALL ZMSQRT(MZ02,MZ02)

      DO J = 0, NDIG+1

         MZ03(J) = MA(KPTIMU+J)

         MZ03(KPTIMU+J) = MA(J)

      ENDDO

      IF (MZ03(1) /= MUNKNO) MZ03(2) = -MZ03(2)



      IF ((MZ02(2) /= 0 .AND. MZ03(1) == MZ02(1) .AND.  &

           MZ03(2) == MZ02(2)) .OR.  &

          (MZ02(KPTIMU+2) /= 0 .AND. MZ03(KPTIMU+1) == MZ02(KPTIMU+1)  &

           .AND. MZ03(KPTIMU+2) == MZ02(KPTIMU+2)) ) THEN

          CALL ZMADD(MZ02,MZ03,MZ03)



          CALL FMSQR(MZ03,M04)

          CALL FMSQR(MZ03(KPTIMU),M05)

          CALL FMADD(M04,M05,M06)

          CALL FMI2M(1,M03)

          CALL FMSUB(M06,M03,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(MA,MA,NDSAVE,NDIG,1)

              CALL ZMI2M(1,MZ03)

              CALL ZMSUB(MZ03,MA,MZ02)

              CALL ZMADD(MZ03,MA,MZ03)

              CALL ZMMPY(MZ02,MZ03,MZ02)

              CALL ZMSQRT(MZ02,MZ02)

              DO J = 0, NDIG+1

                 MZ03(J) = MA(KPTIMU+J)

                 MZ03(KPTIMU+J) = MA(J)

              ENDDO

              IF (MZ03(1) /= MUNKNO) MZ03(2) = -MZ03(2)

              CALL ZMADD(MZ02,MZ03,MZ03)

          ENDIF



          CALL ZMLN(MZ03,MZ03)

          DO J = 0, NDIG+1

             MZ01(J) = MZ03(KPTIMU+J)

             MZ01(KPTIMU+J) = MZ03(J)

          ENDDO

          IF (MZ01(KPTIMU+1) /= MUNKNO) MZ01(KPTIMU+2) = -MZ01(KPTIMU+2)

      ELSE

          CALL ZMSUB(MZ02,MZ03,MZ03)



          CALL FMSQR(MZ03,M04)

          CALL FMSQR(MZ03(KPTIMU),M05)

          CALL FMADD(M04,M05,M06)

          CALL FMI2M(1,M03)

          CALL FMSUB(M06,M03,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(MA,MA,NDSAVE,NDIG,1)

              CALL ZMI2M(1,MZ03)

              CALL ZMSUB(MZ03,MA,MZ02)

              CALL ZMADD(MZ03,MA,MZ03)

              CALL ZMMPY(MZ02,MZ03,MZ02)

              CALL ZMSQRT(MZ02,MZ02)

              DO J = 0, NDIG+1

                 MZ03(J) = MA(KPTIMU+J)

                 MZ03(KPTIMU+J) = MA(J)

              ENDDO

              IF (MZ03(1) /= MUNKNO) MZ03(2) = -MZ03(2)

              CALL ZMSUB(MZ02,MZ03,MZ03)

          ENDIF

          CALL ZMLN(MZ03,MZ03)

          DO J = 0, NDIG+1

             MZ01(J) = MZ03(KPTIMU+J)

             MZ01(KPTIMU+J) = MZ03(J)

          ENDDO

          IF (MZ01(1) /= MUNKNO) MZ01(2) = -MZ01(2)

      ENDIF



  110 MACCMB = MZ01(0)

      MA(0) = MARZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,0)

      RETURN

      END SUBROUTINE ZMASIN

      SUBROUTINE ZMATAN(MA,MB)



!  MB = ATAN(MA).



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



!             Scratch array usage during ZMATAN:  M01 - M06, MZ01 - MZ04



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)



!             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(MA,MZ04)

          GO TO 120

      ELSE IF (MA(KPTIMU+2) == 0) THEN

          CALL FMATAN(MA,MZ04)

          IF (KFLAG == 0) THEN

              CALL FMI2M(0,MZ04(KPTIMU))

              GO TO 120

          ENDIF

      ENDIF



      X = 1.0E+5

      CALL FMSP2M(X,M02)

      CALL FMABS(MA,M03)

      CALL FMABS(MA(KPTIMU),M04)

      CALL FMADD(M03,M04,M04)



      IF (FMCOMP(M04,'GE',M02)) THEN

          CALL ZMI2M(0,MZ04)

          CALL FMPI(MZ04)

          CALL FMDIVI(MZ04,2,MZ04)

          IF (MA(2) < 0) MZ04(2) = -MZ04(2)

          CALL ZMI2M(1,MZ02)

          CALL ZMDIV(MZ02,MA,MZ02)

          CALL ZMEQ(MZ02,MZ03)

          CALL ZMSUB(MZ04,MZ02,MZ04)

          IF (MA(1) > NDIG .OR. MA(KPTIMU+1) > NDIG) GO TO 120

          CALL ZMSQR(MZ02,MZ02)

          JTERM = 1

  110     CALL ZMMPY(MZ03,MZ02,MZ03)

          JTERM = JTERM + 2

          CALL FMEQ(MZ03,M05)

          CALL FMEQ(MZ03(KPTIMU),M06)

          CALL ZMDIVI(MZ03,JTERM,MZ03)

          CALL ZMADD(MZ04,MZ03,MZ04)

          IF (KFLAG /= 0) GO TO 120

          CALL FMEQ(M05,MZ03)

          CALL FMEQ(M06,MZ03(KPTIMU))

          CALL ZMMPY(MZ03,MZ02,MZ03)

          JTERM = JTERM + 2

          CALL FMEQ(MZ03,M05)

          CALL FMEQ(MZ03(KPTIMU),M06)

          CALL ZMDIVI(MZ03,JTERM,MZ03)

          CALL ZMSUB(MZ04,MZ03,MZ04)

          IF (KFLAG /= 0) GO TO 120

          CALL FMEQ(M05,MZ03)

          CALL FMEQ(M06,MZ03(KPTIMU))

          GO TO 110

      ELSE

          CALL ZM2I2M(0,1,MZ02)

          CALL ZMSUB(MZ02,MA,MZ03)

          CALL ZMADD(MZ02,MA,MZ02)

          CALL ZMDIV(MZ02,MZ03,MZ03)



          CALL FMSQR(MZ03,M04)

          CALL FMSQR(MZ03(KPTIMU),M05)

          CALL FMADD(M04,M05,M06)

          CALL FMI2M(1,M03)

          CALL FMSUB(M06,M03,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(MA,MA,NDSAVE,NDIG,1)

              CALL ZM2I2M(0,1,MZ02)

              CALL ZMSUB(MZ02,MA,MZ03)

              CALL ZMADD(MZ02,MA,MZ02)

              CALL ZMDIV(MZ02,MZ03,MZ03)

          ENDIF



          CALL ZMLN(MZ03,MZ03)

          CALL ZMDIVI(MZ03,2,MZ03)

          DO J = 0, NDIG+1

             MZ04(J) = MZ03(KPTIMU+J)

             MZ04(KPTIMU+J) = MZ03(J)

          ENDDO

          IF (MZ04(1) /= MUNKNO) MZ04(2) = -MZ04(2)

      ENDIF



  120 MACCMB = MZ04(0)

      MA(0) = MARZ

      MZ04(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ04(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ04(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      CALL ZMEXIT(MZ04,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,0)

      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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ)



!             Scratch array usage during ZMCHSH:  M01 - M06, MZ01 - MZ04



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)



!             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(MA,MZ01,MC)

          CALL FMI2M(0,MZ01(KPTIMU))

          CALL FMI2M(0,MC(KPTIMU))

          GO TO 110

      ELSE IF (MA(2) == 0) THEN

          CALL FMCSSN(MA(KPTIMU),MZ01,MC(KPTIMU))

          CALL FMI2M(0,MZ01(KPTIMU))

          CALL FMI2M(0,MC)

          GO TO 110

      ENDIF



!             Find SINH(REAL(MA)) and COSH(REAL(MA)).



      CALL FMCHSH(MA,MZ02,MZ02(KPTIMU))



!             Find SIN(IMAG(MA)) and COS(IMAG(MA)).



      CALL FMCSSN(MA(KPTIMU),MZ03,MZ03(KPTIMU))



!             COSH(MA) =  COSH(REAL(MA))*COS(IMAG(MA)) +

!                         SINH(REAL(MA))*SIN(IMAG(MA)) i



      CALL FMMPY(MZ02,MZ03,MZ01)

      CALL FMMPY(MZ02(KPTIMU),MZ03(KPTIMU),MZ01(KPTIMU))



!             SINH(MA) =  SINH(REAL(MA))*COS(IMAG(MA)) +

!                         COSH(REAL(MA))*SIN(IMAG(MA)) i



      CALL FMMPY(MZ02(KPTIMU),MZ03,MC)

      CALL FMMPY(MZ02,MZ03(KPTIMU),MC(KPTIMU))



  110 MACCMB = MZ01(0)

      MA(0) = MARZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      MC(0) = MZ01(0)

      MC(KPTIMU) = MZ01(KPTIMU)

      KACCSW = KASAVE

      CALL ZMEQ2(MC,MC,NDIG,NDSAVE,1)

      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,0)

      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



      DOUBLE PRECISION MAFM(0:LUNPCK),MBFM(0:LUNPCK),MC(0: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))



      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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0: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),MB(KPTIMU))

      IF (MB(KPTIMU+1) /= MUNKNO) MB(KPTIMU+2) = -MB(KPTIMU+2)



      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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



!             Scratch array usage during ZMCOS:   M01 - M06, MZ01 - MZ03



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)



!             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(MA,MZ01)

          CALL FMI2M(0,MZ01(KPTIMU))

          GO TO 110

      ELSE IF (MA(2) == 0) THEN

          CALL FMCOSH(MA(KPTIMU),MZ01)

          CALL FMI2M(0,MZ01(KPTIMU))

          GO TO 110

      ENDIF



!             Find COS(REAL(MA)) and SIN(REAL(MA)).



      CALL FMCSSN(MA,MZ01,MZ01(KPTIMU))



!             Find COSH(IMAG(MA)) and SINH(IMAG(MA)).



      CALL FMCHSH(MA(KPTIMU),M05,M06)



!             COS(MA) =  COS(REAL(MA))*COSH(IMAG(MA)) -

!                        SIN(REAL(MA))*SINH(IMAG(MA)) i



      CALL FMMPY(MZ01,M05,MZ01)

      IF (M06(1) /= MUNKNO) M06(2) = -M06(2)

      CALL FMMPY(MZ01(KPTIMU),M06,MZ01(KPTIMU))



  110 MACCMB = MZ01(0)

      MA(0) = MARZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,0)

      KRAD = KRSAVE

      RETURN

      END SUBROUTINE ZMCOS

      SUBROUTINE ZMCOSH(MA,MB)



!  MB = COSH(MA).



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



!             Scratch array usage during ZMCOSH:  M01 - M06, MZ01 - MZ03



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)



!             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(MA(KPTIMU),MZ01)

          CALL FMI2M(0,MZ01(KPTIMU))

          GO TO 110

      ELSE IF (MA(KPTIMU+2) == 0) THEN

          CALL FMCOSH(MA,MZ01)

          CALL FMI2M(0,MZ01(KPTIMU))

          GO TO 110

      ENDIF



!             Find COS(IMAG(MA)) and SIN(IMAG(MA)).



      CALL FMCSSN(MA(KPTIMU),MZ01,MZ01(KPTIMU))



!             Find COSH(REAL(MA)) and SINH(REAL(MA)).



      CALL FMCHSH(MA,M05,M06)



!             COSH(MA) =  COSH(REAL(MA))*COS(IMAG(MA)) +

!                         SINH(REAL(MA))*SIN(IMAG(MA)) i



      CALL FMMPY(MZ01,M05,MZ01)

      CALL FMMPY(MZ01(KPTIMU),M06,MZ01(KPTIMU))



  110 MACCMB = MZ01(0)

      MA(0) = MARZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,0)

      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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ)



!             Scratch array usage during ZMCSSN:  M01 - M06, MZ01 - MZ04



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)



!             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(MA,MZ01,MC)

          CALL FMI2M(0,MZ01(KPTIMU))

          CALL FMI2M(0,MC(KPTIMU))

          GO TO 110

      ELSE IF (MA(2) == 0) THEN

          CALL FMCHSH(MA(KPTIMU),MZ01,MC(KPTIMU))

          CALL FMI2M(0,MZ01(KPTIMU))

          CALL FMI2M(0,MC)

          GO TO 110

      ENDIF



!             Find SIN(REAL(MA)) and COS(REAL(MA)).



      CALL FMCSSN(MA,MZ02,MZ02(KPTIMU))



!             Find SINH(IMAG(MA)) and COSH(IMAG(MA)).



      CALL FMCHSH(MA(KPTIMU),MZ03,MZ03(KPTIMU))



!             COS(MA) =  COS(REAL(MA))*COSH(IMAG(MA)) -

!                        SIN(REAL(MA))*SINH(IMAG(MA)) i



      CALL FMMPY(MZ02,MZ03,MZ01)

      CALL FMMPY(MZ02(KPTIMU),MZ03(KPTIMU),MZ01(KPTIMU))

      IF (MZ01(KPTIMU+1) /= MUNKNO) MZ01(KPTIMU+2) = -MZ01(KPTIMU+2)



!             SIN(MA) =  SIN(REAL(MA))*COSH(IMAG(MA)) +

!                        COS(REAL(MA))*SINH(IMAG(MA)) i



      CALL FMMPY(MZ02(KPTIMU),MZ03,MC)

      CALL FMMPY(MZ02,MZ03(KPTIMU),MC(KPTIMU))



  110 MACCMB = MZ01(0)

      MA(0) = MARZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      MC(0) = MZ01(0)

      MC(KPTIMU) = MZ01(KPTIMU)

      KACCSW = KASAVE

      CALL ZMEQ2(MC,MC,NDIG,NDSAVE,1)

      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,0)

      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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ)



!             Scratch array usage during ZMDIV:   M01 - M04, MZ01



      DOUBLE PRECISION MACCMB,MAIZ,MARZ,MBIZ,MBRZ,MXSAVE,MZ11SV,MZ1KSV,  &

                       MZERO

      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)

      MZERO = 0

      NTRSAV = NTRACE

      NTRACE = 0

      KWRNSV = KWARN

      KWARN = 0

      IEXTRA = 0

      MZ11SV = -MUNKNO

      MZ1KSV = -MUNKNO



  110 DO J = NDSAVE+2, NDIG+1

         MA(J) = MZERO

         MB(J) = MZERO

         MA(KPTIMU+J) = MZERO

         MB(KPTIMU+J) = MZERO

      ENDDO

      IF (NCALL == 1) THEN

          MA(0) = NINT(NDIG*ALOGM2)

          MB(0) = MA(0)

          MA(KPTIMU) = MA(0)

          MB(KPTIMU) = MA(0)

      ENDIF



!             Check for special cases.



      IF (MB(KPTIMU+2) == 0) THEN

          CALL FMDIVD(MA,MA(KPTIMU),MB,MZ01,MZ01(KPTIMU))

          GO TO 130

      ELSE IF (MB(2) == 0) THEN

          CALL FMDIVD(MA(KPTIMU),MA,MB(KPTIMU),MZ01,MZ01(KPTIMU))

          IF (MZ01(KPTIMU+1) /= MUNKNO) MZ01(KPTIMU+2) = -MZ01(KPTIMU+2)

          GO TO 130

      ENDIF

      IF (MA(1) == MB(1) .AND. MA(2) == MB(2)) THEN

          IF (MA(KPTIMU+1) == MB(KPTIMU+1) .AND.  &

              MA(KPTIMU+2) == MB(KPTIMU+2)) 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)) THEN

          IF (MA(KPTIMU+1) == MB(KPTIMU+1) .AND.  &

              (-MA(KPTIMU+2)) == MB(KPTIMU+2)) 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(MB,MA,MA(KPTIMU),MB,MZ01,MZ01(KPTIMU),M03)

          CALL FMMPYE(MB(KPTIMU),MA(KPTIMU),MA,MB(KPTIMU),M01,M02,M04)

          CALL FMADD(M03,M04,M04)

          CALL FMADD(MZ01,M01,MZ01)

          CALL FMSUB(MZ01(KPTIMU),M02,MZ01(KPTIMU))

          CALL FMDIVD(MZ01,MZ01(KPTIMU),M04,MZ01,MZ01(KPTIMU))

          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(MB,MB(KPTIMU),M04)

          CALL FMMPYE(M04,MA,MA(KPTIMU),MB,MZ01,MZ01(KPTIMU),M03)

          IF (MA(KPTIMU+2)*MZ01(2) < 0) THEN

              KACCSW = 1

          ELSE

              KACCSW = 0

          ENDIF

          CALL FMADD(MA(KPTIMU),MZ01,MZ01)

          IF (M03(2)*MB(KPTIMU+2) < 0) THEN

              KACCSW = 1

          ELSE

              KACCSW = 0

          ENDIF

          CALL FMADD(M03,MB(KPTIMU),M03)

          IF (MZ01(KPTIMU+2)*MA(2) < 0) THEN

              KACCSW = 0

          ELSE

              KACCSW = 1

          ENDIF

          CALL FMSUB(MZ01(KPTIMU),MA,MZ01(KPTIMU))

          KACCSW = 0

          CALL FMDIVD(MZ01,MZ01(KPTIMU),M03,MZ01,MZ01(KPTIMU))

      ELSE

          CALL FMDIV(MB(KPTIMU),MB,M04)

          CALL FMMPYE(M04,MA(KPTIMU),MA,MB(KPTIMU),  &

                      MZ01,MZ01(KPTIMU),M03)

          IF (MA(2)*MZ01(2) < 0) THEN

              KACCSW = 1

          ELSE

              KACCSW = 0

          ENDIF

          CALL FMADD(MA,MZ01,MZ01)

          IF (M03(2)*MB(2) < 0) THEN

              KACCSW = 1

          ELSE

              KACCSW = 0

          ENDIF

          CALL FMADD(M03,MB,M03)

          IF (MZ01(KPTIMU+2)*MA(KPTIMU+2) < 0) THEN

              KACCSW = 0

          ELSE

              KACCSW = 1

          ENDIF

          CALL FMSUB(MA(KPTIMU),MZ01(KPTIMU),MZ01(KPTIMU))

          KACCSW = 0

          CALL FMDIVD(MZ01,MZ01(KPTIMU),M03,MZ01,MZ01(KPTIMU))

      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)

      MA(0) = MARZ

      MB(0) = MBRZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MB(KPTIMU) = MBIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)

      CALL ZMEQ2(MZ01,MC,NDGSV2,NDSAVE,0)

      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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)

      INTEGER INTEG



      INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV

      DOUBLE PRECISION MXSAVE



      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR.  &

          KDEBUG >= 1) THEN

          CALL ZMENTR('ZMDIVI',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &

                      KOVUN)

          IF (KRESLT /= 0) RETURN

          NDIG = NDSAVE

          MXEXP = MXSAVE

          KACCSW = KASAVE

          NTRSAV = NTRACE

      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),INTEG,MB(KPTIMU))



      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

      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ),MXSAVE

      INTEGER NARGS,KRESLT,NDSAVE,KASAVE,KOVUN



      DOUBLE PRECISION 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

              CALL ZMST2M('UNKNOWN+UNKNOWN*i',MA)

              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

              CALL ZMST2M('UNKNOWN+UNKNOWN*i',MA)

              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

                  CALL ZMST2M('UNKNOWN+UNKNOWN*i',MB)

                  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

                  CALL ZMST2M('UNKNOWN+UNKNOWN*i',MB)

                  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) <= (-MBASE) .OR. MA(2) >= MBASE .OR.  &

          ABS(MA(2)-INT(MA(2))) /= 0) KFLAG = 2

      IF (MA(KPTIMU+2) <= (-MBASE) .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

          CALL ZMST2M('UNKNOWN+UNKNOWN*i',MA)

          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) <= (-MBASE) .OR. MB(2) >= MBASE .OR.  &

              ABS(MB(2)-INT(MB(2))) /= 0) KFLAG = 2

          IF (MB(KPTIMU+2) <= (-MBASE) .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

              CALL ZMST2M('UNKNOWN+UNKNOWN*i',MB)

              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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



      CALL FMEQ(MA,MB)

      CALL FMEQ(MA(KPTIMU),MB(KPTIMU))

      RETURN

      END SUBROUTINE ZMEQ

      SUBROUTINE ZMEQ2(MA,MB,NDA,NDB,KSAME)



!  Set MB (having NDB digits) equal to MA (having NDA digits).



!  If MA and MB are the same array, setting KSAME = 1 before calling

!  ZMEQ2 gives faster performance.



!  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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)

      INTEGER NDA,NDB,KSAME



      CALL FMEQ2(MA,MB,NDA,NDB,KSAME)

      CALL FMEQ2(MA(KPTIMU),MB(KPTIMU),NDA,NDB,KSAME)

      RETURN

      END SUBROUTINE ZMEQ2

      SUBROUTINE ZMEQU(MA,MB,NDA,NDB)



!  Set MB (having NDB digits) equal to MA (having NDA digits).



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)

      INTEGER NDA,NDB



      CALL FMEQ2(MA,MB,NDA,NDB,0)

      CALL FMEQ2(MA(KPTIMU),MB(KPTIMU),NDA,NDB,0)

      RETURN

      END SUBROUTINE ZMEQU

      SUBROUTINE ZMEXIT(MT,MC,NDSAVE,MXSAVE,KASAVE,KOVUN,KSAME)



!  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.

!  KSAME is 1 if MT and MC are the same array in the calling routine.

!  KOVUN is nonzero if one of the routine's input arguments was overflow

!  or underflow.



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MT(0:LUNPKZ),MC(0:LUNPKZ),MXSAVE

      INTEGER NDSAVE,KASAVE,KOVUN,KSAME



      INTEGER KFSAVE,KWRNSV



      KWRNSV = KWARN

      KWARN = 0

      MXEXP = MXSAVE

      KFSAVE = KFLAG

      KACCSW = KASAVE

      CALL ZMEQ2(MT,MC,NDIG,NDSAVE,KSAME)

      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(MTFM,MCFM,NDSAVE,MXSAVE,KASAVE,KOVUN,KSAME)



!  This routine is used upon exit for complex functions that

!  return real FM results.



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MTFM(0:LUNPCK),MCFM(0:LUNPCK),MXSAVE

      INTEGER NDSAVE,KASAVE,KOVUN,KSAME



      INTEGER KFSAVE,KWRNSV



      KWRNSV = KWARN

      KWARN = 0

      MXEXP = MXSAVE

      KFSAVE = KFLAG

      KACCSW = KASAVE

      CALL FMEQ2(MTFM,MCFM,NDIG,NDSAVE,KSAME)

      IF (KFLAG /= -5 .AND. KFLAG /= -6) KFLAG = KFSAVE

      NDIG = NDSAVE

      KWARN = KWRNSV

      IF (KFLAG == 1) KFLAG = 0

      IF (MCFM(1) == MUNKNO) THEN

          IF (KFLAG >= 0) KFLAG = -4

      ELSE IF (MCFM(1) == MEXPOV) THEN

          KFLAG = -5

      ELSE IF (MCFM(1) == MEXPUN) THEN

          KFLAG = -6

      ENDIF

      IF ((MCFM(1) == MUNKNO .AND. KFLAG /= -9)  &

         .OR. (MCFM(1) == MEXPUN .AND. KOVUN == 0)  &

         .OR. (MCFM(1) == MEXPOV .AND. KOVUN == 0)) CALL ZMWARN

      IF (NTRACE /= 0) CALL ZMNTR2(1,MCFM,MCFM,1)

      NCALL = NCALL - 1

      RETURN

      END SUBROUTINE ZMEXI2

      SUBROUTINE ZMEXP(MA,MB)



!  MB = EXP(MA).



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



!             Scratch array usage during ZMEXP:   M01 - M06, MZ01



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)



!             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(MA,M06)

      ENDIF



      CALL FMCSSN(MA(KPTIMU),MZ01,MZ01(KPTIMU))



      KWRNSV = KWARN

      KWARN = 0

      CALL FMMPYD(M06,MZ01,MZ01(KPTIMU),MZ01,MZ01(KPTIMU))

      KWARN = KWRNSV



  110 MACCMB = MZ01(0)

      MA(0) = MARZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,0)

      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

      DOUBLE PRECISION MA(0:LUNPKZ)



      INTEGER J,KWIDIM,KWIDRE,LAST,LSIGN



      NCALL = NCALL + 1

      NAMEST(NCALL) = 'ZMFORM'

      STRING = ' '

      CALL ZMFPCM(FORM1,MA,KWIDRE,CMBUFZ)

      CALL FMEQ(MA(KPTIMU),M02)

      IF (M02(2) >= 0) THEN

          LSIGN = 1

      ELSE

          LSIGN = -1

          M02(2) = -M02(2)

      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 (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

      DOUBLE PRECISION MA(0: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

      DOUBLE PRECISION MA(0: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),M02)

      IF (M02(2) >= 0) THEN

          LSIGN = 1

      ELSE

          LSIGN = -1

          M02(2) = -M02(2)

      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) = ' '

                 GO TO 110

             ENDIF

          ENDDO

      ENDIF



  110 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

      DOUBLE PRECISION MA(0:LUNPKZ)



      NCALL = NCALL + 1

      NAMEST(NCALL) = 'ZMI2M '

      IF (NTRACE /= 0) CALL ZMNTRI(2,INTEG,1)



      CALL FMI2M(INTEG,MA)

      CALL FMI2M(0,MA(KPTIMU))



      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

      DOUBLE PRECISION MA(0: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))



      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



      DOUBLE PRECISION MA(0:LUNPKZ),MBFM(0:LUNPCK)



      KFLAG = 0

      NCALL = NCALL + 1

      NAMEST(NCALL) = 'ZMIMAG'

      IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)



      CALL FMEQ(MA(KPTIMU),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)

      DOUBLE PRECISION MA(0:LUNPKZ)



!             Scratch array usage during ZMINP:   M01 - M05



      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(0) = NINT(NDSAVE*ALOGM2)

              MA(1) = MUNKNO

              MA(2) = 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))

          ELSE

              CALL FMINP(LINE,MA(KPTIMU),KSTRTI,KSTOPI)

          ENDIF

      ELSE IF (KIFLAG == 1) THEN

          CALL FMIM(1,MA(KPTIMU))

      ELSE

          CALL FMIM(0,MA(KPTIMU))

      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(0) = NINT(NDIG*ALOGM2)

      MA(1) = MUNKNO

      MA(2) = 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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



      NCALL = NCALL + 1

      NAMEST(NCALL) = 'ZMINT '

      IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)



      CALL FMINT(MA,MB)

      CALL FMINT(MA(KPTIMU),MB(KPTIMU))



      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

      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



!             Scratch array usage during ZMIPWR:  M01 - M03, MZ01 - MZ02



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)

              CALL ZMDIV(MZ02,MA,MB)

              CALL ZMEQ2(MB,MB,NDIG,NDSAVE,1)

              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))

          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),IVAL,MB)

              CALL FMIM(0,MB(KPTIMU))

          ELSE IF (I2N == 1) THEN

              CALL FMIPWR(MA(KPTIMU),IVAL,MB(KPTIMU))

              CALL FMIM(0,MB)

          ELSE IF (I2N == 2) THEN

              CALL FMIPWR(MA(KPTIMU),IVAL,MB)

              CALL FMIM(0,MB(KPTIMU))

              IF (MB(1) /= MUNKNO) MB(2) = -MB(2)

          ELSE IF (I2N == 3) THEN

              CALL FMIPWR(MA(KPTIMU),IVAL,MB(KPTIMU))

              CALL FMIM(0,MB)

              IF (MB(KPTIMU+1) /= MUNKNO) MB(KPTIMU+2) = -MB(KPTIMU+2)

          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,0)



      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,MZ02)

      IF (MOD(K,2) == 1) CALL ZMMPY(MZ02,MB,MB)

      IF (K > 1) GO TO 110



!             Invert if the exponent is negative.



      IF (IVAL < 0) THEN

          CALL ZMI2M(1,MZ02)

          CALL ZMDIV(MZ02,MB,MB)

      ENDIF

      KWARN = KWRNSV



!             Round the result and return.



      MACCMB = MB(0)

      MA(0) = MARZ

      MB(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MB(KPTIMU)

      MA(KPTIMU) = MAIZ

      MB(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      CALL ZMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,1)

      RETURN

      END SUBROUTINE ZMIPWR

      SUBROUTINE ZMLG10(MA,MB)



!  MB = LOG10(MA).



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



!             Scratch array usage during ZMLG10:  M01 - M05, MZ01 - MZ02



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)

      CALL ZMLN(MA,MZ02)

      CALL FMLNI(10,M03)

      CALL FMDIVD(MZ02,MZ02(KPTIMU),M03,MZ01,MZ01(KPTIMU))



      MACCMB = MZ01(0)

      MA(0) = MARZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,0)

      KRAD = KRSAVE

      RETURN

      END SUBROUTINE ZMLG10

      SUBROUTINE ZMLN(MA,MB)



!  MB = LN(MA).



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



!             Scratch array usage during ZMLN:   M01 - M05, MZ01



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)



!             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(2) < 0) THEN

              CALL FMEQ(MA,MZ01)

              IF (MZ01(1) /= MUNKNO) MZ01(2) = -MZ01(2)

              CALL FMLN(MZ01,MZ01)

              CALL FMPI(MZ01(KPTIMU))

          ELSE

              CALL FMLN(MA,MZ01)

              CALL FMI2M(0,MZ01(KPTIMU))

          ENDIF

          GO TO 110

      ELSE IF (MA(2) == 0) THEN

          IF (MA(KPTIMU+2) < 0) THEN

              CALL FMEQ(MA(KPTIMU),MZ01)

              IF (MZ01(1) /= MUNKNO) MZ01(2) = -MZ01(2)

              CALL FMLN(MZ01,MZ01)

              CALL FMPI(MZ01(KPTIMU))

              CALL FMDIVI(MZ01(KPTIMU),-2,MZ01(KPTIMU))

          ELSE

              CALL FMLN(MA(KPTIMU),MZ01)

              CALL FMPI(MZ01(KPTIMU))

              CALL FMDIVI(MZ01(KPTIMU),2,MZ01(KPTIMU))

          ENDIF

          GO TO 110

      ENDIF



!             Ln(a + b i) = Ln(Abs(a + b i)) + Arg(a + b i) i.



      CALL FMABS(MA,M03)

      CALL FMABS(MA(KPTIMU),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(MA,M05,M03)

          CALL FMADD(MA,M05,M04)

          CALL FMMPY(M03,M04,M03)

          CALL FMSQR(MA(KPTIMU),M04)

          CALL FMADD(M03,M04,M04)

      ELSE

          CALL FMSUB(MA(KPTIMU),M05,M03)

          CALL FMADD(MA(KPTIMU),M05,M04)

          CALL FMMPY(M03,M04,M03)

          CALL FMSQR(MA,M04)

          CALL FMADD(M03,M04,M04)

      ENDIF

      CALL ZMABS(MA,MZ01)

      CALL FMADD(MZ01,M05,M03)

      CALL FMDIV(M04,M03,M03)

      IF (KF1 == 1) THEN

          CALL FMEQ(M03,MZ01)

          CALL FMATN2(MA(KPTIMU),MA,MZ01(KPTIMU))

          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(MA,MA,NDSAVE,NDIG,1)

          CALL ZMABS(MA,MZ01)

      ENDIF



      CALL FMLN(MZ01,MZ01)

      CALL FMATN2(MA(KPTIMU),MA,MZ01(KPTIMU))



  110 MACCMB = MZ01(0)

      MA(0) = MARZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,0)

      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



      DOUBLE PRECISION MA(0: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



      DOUBLE PRECISION MA(0: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),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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ)



!             Scratch array usage during ZMMPY:   M01 - M03, MZ01



      DOUBLE PRECISION MACCMB,MAIZ,MARZ,MBIZ,MBRZ,MXSAVE,MZERO,MZ11SV

      INTEGER IEXTRA,J,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

      MZERO = 0

      NTRSAV = NTRACE

      NTRACE = 0

      KWRNSV = KWARN

      KWARN = 0



  110 DO J = NDSAVE+2, NDIG+1

         MA(J) = MZERO

         MB(J) = MZERO

         MA(KPTIMU+J) = MZERO

         MB(KPTIMU+J) = MZERO

      ENDDO

      IF (NCALL == 1) THEN

          MA(0) = NINT(NDIG*ALOGM2)

          MB(0) = MA(0)

          MA(KPTIMU) = MA(0)

          MB(KPTIMU) = MA(0)

      ENDIF



!             Check for special cases.



      KMETHD = 1

      IF (NDIG >= 35) KMETHD = 2



      IF (MB(KPTIMU+2) == 0) THEN

          CALL FMMPYD(MB,MA,MA(KPTIMU),MZ01,MZ01(KPTIMU))

      ELSE IF (MB(2) == 0) THEN

          CALL FMMPYD(MB(KPTIMU),MA(KPTIMU),MA,MZ01,MZ01(KPTIMU))

          IF (MZ01(1) /= MUNKNO) MZ01(2) = -MZ01(2)

      ELSE IF (MA(KPTIMU+2) == 0) THEN

          CALL FMMPYD(MA,MB,MB(KPTIMU),MZ01,MZ01(KPTIMU))

      ELSE IF (MA(2) == 0) THEN

          CALL FMMPYD(MA(KPTIMU),MB(KPTIMU),MB,MZ01,MZ01(KPTIMU))

          IF (MZ01(1) /= MUNKNO) MZ01(2) = -MZ01(2)

      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(MA,MB,MB(KPTIMU),MZ01,MZ01(KPTIMU))

          CALL FMMPYD(MA(KPTIMU),MB(KPTIMU),MB,M01,M02)

          IF (MZ01(2)*M01(2) < 0) THEN

              KACCSW = 0

          ELSE

              KACCSW = 1

          ENDIF

          CALL FMSUB(MZ01,M01,MZ01)

          IF (MZ01(KPTIMU+2)*M02(2) < 0) THEN

              KACCSW = 1

          ELSE

              KACCSW = 0

          ENDIF

          CALL FMADD(MZ01(KPTIMU),M02,MZ01(KPTIMU))

          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(MA,MA(KPTIMU),M01)

          CALL FMADD(MB,MB(KPTIMU),M02)

          CALL FMMPY(M01,M02,M01)



          CALL FMMPY(MA,MB,M02)

          CALL FMMPY(MA(KPTIMU),MB(KPTIMU),M03)



          CALL FMSUB(M02,M03,MZ01)

          CALL FMSUB(M01,M02,MZ01(KPTIMU))

          CALL FMSUB(MZ01(KPTIMU),M03,MZ01(KPTIMU))

      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)

      MA(0) = MARZ

      MB(0) = MBRZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MB(KPTIMU) = MBIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)

      CALL ZMEQ2(MZ01,MC,NDGSV2,NDSAVE,0)

      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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)

      INTEGER INTEG



      INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV

      DOUBLE PRECISION MXSAVE



      IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR.  &

          KDEBUG >= 1) THEN

          CALL ZMENTR('ZMMPYI',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &

                      KOVUN)

          IF (KRESLT /= 0) RETURN

          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),INTEG,MB(KPTIMU))



      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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



      NCALL = NCALL + 1

      NAMEST(NCALL) = 'ZMNINT'

      IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)



      CALL FMNINT(MA,MB)

      CALL FMNINT(MA(KPTIMU),MB(KPTIMU))



      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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0: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



      DOUBLE PRECISION MAFM(0:LUNPCK),MBFM(0: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



      DOUBLE PRECISION MA(0: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(J)),J=1,N1)

      WRITE (KW,FORM) (INT(MA(J+KPTIMU)),J=1,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



      DOUBLE PRECISION MA(0:LUNPKZ)

      INTEGER LB,LAST1,LAST2

      CHARACTER LINE(LB)



      DOUBLE PRECISION MAIM2

      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 MAIM2 = MA(KPTIMU+2)

      LINE(LAST1+1) = ' '

      IF (JFORMZ == 3) THEN

          LINE(LAST1+2) = ','

      ELSE

          IF (MAIM2 < 0) THEN

              MA(KPTIMU+2) = -MA(KPTIMU+2)

              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(MA(KPTIMU),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



      MA(KPTIMU+2) = MAIM2

      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



      DOUBLE PRECISION MA(0:LUNPKZ),MP(0:LPACKZ)

      CALL FMPACK(MA,MP)

      CALL FMPACK(MA(KPTIMU),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



      DOUBLE PRECISION MA(0: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))

      ENDIF

      KFLAG = KSAVE

      RETURN

      END SUBROUTINE ZMPRNT

      SUBROUTINE ZMPWR(MA,MB,MC)



!  MC = MA ** MB.



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ)



!             Scratch array usage during ZMPWR:   M01 - M06, MZ01 - MZ03



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)

      CALL ZMEQ2(MB,MB,NDSAVE,NDIG,1)



!             Check for special cases.



      IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN

          IF (MB(2) > 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(MB,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',MB)

                      IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,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(MA,MA,NDSAVE,NDIG,1)

              CALL ZMIPWR(MA,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(MA,M03)

      CALL FMABS(MA(KPTIMU),M04)

      CALL FMI2M(1,M05)

      IF (FMCOMP(M03,'EQ',M05) .AND.  &

          (M04(1) <= (-NDIG).OR.M04(2) == 0)) THEN

          IF (MA(2) > 0) THEN



!                 (1+c)**b = 1 + b*c + ...



              CALL ZMI2M(1,MZ02)

              CALL ZMSUB(MA,MZ02,MZ02)

              CALL ZMMPY(MB,MZ02,MZ02)

              CALL FMADD(MZ02,M05,MZ02)

          ELSE



!                 (-1+c)**b = (-1)**b * (1 - b*c + ... )



              CALL ZMI2M(-1,MZ02)

              CALL ZMSUB(MA,MZ02,MZ02)

              CALL ZMMPY(MB,MZ02,MZ02)

              CALL ZMMPYI(MZ02,-1,MZ02)

              CALL FMADD(MZ02,M05,MZ02)

              KRADSV = KRAD

              KRAD = 0

              IF (MA(KPTIMU+2) >= 0) THEN

                  CALL FMMPYI(MB,180,M06)

              ELSE

                  CALL FMMPYI(MB,-180,M06)

              ENDIF

              CALL FMCSSN(M06,MZ03,MZ03(KPTIMU))

              KRAD = KRADSV

              CALL FMPI(M05)

              CALL FMMPY(M05,MB(KPTIMU),M05)

              IF (MA(KPTIMU+2) >= 0) CALL FMMPYI(M05,-1,M05)

              CALL FMEXP(M05,M05)

              CALL FMMPYD(M05,MZ03,MZ03(KPTIMU),MZ03,MZ03(KPTIMU))

              CALL ZMMPY(MZ02,MZ03,MZ02)

          ENDIF

          GO TO 110

      ENDIF

      IF (FMCOMP(M04,'EQ',M05) .AND.  &

          (M03(1) <= (-NDIG).OR.M03(2) == 0)) THEN

          IF (MA(KPTIMU+2) > 0) THEN



!                 (i+c)**b = i**b * (1 - b*c*i - ... )



              CALL ZM2I2M(0,1,MZ02)

              CALL ZMSUB(MA,MZ02,MZ02)

              CALL ZMMPY(MB,MZ02,MZ02)

              DO J = 0, NDIG+1

                 MTEMP = MZ02(J)

                 MZ02(J) = MZ02(KPTIMU+J)

                 MZ02(KPTIMU+J) = MTEMP

              ENDDO

              IF (MZ02(KPTIMU+1) /= MUNKNO)  &

                  MZ02(KPTIMU+2) = -MZ02(KPTIMU+2)

              CALL FMADD(MZ02,M05,MZ02)

              KRADSV = KRAD

              KRAD = 0

              CALL FMMPYI(MB,90,M06)

              CALL FMCSSN(M06,MZ03,MZ03(KPTIMU))

              KRAD = KRADSV

              CALL FMPI(M05)

              CALL FMMPY(M05,MB(KPTIMU),M05)

              CALL FMDIVI(M05,-2,M05)

              CALL FMEXP(M05,M05)

              CALL FMMPYD(M05,MZ03,MZ03(KPTIMU),MZ03,MZ03(KPTIMU))

              CALL ZMMPY(MZ02,MZ03,MZ02)

          ELSE



!                 (-i+c)**b = (-i)**b * (1 + b*c*i - ... )



              CALL ZM2I2M(0,-1,MZ02)

              CALL ZMSUB(MA,MZ02,MZ02)

              CALL ZMMPY(MB,MZ02,MZ02)

              DO J = 0, NDIG+1

                 MTEMP = MZ02(J)

                 MZ02(J) = MZ02(KPTIMU+J)

                 MZ02(KPTIMU+J) = MTEMP

              ENDDO

              IF (MZ02(1) /= MUNKNO) MZ02(2) = -MZ02(2)

              CALL FMADD(MZ02,M05,MZ02)

              KRADSV = KRAD

              KRAD = 0

              CALL FMMPYI(MB,-90,M06)

              CALL FMCSSN(M06,MZ03,MZ03(KPTIMU))

              KRAD = KRADSV

              CALL FMPI(M05)

              CALL FMMPY(M05,MB(KPTIMU),M05)

              CALL FMDIVI(M05,2,M05)

              CALL FMEXP(M05,M05)

              CALL FMMPYD(M05,MZ03,MZ03(KPTIMU),MZ03,MZ03(KPTIMU))

              CALL ZMMPY(MZ02,MZ03,MZ02)

          ENDIF

          GO TO 110

      ENDIF



      CALL ZMLN(MA,MZ02)

      CALL ZMMPY(MB,MZ02,MZ02)

      KWRNSV = KWARN

      KWARN = 0

      CALL FMRDC(MZ02(KPTIMU),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(MA,MA,NDSAVE,NDIG,1)

          CALL ZMEQ2(MB,MB,NDSAVE,NDIG,1)

          CALL ZMLN(MA,MZ02)

          CALL ZMMPY(MB,MZ02,MZ02)

      ENDIF



      CALL ZMEXP(MZ02,MZ02)



  110 MACCMB = MZ02(0)

      MA(0) = MARZ

      MB(0) = MBRZ

      MZ02(0) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)

      MACCMB = MZ02(KPTIMU)

      MA(KPTIMU) = MAIZ

      MB(KPTIMU) = MBIZ

      MZ02(KPTIMU) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)

      CALL ZMEXIT(MZ02,MC,NDSAVE,MXSAVE,KASAVE,KOVUN,0)

      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

      DOUBLE PRECISION MA(0: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



      DOUBLE PRECISION MA(0:LUNPKZ),MBFM(0: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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)

      INTEGER IVAL,JVAL



!             Scratch array usage during ZMRPWR:  M01 - M03, MZ01 - MZ04



      DOUBLE PRECISION 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,0)

      IF (IVAL2 == 1 .AND. JVAL2 == 2) THEN

          CALL ZMSQRT(MZ04,MB)

          GO TO 110

      ENDIF



!             Generate the first approximation to MA**(1/JVAL2).



      CALL ZMI2M(0,MB)

      CALL FMDIG(NSTACK,KST)

      NDIG = NSTACK(1)

      CALL FMSQR(MZ04,MZ03)

      CALL FMSQR(MZ04(KPTIMU),M03)

      CALL FMADD(MZ03,M03,MZ03)

      CALL FMSQRT(MZ03,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,MZ04)

              NDIG = NSTACK(1)

              CALL FMDIV(MB,MZ03,MZ03)

          ENDIF

      ENDIF



      CALL FMDIV(MZ04,MZ03,M03)

      CALL FMM2DP(M03,AR)

      CALL FMDIV(MZ04(KPTIMU),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))

      CALL FMMPY(M03,MB,MB)

      CALL FMMPY(M03,MB(KPTIMU),MB(KPTIMU))



!             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,MZ03)

         CALL ZMMPYI(MB,LVAL,MB)

         CALL ZMADD(MB,MZ03,MB)

         CALL ZMDIVI(MB,JVAL2,MB)

      ENDDO



      CALL ZMIPWR(MB,IJSIGN*IVAL2,MB)

      IF (INVERT == 1) THEN

          CALL ZMI2M(1,MZ03)

          CALL ZMDIV(MZ03,MB,MB)

      ENDIF



!             Round the result and return.



  110 MACCMB = MB(0)

      MA(0) = MARZ

      MB(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MB(KPTIMU)

      MA(KPTIMU) = MAIZ

      MB(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      CALL ZMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,1)

      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



      DOUBLE PRECISION MC(0: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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



!             Scratch array usage during ZMSIN:   M01 - M06, MZ01 - MZ03



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)



!             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(MA,MZ01)

          GO TO 110

      ELSE IF (MA(KPTIMU+2) == 0) THEN

          CALL FMSIN(MA,MZ01)

          CALL FMI2M(0,MZ01(KPTIMU))

          GO TO 110

      ELSE IF (MA(2) == 0) THEN

          CALL FMSINH(MA(KPTIMU),MZ01(KPTIMU))

          CALL FMI2M(0,MZ01)

          GO TO 110

      ENDIF



!             Find COS(REAL(MA)) and SIN(REAL(MA)).



      CALL FMCSSN(MA,MZ01(KPTIMU),MZ01)



!             Find COSH(IMAG(MA)) and SINH(IMAG(MA)).



      CALL FMCHSH(MA(KPTIMU),M05,M06)



!             SIN(MA) =  SIN(REAL(MA))*COSH(IMAG(MA)) +

!                        COS(REAL(MA))*SINH(IMAG(MA)) i



      CALL FMMPY(MZ01,M05,MZ01)

      CALL FMMPY(MZ01(KPTIMU),M06,MZ01(KPTIMU))



  110 MACCMB = MZ01(0)

      MA(0) = MARZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,0)

      KRAD = KRSAVE

      RETURN

      END SUBROUTINE ZMSIN

      SUBROUTINE ZMSINH(MA,MB)



!  MB = SINH(MA).



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



!             Scratch array usage during ZMSINH:  M01 - M06, MZ01 - MZ03



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)



!             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(MA,MZ01)

          GO TO 110

      ELSE IF (MA(2) == 0) THEN

          CALL FMSIN(MA(KPTIMU),MZ01(KPTIMU))

          CALL FMI2M(0,MZ01)

          GO TO 110

      ELSE IF (MA(KPTIMU+2) == 0) THEN

          CALL FMSINH(MA,MZ01)

          CALL FMI2M(0,MZ01(KPTIMU))

          GO TO 110

      ENDIF



!             Find SIN(IMAG(MA)) and COS(IMAG(MA)).



      CALL FMCSSN(MA(KPTIMU),MZ01,MZ01(KPTIMU))



!             Find SINH(REAL(MA)) and COSH(REAL(MA)).



      CALL FMCHSH(MA,M05,M06)



!             SINH(MA) =  SINH(REAL(MA))*COS(IMAG(MA)) +

!                         COSH(REAL(MA))*SIN(IMAG(MA)) i



      CALL FMMPY(MZ01,M06,MZ01)

      CALL FMMPY(MZ01(KPTIMU),M05,MZ01(KPTIMU))



  110 MACCMB = MZ01(0)

      MA(0) = MARZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,0)

      KRAD = KRSAVE

      RETURN

      END SUBROUTINE ZMSINH

      SUBROUTINE ZMSQR(MA,MB)



!  MB = MA * MA



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



!             Scratch array usage during ZMSQR:   M01 - M03, MZ01



      DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE,MZERO

      INTEGER J,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)

      MZERO = 0

      NTRSAV = NTRACE

      NTRACE = 0

      KWRNSV = KWARN

      KWARN = 0



      DO J = NDSAVE+2, NDIG+1

         MA(J) = MZERO

         MA(KPTIMU+J) = MZERO

      ENDDO

      IF (NCALL == 1) THEN

          MA(0) = NINT(NDIG*ALOGM2)

          MA(KPTIMU) = MA(0)

      ENDIF



!             Check for special cases.



      IF (MA(KPTIMU+2) == 0) THEN

          CALL FMSQR(MA,MZ01)

          CALL FMI2M(0,MZ01(KPTIMU))

      ELSE IF (MA(2) == 0) THEN

          CALL FMSQR(MA(KPTIMU),MZ01)

          IF (MZ01(1) /= MUNKNO) MZ01(2) = -MZ01(2)

          CALL FMI2M(0,MZ01(KPTIMU))

      ELSE

          CALL FMADD(MA,MA(KPTIMU),M02)

          CALL FMSUB(MA,MA(KPTIMU),M03)

          CALL FMMPY(M02,M03,MZ01)

          CALL FMMPY(MA,MA(KPTIMU),M03)

          CALL FMADD(M03,M03,MZ01(KPTIMU))

      ENDIF



      MXEXP = MXSAVE

      NTRACE = NTRSAV

      NDGSV2 = NDIG

      NDIG = NDSAVE

      KWARN = KWRNSV

      IF (NCALL == 1) THEN

          MA(0) = MARZ

          MA(KPTIMU) = MAIZ

      ENDIF

      MACCMB = MZ01(0)

      MA(0) = MARZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      KACCSW = KASAVE

      CALL ZMEQ2(MZ01,MB,NDGSV2,NDSAVE,0)

      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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



!             Scratch array usage during ZMSQRT:   M01 - M03, MZ01



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)



!             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(MA(KPTIMU),M01)

          CALL FMDIVI(M01,2,M03)

          CALL FMSQRT(M03,M03)

      ELSE IF (MA(KPTIMU+2) == 0) THEN

          CALL FMABS(MA,M03)

          CALL FMSQRT(M03,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(MA,M01)

          CALL FMSQR(MA(KPTIMU),M02)

          CALL FMADD(M01,M02,M03)

          CALL FMSQRT(M03,M03)

          CALL FMABS(MA,M02)

          CALL FMADD(M02,M03,M03)

          CALL FMDIVI(M03,2,M03)

          CALL FMSQRT(M03,M03)

      ENDIF



      CALL FMADD(M03,M03,M02)

      IF (MA(2) >= 0) THEN

          CALL FMDIV(MA(KPTIMU),M02,MZ01(KPTIMU))

          CALL FMEQ(M03,MZ01)

      ELSE

          IF (MA(KPTIMU+2) >= 0) THEN

              CALL FMDIV(MA(KPTIMU),M02,MZ01)

              CALL FMEQ(M03,MZ01(KPTIMU))

          ELSE

              CALL FMDIV(MA(KPTIMU),M02,MZ01)

              CALL FMEQ(M03,MZ01(KPTIMU))

              IF (MZ01(1) /= MUNKNO) MZ01(2) = -MZ01(2)

              IF (MZ01(KPTIMU+1) /= MUNKNO) MZ01(KPTIMU+2) =  &

                                          -MZ01(KPTIMU+2)

          ENDIF

      ENDIF



  110 MXEXP = MXSAVE

      MACCMB = MZ01(0)

      MA(0) = MARZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      KACCSW = KASAVE

      CALL ZMEQ2(MZ01,MB,NDIG,NDSAVE,0)



      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

      DOUBLE PRECISION MA(0: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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ)



      INTEGER KASAVE,KF1,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV

      DOUBLE PRECISION 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),MB(KPTIMU),MC(KPTIMU))



      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



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



!             Scratch array usage during ZMTAN:   M01 - M06, MZ01 - MZ03



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)



!             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(MA,MZ01)

          GO TO 120

      ELSE IF (MA(KPTIMU+2) == 0) THEN

          CALL FMTAN(MA,MZ01)

          CALL FMI2M(0,MZ01(KPTIMU))

          GO TO 120

      ELSE IF (MA(2) == 0) THEN

          CALL FMTANH(MA(KPTIMU),MZ01(KPTIMU))

          CALL FMI2M(0,MZ01)

          GO TO 120

      ENDIF



!             Find SIN(2*REAL(MA)) and COS(2*REAL(MA)).



      CALL FMADD(MA,MA,MZ01)

      CALL FMCSSN(MZ01,MZ01(KPTIMU),MZ01)



!             Find SINH(2*IMAG(MA)) and COSH(2*IMAG(MA)).



      CALL FMADD(MA(KPTIMU),MA(KPTIMU),M06)

      CALL FMCHSH(M06,M05,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(MZ01(KPTIMU),M05,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)

          CALL FMIM(1,MZ01(KPTIMU))

          IF (M06(2) < 0) MZ01(KPTIMU+2) = -MZ01(KPTIMU+2)

      ELSE

          CALL FMDIVD(MZ01,M06,M05,MZ01,MZ01(KPTIMU))

      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)

      MA(0) = MARZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,0)

      KRAD = KRSAVE

      RETURN

      END SUBROUTINE ZMTAN

      SUBROUTINE ZMTANH(MA,MB)



!  MB = TANH(MA).



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ)



!             Scratch array usage during ZMTANH:  M01 - M06, MZ01 - MZ03



      DOUBLE PRECISION 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 ZMEQ2(MA,MA,NDSAVE,NDIG,1)



!             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(MA,MZ01)

          GO TO 120

      ELSE IF (MA(2) == 0) THEN

          CALL FMTAN(MA(KPTIMU),MZ01(KPTIMU))

          CALL FMI2M(0,MZ01)

          GO TO 120

      ELSE IF (MA(KPTIMU+2) == 0) THEN

          CALL FMTANH(MA,MZ01)

          CALL FMI2M(0,MZ01(KPTIMU))

          GO TO 120

      ENDIF



!             Find SIN(2*IMAG(MA)) and COS(2*IMAG(MA)).



      CALL FMADD(MA(KPTIMU),MA(KPTIMU),MZ01)

      CALL FMCSSN(MZ01,MZ01(KPTIMU),MZ01)



!             Find SINH(2*REAL(MA)) and COSH(2*REAL(MA)).



      CALL FMADD(MA,MA,M06)

      CALL FMCHSH(M06,M05,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(MZ01(KPTIMU),M05,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))

          CALL FMIM(1,MZ01)

          IF (M06(2) < 0) MZ01(2) = -MZ01(2)

      ELSE

          CALL FMDIVD(MZ01,M06,M05,MZ01(KPTIMU),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)

      MA(0) = MARZ

      MZ01(0) = MIN(MACCMB,MARZ,MAIZ)

      MACCMB = MZ01(KPTIMU)

      MA(KPTIMU) = MAIZ

      MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)

      CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN,0)

      KRAD = KRSAVE

      RETURN

      END SUBROUTINE ZMTANH

      SUBROUTINE ZMUNPK(MP,MA)



!  MP is unpacked and the value returned in MA.



      USE FMVALS

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPKZ),MP(0:LPACKZ)



      CALL FMUNPK(MP,MA)

      CALL FMUNPK(MP(KPTIMP),MA(KPTIMU))

      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 FMREAD.



      USE FMVALS

      IMPLICIT NONE



      INTEGER KWRITE

      DOUBLE PRECISION MA(0: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

      DOUBLE PRECISION MA(0: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))



      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:

!  '(0:LUNPKZ)' to '(0: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

      DOUBLE PRECISION MA(0:LPACKZ),MBFM(0: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

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMACOS(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPACOS

      SUBROUTINE ZPADD(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ),MC(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMUNPK(MB,MPY)

      CALL ZMADD(MPX,MPY,MPX)

      CALL ZMPACK(MPX,MC)

      RETURN

      END SUBROUTINE ZPADD

      SUBROUTINE ZPADDI(MA,INTEG)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0: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

      DOUBLE PRECISION MA(0:LPACKZ),MBFM(0: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

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMASIN(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPASIN

      SUBROUTINE ZPATAN(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMATAN(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPATAN

      SUBROUTINE ZPCHSH(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ),MC(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMCHSH(MPX,MPX,MPY)

      CALL ZMPACK(MPX,MB)

      CALL ZMPACK(MPY,MC)

      RETURN

      END SUBROUTINE ZPCHSH

      SUBROUTINE ZPCMPX(MAFM,MBFM,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MAFM(0:LPACK),MBFM(0:LPACK),MC(0: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

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMCONJ(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPCONJ

      SUBROUTINE ZPCOS(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMCOS(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPCOS

      SUBROUTINE ZPCOSH(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMCOSH(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPCOSH

      SUBROUTINE ZPCSSN(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ),MC(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMCSSN(MPX,MPX,MPY)

      CALL ZMPACK(MPX,MB)

      CALL ZMPACK(MPY,MC)

      RETURN

      END SUBROUTINE ZPCSSN

      SUBROUTINE ZPDIV(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ),MC(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMUNPK(MB,MPY)

      CALL ZMDIV(MPX,MPY,MPX)

      CALL ZMPACK(MPX,MC)

      RETURN

      END SUBROUTINE ZPDIV

      SUBROUTINE ZPDIVI(MA,INTEG,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      INTEGER INTEG

      CALL ZMUNPK(MA,MPX)

      CALL ZMDIVI(MPX,INTEG,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPDIVI

      SUBROUTINE ZPEQ(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0: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

      DOUBLE PRECISION MA(0:LPACKZ),MB(0: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

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMEXP(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPEXP

      SUBROUTINE ZPFORM(FORM1,FORM2,MA,STRING)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0: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

      DOUBLE PRECISION MA(0: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

      DOUBLE PRECISION MA(0:LPACKZ)

      CALL ZM2I2M(INTEG1,INTEG2,MPX)

      CALL ZMPACK(MPX,MA)

      RETURN

      END SUBROUTINE ZP2I2M

      SUBROUTINE ZPI2M(INTEG,MA)

      USE FMVALS

      IMPLICIT NONE

      INTEGER INTEG

      DOUBLE PRECISION MA(0:LPACKZ)

      CALL ZMI2M(INTEG,MPX)

      CALL ZMPACK(MPX,MA)

      RETURN

      END SUBROUTINE ZPI2M

      SUBROUTINE ZPIMAG(MA,MBFM)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MBFM(0: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

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMINT(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPINT

      SUBROUTINE ZPINP(LINE,MA,LA,LB)

      USE FMVALS

      IMPLICIT NONE

      INTEGER LA,LB

      CHARACTER LINE(LB)

      DOUBLE PRECISION MA(0:LPACKZ)

      CALL ZMINP(LINE,MPX,LA,LB)

      CALL ZMPACK(MPX,MA)

      RETURN

      END SUBROUTINE ZPINP

      SUBROUTINE ZPIPWR(MA,INTEG,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      INTEGER INTEG

      CALL ZMUNPK(MA,MPX)

      CALL ZMIPWR(MPX,INTEG,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPIPWR

      SUBROUTINE ZPLG10(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMLG10(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPLG10

      SUBROUTINE ZPLN(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMLN(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPLN

      SUBROUTINE ZPM2I(MA,INTEG)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0: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

      DOUBLE PRECISION MA(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMM2Z(MPX,ZVAL)

      RETURN

      END SUBROUTINE ZPM2Z

      SUBROUTINE ZPMPY(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ),MC(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMUNPK(MB,MPY)

      CALL ZMMPY(MPX,MPY,MPX)

      CALL ZMPACK(MPX,MC)

      RETURN

      END SUBROUTINE ZPMPY

      SUBROUTINE ZPMPYI(MA,INTEG,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      INTEGER INTEG

      CALL ZMUNPK(MA,MPX)

      CALL ZMMPYI(MPX,INTEG,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPMPYI

      SUBROUTINE ZPNINT(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMNINT(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPNINT

      SUBROUTINE ZPOUT(MA,LINE,LB,LAST1,LAST2)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0: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

      DOUBLE PRECISION MA(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMPRNT(MPX)

      RETURN

      END SUBROUTINE ZPPRNT

      SUBROUTINE ZPPWR(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ),MC(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMUNPK(MB,MPY)

      CALL ZMPWR(MPX,MPY,MPX)

      CALL ZMPACK(MPX,MC)

      RETURN

      END SUBROUTINE ZPPWR

      SUBROUTINE ZPREAD(KREAD,MA)

      USE FMVALS

      IMPLICIT NONE

      INTEGER KREAD

      DOUBLE PRECISION MA(0:LPACKZ)

      CALL ZMREAD(KREAD,MPX)

      CALL ZMPACK(MPX,MA)

      RETURN

      END SUBROUTINE ZPREAD

      SUBROUTINE ZPREAL(MA,MBFM)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MBFM(0: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

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      INTEGER IVAL,JVAL

      CALL ZMUNPK(MA,MPX)

      CALL ZMRPWR(MPX,IVAL,JVAL,MPX)

      CALL ZMPACK(MPX,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

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMSIN(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPSIN

      SUBROUTINE ZPSINH(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMSINH(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPSINH

      SUBROUTINE ZPSQR(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMSQR(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPSQR

      SUBROUTINE ZPSQRT(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMSQRT(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPSQRT

      SUBROUTINE ZPST2M(STRING,MA)

      USE FMVALS

      IMPLICIT NONE

      CHARACTER(*) :: STRING

      DOUBLE PRECISION MA(0:LPACKZ)

      CALL ZMST2M(STRING,MPX)

      CALL ZMPACK(MPX,MA)

      RETURN

      END SUBROUTINE ZPST2M

      SUBROUTINE ZPSUB(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ),MC(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMUNPK(MB,MPY)

      CALL ZMSUB(MPX,MPY,MPX)

      CALL ZMPACK(MPX,MC)

      RETURN

      END SUBROUTINE ZPSUB

      SUBROUTINE ZPTAN(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMTAN(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPTAN

      SUBROUTINE ZPTANH(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMTANH(MPX,MPX)

      CALL ZMPACK(MPX,MB)

      RETURN

      END SUBROUTINE ZPTANH

      SUBROUTINE ZPWRIT(KWRITE,MA)

      USE FMVALS

      IMPLICIT NONE

      INTEGER KWRITE

      DOUBLE PRECISION MA(0:LPACKZ)

      CALL ZMUNPK(MA,MPX)

      CALL ZMWRIT(KWRITE,MPX)

      RETURN

      END SUBROUTINE ZPWRIT

      SUBROUTINE ZPZ2M(ZVAL,MA)

      USE FMVALS

      IMPLICIT NONE

      COMPLEX ZVAL

      DOUBLE PRECISION MA(0: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

      DOUBLE PRECISION MA(0:LUNPCK),MB(0: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

      USE FMZM

      IMPLICIT NONE



      INTEGER N

      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMBERN:  M_01 - M_04



!             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

      DOUBLE PRECISION 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,M_04%MFM,NDSAVE,NDIG,0)

      M_04%MFM(0) = NINT(NDIG*ALOGM2)

      NUMTRY = 0



!             Check for special cases.



  110 IF (N >= 2 .AND. N <= 26) THEN

          CALL FMBER2(N,M_04%MFM,M_03%MFM)

          GO TO 130

      ELSE IF (N == 0) THEN

          M_03 = M_04

          GO TO 130

      ELSE IF (N == 1) THEN

          M_03 = M_04/(-2)

          GO TO 130

      ELSE IF (MOD(N,2) == 1 .OR. N < 0) THEN

          M_03 = 0

          GO TO 130

      ELSE IF (MA(2) == 0) THEN

          M_03 = 0

          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+2) THEN

              CALL FMMPY(MBERN(NPTBRN(N2)),M_04%MFM,M_03%MFM)

              GO TO 130

          ELSE IF (N == NUMBRN .AND. NWDBRN-NPTBRN(N2) >= NDIG+1) THEN

              CALL FMMPY(MBERN(NPTBRN(N2)),M_04%MFM,M_03%MFM)

              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+2) THEN

                 NSTART = J

                 NWDBRN = NPTBRN(J2) - 1

                 GO TO 120

             ENDIF

          ENDDO

          JSIZE = NWDBRN - NPTBRN(NUMBRN/2)

          IF (JSIZE < NDIG+1) THEN

              NSTART = NUMBRN

              NWDBRN = NPTBRN(NUMBRN/2) - 1

              GO TO 120

          ENDIF

      ENDIF



  120 NEEDED = ((N-NSTART)/2+1)*(NDIG+2)

      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)+1)

             MBERN(NPTBRN(J2-1)+1) = 0

             CALL FMM2DP(MBERN(NPTBRN(J2-1)),U)

             MBERN(NPTBRN(J2-1)+1) = MNEXP

             U = -U*(J*J-J)/X

             NPTBRN(J2) = NWDBRN + 1

             NUMBRN = J

             MBSBRN = MBASE

             NWDBRN = NPTBRN(J2) + NDIG + 1

             CALL FMDPM(U,MBERN(NPTBRN(J2)))

             MBERN(NPTBRN(J2)+1) = MBERN(NPTBRN(J2)+1) + 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 + 1

             CALL FM_PI(M_01)

             CALL FM_SQR(M_01,M_01)

             IF (MOD(J,4) == 0 .OR. MOD(J,4) == 1) THEN

                 L = -(J*J-J)/4

                 CALL FMMPYI(MBERN(NPTBRN(J2-1)),L,M_02%MFM)

             ELSE

                 L = -(J*J-J)

                 CALL FMMPYI(MBERN(NPTBRN(J2-1)),L,M_02%MFM)

                 M_02 = M_02/4

             ENDIF

             CALL FMDIV(M_02%MFM,M_01%MFM,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,M_01%MFM)

         IF (NBOT <= 26) THEN

             CALL FMBER2(NBOT,M_01%MFM,M_02%MFM)

         ELSE

             CALL FMMPY(MBERN(NPTBRN(NBOT/2)),M_01%MFM,M_02%MFM)

         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(M_01%MFM(1))+INTNDG))

                           M_01 = (M_01*NTN)/NTD

                           NTN = NEXTN

                           NTD = NEXTD

                       ENDIF

                   ENDIF

                ENDDO

                NDIG = MAX(2,MIN(NDSAV2,INT(M_01%MFM(1))+INTNDG))

                M_01 = (M_01*NTN)/NTD

                NDIG = NDSAV2

            ELSE

                CALL FMCMBI(NTOP,NBOT,M_01%MFM)

            ENDIF

            M_01%MFM(0) = NINT(NDIG*ALOGM2)



!             Now M_01 is the combination NTOP choose NBOT.



            IF (NBOT <= 26) THEN

                CALL FMBER2(NBOT,M_01%MFM,M_03%MFM)

            ELSE

                CALL FMMPY(MBERN(NPTBRN(NBOT/2)),M_01%MFM,M_03%MFM)

            ENDIF

            NDIG = NDSAV1

            M_02 = M_02 + M_03

            NDIG = MAX(2,NDSAV1-INT(M_02%MFM(1)-M_03%MFM(1)))

         ENDDO



         NDIG = NDSAV1

         IF (MOD(J,6) == 4) THEN

             M_03 = TO_FM(NTOP)/(-6)

             M_02 = M_03 - M_02

         ELSE

             M_03 = TO_FM(NTOP)/3

             M_02 = M_03 - M_02

         ENDIF



         J2 = J/2

         NPTBRN(J2) = NWDBRN + 1

         NUMBRN = J

         MBSBRN = MBASE

         NWDBRN = NPTBRN(J2) + NDIG + 1



         M_02 = 6*M_02

         NTN = NTOP*(NTOP-1)

         LARGE = INT(INTMAX/NTOP)

         IF (NTN > MXBASE .OR. NTOP > LARGE) THEN

             M_02 = M_02/NTOP

             NTN = NTOP - 1

             M_02 = M_02/NTN

             NTN = NTOP - 2

             CALL FMDIVI(M_02%MFM,NTN,MBERN(NPTBRN(J2)))

         ELSE IF (NTN*(NTOP-2) > MXBASE .OR. NTN > LARGE) THEN

             M_02 = M_02/NTN

             NTN = NTOP - 2

             CALL FMDIVI(M_02%MFM,NTN,MBERN(NPTBRN(J2)))

         ELSE

             NTN = NTN*(NTOP-2)

             CALL FMDIVI(M_02%MFM,NTN,MBERN(NPTBRN(J2)))

         ENDIF

      ENDDO



      CALL FMMPY(MBERN(NPTBRN(N2)),M_04%MFM,M_03%MFM)



!             Check for too much cancellation.



  130 IF (NCALL <= 1) THEN

          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17

      ELSE

          NGOAL = INT(-MXEXP2)

      ENDIF

      IF (M_03%MFM(0) <= NGOAL) THEN

          IF (NUMTRY > 0) THEN

              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)

              DO J = 1, NDGOAL+1

                 IF (MRETRY(J) /= M_03%MFM(J)) GO TO 140

              ENDDO

              GO TO 150

          ENDIF

  140     IEXTRA = INT(REAL(NGOAL-M_03%MFM(0))/ALOGM2 + 23.03/ALOGMB) + 1

          NDOLD = NDIG

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDIG - IEXTRA

              CALL FM_ST2M('UNKNOWN',M_03)

              GO TO 150

          ENDIF

          CALL FMEQ2(M_04%MFM,M_04%MFM,NDSAVE,NDIG,1)

          NUMTRY = NUMTRY + 1

          CALL FMEQ2(M_03%MFM,MRETRY,NDOLD,NDIG,0)

          GO TO 110

      ENDIF



  150 MACMAX = NINT(NDSAVE*ALOGM2)

      M_03%MFM(0) = MIN(M_03%MFM(0),MACCA,MACMAX)

      CALL FMEXT2(M_03%MFM,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

      DOUBLE PRECISION MA(0:LUNPCK),MB(0: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(MB,NBBOT(N2),MB)

          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

      USE FMZM

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



!             Scratch array usage during FMBETA:  M_01 - M_17



      DOUBLE PRECISION 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

      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,M_13%MFM,NDSAVE,NDIG,0)

      M_13%MFM(0) = NINT(NDIG*ALOGM2)

      CALL FMEQ2(MB,M_14%MFM,NDSAVE,NDIG,0)

      M_14%MFM(0) = NINT(NDIG*ALOGM2)

      M_16 = M_13

      NUMTRY = 0



  110 M_12 = M_13 + M_14

      IF (M_13%MFM(2) == 0 .OR. M_14%MFM(2) == 0) THEN

          CALL FM_ST2M('UNKNOWN',M_17)

          KFLAG = -4

          GO TO 140

      ENDIF

      IF (M_12 == M_13) THEN

          IF (M_14%MFM(1) > MEXPAB) THEN

              M_07 = (M_13%MFM(1)+1)*DLOGMB*ABS(M_14)

          ELSE

              M_07 = M_14

          ENDIF

          IF (M_07 <= EPSILON(M_07)) THEN

              CALL FMGAM(M_14%MFM,M_17%MFM)

              GO TO 140

          ENDIF

      ENDIF

      IF (M_12 == M_14) THEN

          IF (M_13%MFM(1) > MEXPAB) THEN

              M_07 = (M_14%MFM(1)+1)*DLOGMB*ABS(M_13)

          ELSE

              M_07 = M_13

          ENDIF

          IF (M_07 <= EPSILON(M_07)) THEN

              CALL FMGAM(M_13%MFM,M_17%MFM)

              GO TO 140

          ENDIF

      ENDIF

      IF (M_13%MFM(1) == MEXPOV) THEN

          IF (M_13 > 0 .AND. M_14 >= 1) THEN

              CALL FM_ST2M('UNDERFLOW',M_17)

              KFLAG = -6

              GO TO 140

          ENDIF

      ENDIF

      IF (M_14%MFM(1) == MEXPOV) THEN

          IF (M_14 > 0 .AND. M_13 >= 1) THEN

              CALL FM_ST2M('UNDERFLOW',M_17)

              KFLAG = -6

              GO TO 140

          ENDIF

      ENDIF



!             See if any of the terms are negative integers.



      M_02 = AINT(M_13)

      IF (M_13%MFM(2) < 0) THEN

          IF (M_13 == M_02) THEN

              CALL FM_ST2M('UNKNOWN',M_17)

              KFLAG = -4

              GO TO 140

          ENDIF

      ENDIF

      M_03 = AINT(M_14)

      IF (M_14%MFM(2) < 0) THEN

          IF (M_14 == M_03) THEN

              CALL FM_ST2M('UNKNOWN',M_17)

              KFLAG = -4

              GO TO 140

          ENDIF

      ENDIF

      IF (M_12%MFM(2) == 0) THEN

          M_17 = 0

          GO TO 120

      ELSE IF (M_12%MFM(2) < 0) THEN

          M_07 = (M_13-M_02) + (M_14-M_03)

          M_08 = AINT(M_07)

          IF (M_07 == M_08) THEN

              M_17 = 0

              GO TO 120

          ENDIF

      ENDIF



!             See if any of the terms are small integers.



      KWRNSV = KWARN

      KWARN = 0

      N = M_13

      KFLKB = KFLAG

      K = M_14

      KFLNKB = KFLAG

      NK = M_12

      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,M_17%MFM)

              M_02 = (N+K-1)

              M_17 = M_17 * M_02

              M_17 = 1 / M_17

              GO TO 120

          ENDIF

      ENDIF

      NBOT = 0

      IF (KFLKB == 0 .AND. N <= 200) THEN

          M_15 = M_14

          CALL FMPOCH(M_15%MFM,N,M_15%MFM)

          CALL FMFCTI(KB,M_05%MFM)

          M_16 = M_05 / M_15

          IF (ABS(M_16%MFM(1)) < MXSAVE) THEN

              M_17 = M_16

              GO TO 140

          ENDIF

          NBOT = 1

      ELSE IF (KFLNKB == 0 .AND. K <= 200) THEN

          M_15 = M_13

          CALL FMPOCH(M_15%MFM,K,M_15%MFM)

          CALL FMFCTI(NKB,M_05%MFM)

          M_16 = M_05 / M_15

          IF (ABS(M_16%MFM(1)) < MXSAVE) THEN

              M_17 = M_16

              GO TO 140

          ENDIF

          NBOT = 1

      ENDIF

      IF (NBOT == 1) THEN

          CALL FMEQ2(MA,M_13%MFM,NDSAVE,NDIG,0)

          M_13%MFM(0) = NINT(NDIG*ALOGM2)

          CALL FMEQ2(MB,M_14%MFM,NDSAVE,NDIG,0)

          M_14%MFM(0) = NINT(NDIG*ALOGM2)

          M_16 = M_13

          M_12 = M_13 + M_14

      ENDIF



!             General case.  Use FMGAM, unless one of the numbers

!             is too big.  If so, use FMLNGM.



      X = ALOGMB*REAL(MXEXP)

      M_01 = X/LOG(X)

      IF (ABS(M_12) >= M_01 .OR. ABS(M_13) >= M_01 .OR.  &

          ABS(M_14) >= M_01) 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 (M_13%MFM(1) > M_14%MFM(1)) THEN

              M_04 = M_13

              M_05 = M_14

          ELSE

              M_04 = M_14

              M_05 = M_13

          ENDIF

          IF (M_04%MFM(1) > NDIG .AND. M_04%MFM(1) >= M_05%MFM(1)+NDIG) THEN

              IF (M_05 < 0) THEN

                  IF (M_05%MFM(1) > NDIG) THEN

                      KFLAG = -9

                      CALL FMWRN2

                      NDIG = NDIG - IEXTRA

                      CALL FM_ST2M('UNKNOWN',M_17)

                      GO TO 140

                  ELSE

                      M_06 = MOD(AINT(-M_05),TO_FM(2))

                      IF (M_06 == 0) THEN

                          M_11 = M_05*LOG(M_04+M_05)

                          M_12 = M_05 + 1

                          M_15 = M_05

                          CALL FMLNGM(M_12%MFM,M_12%MFM)

                          M_07 = EXP(M_12 - M_11)/M_15

                          M_17 = M_07

                          GO TO 120

                      ENDIF

                  ENDIF

              ENDIF

              M_11 = M_05*LOG(M_04+M_05)

              M_15 = M_05

              CALL FMLNGM(M_15%MFM,M_12%MFM)

              M_07 = EXP(M_12 - M_11)

              M_17 = M_07

              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.



          IF (M_13 > 1.0E7 .AND. M_14 > 1.0E7) THEN

              M_10 = M_13*LOG(M_13) + M_14*LOG(M_14) -  &

                     (M_13+M_14)*LOG(M_13+M_14)

              M_11 = EXP(M_10)

              IF (M_11%MFM(1) == MEXPUN) THEN

                  M_17 = M_11

                  GO TO 140

              ENDIF

          ENDIF



!             Compute IEXTRA, the number of extra digits required

!             to compensate for cancellation error.



          MZERO = 0

          IEXTRA = INT(MAX(M_12%MFM(1),M_13%MFM(1),M_14%MFM(1),MZERO))

          IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN

              CALL FMEQ2(M_13%MFM,M_13%MFM,NDIG,NDIG+IEXTRA,1)

              CALL FMEQ2(M_14%MFM,M_14%MFM,NDIG,NDIG+IEXTRA,1)

          ENDIF

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDIG - IEXTRA

              CALL FM_ST2M('UNKNOWN',M_17)

              GO TO 140

          ENDIF

          M_12 = M_13 + M_14

          M_04 = 1

          M_05 = 2

          M_17 = M_12

          K10 = 0

          K11 = 0

          KC = 0

          IF (M_13%MFM(2) < 0) THEN

              M_06 = AINT(M_13)

              M_07 = MOD(M_06,M_05)

              IF (M_07%MFM(2) == 0) THEN

                  K10 = 1

                  M_13 = M_13 + M_04

              ENDIF

          ENDIF

          IF (M_14%MFM(2) < 0) THEN

              M_06 = AINT(M_14)

              M_07 = MOD(M_06,M_05)

              IF (M_07%MFM(2) == 0) THEN

                  K11 = 1

                  M_14 = M_14 + M_04

              ENDIF

          ENDIF

          IF (M_17%MFM(2) < 0) THEN

              M_06 = AINT(M_17)

              M_07 = MOD(M_06,M_05)

              IF (M_07%MFM(2) == 0) THEN

                  KC = 1

                  M_17 = M_17 + M_04

              ENDIF

          ENDIF

          CALL FMLNGM(M_13%MFM,M_12%MFM)

          CALL FMLNGM(M_14%MFM,M_15%MFM)

          M_12 = M_12 + M_15

          CALL FMLNGM(M_17%MFM,M_15%MFM)

          M_12 = EXP(M_12-M_15)

          IF (K10 == 1 .OR. K11 == 1 .OR. KC == 1) THEN

              M_04 = 1

              IF (K10 == 1) THEN

                  M_13 = M_13 - M_04

                  M_12 = M_12/M_13

              ENDIF

              IF (K11 == 1) THEN

                  M_14 = M_14 - M_04

                  M_12 = M_12/M_14

              ENDIF

              IF (KC == 1) THEN

                  M_17 = M_17 - M_04

                  M_12 = M_12 * M_17

              ENDIF

          ENDIF

          M_17 = M_12

      ELSE

          M_17 = M_12

          CALL FMGAM(M_13%MFM,M_13%MFM)

          CALL FMGAM(M_14%MFM,M_14%MFM)

          CALL FMGAM(M_17%MFM,M_17%MFM)

          M_02 = M_13*M_14

          M_17 = M_02 / M_17

      ENDIF



!             Check for too much cancellation.



  120 IF (NCALL <= 1) THEN

          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17

      ELSE

          NGOAL = INT(-MXEXP2)

      ENDIF

      IF (M_17%MFM(0) <= NGOAL) THEN

          IF (NUMTRY > 0) THEN

              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)

              DO J = 1, NDGOAL+1

                 IF (MRETRY(J) /= M_17%MFM(J)) GO TO 130

              ENDDO

              GO TO 140

          ENDIF

  130     IEXTRA = INT(REAL(NGOAL-M_17%MFM(0))/ALOGM2 + 23.03/ALOGMB) + 1

          NDOLD = NDIG

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDIG - IEXTRA

              CALL FM_ST2M('UNKNOWN',M_17)

              GO TO 140

          ENDIF

          CALL FMEQ2(MA,M_13%MFM,NDSAVE,NDIG,0)

          CALL FMEQ2(MB,M_14%MFM,NDSAVE,NDIG,0)

          NUMTRY = NUMTRY + 1

          CALL FMEQ2(M_17%MFM,MRETRY,NDOLD,NDIG,0)

          GO TO 110

      ENDIF



  140 MACMAX = NINT(NDSAVE*ALOGM2)

      M_17%MFM(0) = MIN(M_17%MFM(0),MACCA,MACCB,MACMAX)

      CALL FMEXT2(M_17%MFM,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

      DOUBLE PRECISION MA(0: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(MA,NTN,MA)

             CALL FMDIVI(MA,NTD,MA)

             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(MA,NTN,MA)

                 CALL FMDIVI(MA,NTD,MA)

                 NTN = NEXTN

                 NTD = NEXTD

             ENDIF

         ENDIF

      ENDDO

      NDIG = MAX(2,MIN(NDSAVE,INT(MA(1))+INTNDG))

      CALL FMGCDI(NTN,NTD)

      CALL FMMPYI(MA,NTN,MA)

      CALL FMDIVI(MA,NTD,MA)

      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

      USE FMZM

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



!             Scratch array usage during FMCOMB:  M_01 - M_16



      DOUBLE PRECISION 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

      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,M_13%MFM,NDSAVE,NDIG,0)

      M_13%MFM(0) = NINT(NDIG*ALOGM2)

      CALL FMEQ2(MB,M_14%MFM,NDSAVE,NDIG,0)

      M_14%MFM(0) = NINT(NDIG*ALOGM2)

      NUMTRY = 0



  110 M_12 = M_13 - M_14

      IF (M_14%MFM(2) == 0) THEN

          M_16 = 1

          GO TO 120

      ENDIF



!             See if any of the terms are negative integers.



      M_06 = 1

      K10 = 0

      IF (M_13%MFM(2) < 0) THEN

          M_02 = AINT(M_13)

          IF (M_13 == M_02) K10 = -1

      ENDIF

      K11 = 0

      IF (M_14%MFM(2) < 0) THEN

          M_03 = AINT(M_14)

          IF (M_14 == M_03) K11 = -1

      ENDIF

      K09 = 0

      IF (M_13 < M_14) THEN

          M_04 = MOD(M_13,M_06)

          M_05 = MOD(M_14,M_06)

          M_05 = M_04 - M_05

          M_04 = AINT(M_05)

          IF (M_05 == M_04) K09 = -1

      ENDIF



      M_05 = 2



      IF (K11 == -1) THEN

          M_16 = 0

          GO TO 120

      ELSE IF (M_12%MFM(2) == 0) THEN

          M_16 = 1

          GO TO 120

      ELSE IF (K09 == -1 .AND. K10 == 0) THEN

          M_16 = 0

          GO TO 120

      ELSE IF (K10 == -1 .AND. K09 == 0) THEN

          CALL FM_ST2M('UNKNOWN',M_16)

          KFLAG = -4

          GO TO 140

      ELSE IF (K10 == -1 .AND. K09 == -1) THEN

          M_07 = MOD(M_14,M_05)

          IF (M_07%MFM(2) /= 0) KSIGN = -1

          M_07 = M_14 - M_13

          M_13 = M_07 - M_06

          M_12 = M_13 - M_14

      ENDIF



!             Check for an obviously overflowed result.



      IF (M_13%MFM(1) == MEXPOV) THEN

          IF (M_13 > 0 .AND. M_14 >= 1 .AND. M_14%MFM(1) < MEXPOV) THEN

              CALL FM_ST2M('OVERFLOW',M_16)

              KFLAG = -5

              GO TO 140

          ENDIF

      ENDIF

      IF (M_13%MFM(1) >= 10000) THEN

          IF (M_14 > 1 .AND. M_14 < M_13) THEN

              M_08 = MIN(M_14,M_13-M_14)

              M_07 = M_08*(LOG((M_13-M_08+1)/M_08)+1) - LOG(6.283185*M_08)/2

              M_07 = EXP(M_07)

              IF (M_07%MFM(1) == MEXPOV) THEN

                  CALL FM_ST2M('OVERFLOW',M_16)

                  KFLAG = -5

                  GO TO 140

              ENDIF

          ENDIF

      ENDIF



!             See if any of the terms are small integers.



      KWRNSV = KWARN

      KWARN = 0

      N = M_13

      K = M_14

      KFLGK = KFLAG

      NK = M_12

      KFLGNK = KFLAG

      KWARN = KWRNSV



      IF (KFLGK == 0 .AND. (1+M_13)-1 == 0) THEN

          M_16 = 2

          M_16 = MOD(M_14,M_16)

          IF (M_16 == 0) THEN

              M_16 = -M_13 / M_14

          ELSE

              M_16 = M_13 / M_14

          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,M_16%MFM)

              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

          M_02 = M_13

          M_03 = M_13

          M_04 = -1

          DO J = 2, NBOT

             M_02 = M_02 + M_04

             M_03 = M_02*M_03

             KBOT = KBOT*J

             IF (KBOT >= LARGE) THEN

                 M_03 = M_03/KBOT

                 KBOT = 1

             ENDIF

          ENDDO

          M_16 = M_03 / KBOT

          GO TO 120

      ENDIF



!             General case.  Use FMFACT, unless one of the numbers

!             is too big.  If so, use FMLNGM.



      X = ALOGMB*REAL(MXEXP)

      M_01 = X/LOG(X)

      IF (ABS(M_12) >= M_01 .OR. ABS(M_13) >= M_01 .OR.  &

          ABS(M_14) >= M_01) 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 (M_13%MFM(1) > M_14%MFM(1) .AND. M_13%MFM(2) > 0 .AND.  &

              M_14%MFM(2) > 0) THEN

              M_04 = M_13

              M_05 = M_14

          ELSE

              M_04 = 1

              M_05 = 1

          ENDIF

          IF (M_04%MFM(1) > NDIG .AND. M_04%MFM(1) >= M_05%MFM(1)+NDIG) THEN

              M_15 = M_05 + 1

              M_11 = (M_05 + M_05*(LOG(M_04)-1))

              CALL FMLNGM(M_15%MFM,M_12%MFM)

              M_07 = EXP(M_11 - M_12)

              M_16 = M_07

              GO TO 120

          ENDIF



!             Compute IEXTRA, the number of extra digits required

!             to compensate for cancellation error.



          MZERO = 0

          IEXTRA = INT(MAX(M_12%MFM(1),M_13%MFM(1),M_14%MFM(1),MZERO))

          IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN

              CALL FMEQ2(M_13%MFM,M_13%MFM,NDIG,NDIG+IEXTRA,1)

              CALL FMEQ2(M_14%MFM,M_14%MFM,NDIG,NDIG+IEXTRA,1)

          ENDIF

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDIG - IEXTRA

              CALL FM_ST2M('UNKNOWN',M_16)

              CALL FMEXT2(M_16%MFM,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)

              RETURN

          ENDIF

          M_12 = M_13 - M_14

          M_04 = 1

          M_05 = 2

          M_16 = M_12 + M_04

          M_13 = M_13 + M_04

          M_14 = M_14 + M_04

          K10 = 0

          K11 = 0

          KC = 0

          IF (M_13%MFM(2) < 0) THEN

              M_06 = AINT(M_13)

              M_07 = MOD(M_06,M_05)

              IF (M_07%MFM(2) == 0) THEN

                  K10 = 1

                  M_13 = M_13 + M_04

              ENDIF

          ENDIF

          IF (M_14%MFM(2) < 0) THEN

              M_06 = AINT(M_14)

              M_07 = MOD(M_06,M_05)

              IF (M_07%MFM(2) == 0) THEN

                  K11 = 1

                  M_14 = M_14 + M_04

              ENDIF

          ENDIF

          IF (M_16%MFM(2) < 0) THEN

              M_06 = AINT(M_16)

              M_07 = MOD(M_06,M_05)

              IF (M_07%MFM(2) == 0) THEN

                  KC = 1

                  M_16 = M_16 + M_04

              ENDIF

          ENDIF

          CALL FMLNGM(M_13%MFM,M_12%MFM)

          CALL FMLNGM(M_14%MFM,M_15%MFM)

          M_12 = M_12 - M_15

          CALL FMLNGM(M_16%MFM,M_15%MFM)

          M_12 = M_12 - M_15

          M_12 = EXP(M_12)

          IF (K10 == 1 .OR. K11 == 1 .OR. KC == 1) THEN

              M_04 = 1

              IF (K10 == 1) THEN

                  M_13 = M_13 - M_04

                  M_12 = M_12/M_13

              ENDIF

              IF (K11 == 1) THEN

                  M_14 = M_14 - M_04

                  M_12 = M_12*M_14

              ENDIF

              IF (KC == 1) THEN

                  M_16 = M_16 - M_04

                  M_12 = M_12 * M_16

              ENDIF

          ENDIF

          M_16 = M_12

      ELSE

          M_16 = M_12

          CALL FMFACT(M_13%MFM,M_13%MFM)

          CALL FMFACT(M_14%MFM,M_14%MFM)

          CALL FMFACT(M_16%MFM,M_16%MFM)

          M_02 = M_16 * M_14

          M_16 = M_13 / M_02

      ENDIF



!             Check for too much cancellation.



  120 IF (NCALL <= 1) THEN

          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17

      ELSE

          NGOAL = INT(-MXEXP2)

      ENDIF

      IF (M_16%MFM(0) <= NGOAL) THEN

          IF (NUMTRY > 0) THEN

              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)

              DO J = 1, NDGOAL+1

                 IF (MRETRY(J) /= M_16%MFM(J)) GO TO 130

              ENDDO

              GO TO 140

          ENDIF

  130     IEXTRA = INT(REAL(NGOAL-M_16%MFM(0))/ALOGM2 + 23.03/ALOGMB) + 1

          NDOLD = NDIG

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDIG - IEXTRA

              CALL FM_ST2M('UNKNOWN',M_16)

              GO TO 140

          ENDIF

          CALL FMEQ2(MA,M_13%MFM,NDSAVE,NDIG,0)

          CALL FMEQ2(MB,M_14%MFM,NDSAVE,NDIG,0)

          NUMTRY = NUMTRY + 1

          CALL FMEQ2(M_16%MFM,MRETRY,NDOLD,NDIG,0)

          GO TO 110

      ENDIF



  140 M_16%MFM(2) = KSIGN*M_16%MFM(2)

      MACMAX = NINT(NDSAVE*ALOGM2)

      M_16%MFM(0) = MIN(M_16%MFM(0),MACCA,MACCB,MACMAX)

      CALL FMEXT2(M_16%MFM,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

      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0: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(MC,2,MC)

              IF (KRESLT >= 14) CALL FMDIVI(MC,4,MC)

              CALL FMEQ2(MC,MC,NDIG,NDSAVE,1)

              NDIG = NDSAVE

              IF (KRESLT == 9 .OR. KRESLT == 14) MC(2) = -MC(2)

              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

      USE FMZM

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK)



!             Scratch array usage during FMEULR:  M_01 - M_10



      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%MFM,MA,NDGEUL,NDSAVE,0)

      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 FM_ST2M(STRING,M_EULER)

              M_EULER%MFM(0) = NINT(NDIG*ALOGM2)

              MBSEUL = MBASE

              NDGEUL = NDIG

              IF (ABS(M_EULER%MFM(1)) > 10) NDGEUL = 0

              CALL FMEQ2(M_EULER%MFM,MA,NDIG,NDSAVE,0)

              NDIG = NDSV

          ELSE

              NDSV = NDIG

              NDIG = MIN(NDIG+2,NDG2MX)

              M_EULER = 1

              CALL FMPSI(M_EULER%MFM,M_EULER%MFM)

              M_EULER%MFM(2) = ABS(M_EULER%MFM(2))

              MBSEUL = MBASE

              NDGEUL = NDIG

              IF (ABS(M_EULER%MFM(1)) > 10) NDGEUL = 0

              CALL FMEQ2(M_EULER%MFM,MA,NDIG,NDSAVE,0)

              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



      DOUBLE PRECISION MT(0:LUNPCK),MC(0:LUNPCK),MXSAVE

      INTEGER NDSAVE,KASAVE,KOVUN



      INTEGER KFSAVE,KWRNSV



      KWRNSV = KWARN

      KWARN = 0

      MXEXP = MXSAVE

      KFSAVE = KFLAG

      CALL FMEQ2(MT,MC,NDIG,NDSAVE,0)

      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



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMFACT:  M_01 - M_12



      DOUBLE PRECISION MACCA,MACMAX,MXSAVE

      INTEGER 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,0)

      MB(0) = NINT(NDIG*ALOGM2)

      CALL FMADDI(MB,1)

      CALL FMGAM(MB,MB)

      MACMAX = NINT(NDSAVE*ALOGM2)

      MB(0) = MIN(MB(0),MACCA,MACMAX)

      CALL FMEXT2(MB,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

      DOUBLE PRECISION MA(0: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(MA,K,MA)

             K = 1

         ENDIF

      ENDDO

      IF (K > 1) CALL FMMPYI(MA,K,MA)

      RETURN

      END SUBROUTINE FMFCTI

      SUBROUTINE FMGAM(MA,MB)



!  MB = GAMMA(MA)



      USE FMVALS

      USE FMZM

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMGAM:  M_01 - M_12



      DOUBLE PRECISION 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



      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,M_12%MFM,NDSAVE,NDIG,0)

      M_12%MFM(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

          M_02 = M_12 - M_GAMMA_MA

          IF (M_02%MFM(2) == 0) THEN

              M_06 = M_GAMMA_MB

              GO TO 140

          ENDIF

          KWRNSV = KWARN

          KWARN = 0

          KDIFF = M_02

          KWARN = KWRNSV

          IF (KFLAG == 0 .AND. ABS(KDIFF) <= 50) THEN

              IF (KDIFF > 0) THEN

                  M_05 = M_GAMMA_MA

              ELSE

                  M_05 = M_12

              ENDIF

              M_04 = M_05

              DO J = 1, ABS(KDIFF)-1

                 M_05 = M_05 + 1

                 M_04 = M_04*M_05

              ENDDO

              IF (KDIFF > 0) THEN

                  M_06 = M_GAMMA_MB * M_04

              ELSE

                  M_06 = M_GAMMA_MB / M_04

              ENDIF

              GO TO 140

          ENDIF

      ENDIF



      M_GAMMA_MB = M_12



!             Near zero Gamma(x) is about 1/x.



  110 IF (M_GAMMA_MB%MFM(1) < (-NDIG-3)) THEN

          M_06 = 1 / M_GAMMA_MB

          GO TO 140

      ENDIF



!             Check for special cases.



      KRFLCT = 0

      M_02 = -0.5

      IF (M_GAMMA_MB <= M_02) THEN

          KRFLCT = 1

          KFL = 0

          IF (M_12%MFM(1) <= NDSAVE) THEN

              M_05 = AINT(M_GAMMA_MB)

              IF (M_GAMMA_MB == M_05) KFL = -4

          ELSE

              KFL = -4

          ENDIF

          IF (KFL /= 0) THEN

              CALL FM_ST2M('UNKNOWN',M_06)

              KFLAG = -4

              GO TO 140

          ELSE

              M_GAMMA_MB = 1 - M_GAMMA_MB

          ENDIF

      ENDIF



!             To speed the asymptotic series calculation, increase

!             the argument by LSHIFT.



      KWSAVE = KWARN

      KWARN = 0

      INTA = M_GAMMA_MB

      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

                  M_06 = 1

                  GO TO 120

              ENDIF

              INTA = INTA - 1

              CALL FMFCTI(INTA,M_06%MFM)

              GO TO 120

          ENDIF

      ENDIF



      IF (LSHIFT /= 0) THEN

          M_11 = M_GAMMA_MB + LSHIFT

      ELSE

          M_11 = M_GAMMA_MB

      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(M_11%MFM(1))-1,0),INT(1.0+ALOGMX/ALOGMB))

      IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN

          CALL FMEQ2(M_11%MFM,M_11%MFM,NDIG,NDIG+IEXTRA,1)

          CALL FMEQ2(M_GAMMA_MB%MFM,M_GAMMA_MB%MFM,NDIG,NDIG+IEXTRA,1)

      ENDIF

      NDSAV2 = NDIG

      NDIG = NDIG + IEXTRA

      IF (NDIG > NDG2MX .AND. KRFLCT == 1) THEN

          KFLAG = -9

          CALL FMWRN2

          NDIG = NDIG - IEXTRA

          CALL FM_ST2M('UNKNOWN',M_06)

          GO TO 140

      ELSE IF (NDIG > NDG2MX .AND. KRFLCT == 0) THEN

          KFLAG = -5

          NDIG = NDIG - IEXTRA

          CALL FM_ST2M('OVERFLOW',M_06)

          GO TO 140

      ENDIF

      CALL FMLNGM(M_11%MFM,M_11%MFM)

      M_06 = EXP(M_11)



      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.



!             M_01  is Z

!             M_02 is Z**2

!             M_03 is Z**3

!             M_04 is (Z+K)*...*(Z+K+3)

!             M_07 is the current product



      M_01 = M_GAMMA_MB

      IF (LSHIFT > 0) THEN

          M_02 = M_01 ** 2

          M_03 = M_01 * M_02

          M_04 = M_02 ** 2

          M_08 = 6*M_03

          M_04 = M_04 + M_08

          M_08 = 11*M_02

          M_04 = M_04 + M_08

          M_08 = M_01 * 6

          M_04 = M_04 + M_08

          M_07 = M_04

          M_03 = 16*M_03

          LARGE = INTMAX

          DO K = 0, LSHIFT-8, 4

             M_04 = M_04 + M_03

             K2 = 24*(2*K + 7)

             M_08 = K2*M_02

             M_04 = M_04 + M_08

             IF (K <= SQRT(REAL(LARGE)/49.0)) THEN

                 K1 = 8*(6*K*K + 42*K + 79)

                 M_08 = M_01 * K1

                 M_04 = M_04 + M_08

             ELSE

                 K1 = 48*K

                 M_08 = M_01 * K1

                 M_08 = K*M_08

                 M_04 = M_04 + M_08

                 K1 = 336*K + 632

                 M_08 = M_01 * K1

                 M_04 = M_04 + M_08

             ENDIF

             IF (K <= (REAL(LARGE)/17.0)**0.3333) THEN

                 K0 = 8*(2*K + 7)*(K*K + 7*K + 15)

                 M_04 = M_04 + K0

             ELSE IF (K <= SQRT(REAL(LARGE)*0.9)) THEN

                 K0 = 8*(2*K + 7)

                 M_08 = K0

                 K0 = K*K + 7*K + 15

                 M_08 = K0*M_08

                 M_04 = M_04 + M_08

             ELSE

                 K0 = 8*(2*K + 7)

                 M_08 = K0

                 M_05 = K*M_08

                 M_05 = K*M_05

                 M_04 = M_04 + M_05

                 K0 = 7*K + 15

                 M_08 = K0*M_08

                 M_04 = M_04 + M_08

             ENDIF

             M_07 = M_07*M_04

          ENDDO

          M_06 = M_06/M_07

      ENDIF



!             Use the reflection formula if MA was less than -1/2.



  120 IF (KRFLCT == 1) THEN



!             Reduce the argument before multiplying by Pi.



          M_02 = ANINT(M_GAMMA_MB)

          M_03 = M_02/2

          M_03 = AINT(M_03)

          M_04 = M_03*2

          KSIGN = -1

          IF (M_02 == M_04) KSIGN = 1

          M_05 = M_GAMMA_MB - M_02

          M_05%MFM(0) = M_GAMMA_MB%MFM(0)

          CALL FM_PI(M_07)

          M_07 = M_07*M_05

          KRSAVE = KRAD

          KRAD = 1

          M_07 = SIN(M_07)

          M_07%MFM(2) = KSIGN*M_07%MFM(2)

          KRAD = KRSAVE

          CALL FMDIV(MPISAV,M_07%MFM,M_07%MFM)

          M_06 = M_07/M_06

      ENDIF



!             Check for too much cancellation.



      IF (NCALL <= 1) THEN

          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17

      ELSE

          NGOAL = INT(-MXEXP2)

      ENDIF

      IF (M_06%MFM(0) <= NGOAL) THEN

          IF (NUMTRY > 0) THEN

              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)

              DO J = 1, NDGOAL+1

                 IF (MRETRY(J) /= M_06%MFM(J)) GO TO 130

              ENDDO

              GO TO 140

          ENDIF

  130     IEXTRA = INT(REAL(NGOAL-M_06%MFM(0))/ALOGM2 + 23.03/ALOGMB) + 1

          NDOLD = NDIG

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDIG - IEXTRA

              CALL FM_ST2M('UNKNOWN',M_06)

              GO TO 140

          ENDIF

          CALL FMEQ2(M_12%MFM,M_12%MFM,NDSAVE,NDIG,1)

          M_GAMMA_MB = M_12

          NUMTRY = NUMTRY + 1

          CALL FMEQ2(M_06%MFM,MRETRY,NDOLD,NDIG,0)

          GO TO 110

      ENDIF



  140 MACMAX = NINT(NDSAVE*ALOGM2)

      M_06%MFM(0) = MIN(M_06%MFM(0),MACCA,MACMAX)



      M_GAMMA_MA = M_12

      M_GAMMA_MB = M_06

      NDGGAM = NDIG

      IF (ABS(M_GAMMA_MB%MFM(1)) > MEXPOV) NDGGAM = 0

      MBSGAM = MBASE



      CALL FMEXT2(M_06%MFM,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

      USE FMZM

      IMPLICIT NONE



      DOUBLE PRECISION MX(0:LUNPCK),MA(0:LUNPCK),MB(0:LUNPCK),  &

                       MC(0:LUNPCK)



!             Scratch array usage during FMIBTA:  M_01 - M_29



      DOUBLE PRECISION 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



      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



      KACCSW = 1

      MACCX = MX(0)

      MACCA = MA(0)

      MACCB = MB(0)

      CALL FMEQ2(MX,M_20%MFM,NDSAVE,NDIG,0)

      M_20%MFM(0) = NINT(NDIG*ALOGM2)

      CALL FMEQ2(MA,M_21%MFM,NDSAVE,NDIG,0)

      M_21%MFM(0) = NINT(NDIG*ALOGM2)

      CALL FMEQ2(MB,M_22%MFM,NDSAVE,NDIG,0)

      M_22%MFM(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

          M_21 = HUGE(M_20)

          M_21%MFM(1) = MXSAVE + 1

          KBIGAB = -1

      ENDIF

      IF (MB(1) == MEXPOV) THEN

          M_22 = HUGE(M_20)

          M_22%MFM(1) = MXSAVE + 1

          KBIGAB = -1

      ENDIF

      IF (MX(1) == MEXPUN) THEN

          M_20 = HUGE(M_20)

          M_20%MFM(1) = MXSAVE + 1

          M_20 = 1 / M_20

          KBIGAB = -1

      ENDIF

      IF (MA(1) == MEXPUN) THEN

          M_21 = HUGE(M_20)

          M_21%MFM(1) = MXSAVE + 1

          M_21 = 1 / M_21

          IF (KBIGAB < 0) THEN

              KBIGAB = -9

              M_09 = 0

              GO TO 200

          ELSE

              KBIGAB = 1

          ENDIF

      ENDIF

      IF (MB(1) == MEXPUN) THEN

          IF (M_20 /= 1) THEN

              M_22 = 0

          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).



      M_24 = (.11709*M_21 + .62633*M_22 + 1.0)/  &

           (.00173*M_21**2 + .01253*M_22**2 +  &

            .21583*M_21 + .03891*M_22 + 9.14350)

      M_25 = (.29217*M_21 + 2.09304*M_22 + 1.0)/  &

           (.0000*M_21**2 + .0000*M_22**2 +  &

            .29217*M_21 + 2.09304*M_22 + 1.53724)

      M_26 = (.87312*M_21 + .20334*M_22 + 1.0)/  &

           (.04038*M_21**2 + .05754*M_22**2 +  &

            .02670*M_21 + .56206*M_22 + 0.13746)

      M_27 = (.64584*M_21 + .00000*M_22 + 1.0)/  &

           (.0000*M_21**2 + .0000*M_22**2 +  &

            .64584*M_21 + .64584*M_22 + 6.31958)

      M_28 = (.99773*M_21 + .56855*M_22 + 1.0)/  &

           (.11637*M_21**2 + .10718*M_22**2 +  &

            .92626*M_21 + .05518*M_22 + 0.28962)



      IF (M_20 <= M_24) THEN

          NMETHD = 1

      ELSE IF (M_20 >= M_25) THEN

          NMETHD = 3

      ELSE IF (M_20 < M_28) THEN

          IF (M_20 < M_26) THEN

              NMETHD = 2

          ELSE

              NMETHD = 4

          ENDIF

      ELSE

          IF (M_20 < M_27) THEN

              NMETHD = 5

          ELSE

              NMETHD = 6

          ENDIF

      ENDIF

      IF (M_22%MFM(1) <= 0 .AND. M_21%MFM(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.



!             M_03 and M_09 hold the positive and negative parts

!                 of the current sum.

!             M_05 is the current term.

!             M_06 is J-B.

!             M_07 is 1.

!             M_08 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(M_20%MFM,M_20%MFM,NDIG,NDIG+JEXTRA,1)

          CALL FMEQ2(M_21%MFM,M_21%MFM,NDIG,NDIG+JEXTRA,1)

          CALL FMEQ2(M_22%MFM,M_22%MFM,NDIG,NDIG+JEXTRA,1)

      ENDIF

      NDIG = NDIG + JEXTRA

      M_05 = 1

      M_03 = M_05/M_21

      M_09 = 0

      M_06 = -M_22

      M_08 = M_21

      M_07 = 1

      M_04 = 0

      M_10 = 0

      JCHECK = 5

      NDSAV1 = NDIG



!             Method 1 summation loop.



      METHOD1:    DO J = 1, NTERMS

         NDIG = NDSAV1

         M_06 = M_06 + M_07

         IF (M_06%MFM(2) == 0) M_06%MFM(0) = M_07%MFM(0)

         NDIG2 = MIN(NDSAV1,MAX(2,NDSAV1-INT(M_03%MFM(1)-M_05%MFM(1)),  &

                                  NDSAV1-INT(M_09%MFM(1)-M_05%MFM(1))))

         NDIG = NDIG2

         M_05 = M_05*M_06*M_20

         IF (J > 1) M_05 = M_05/J

         NDIG = NDSAV1

         M_08 = M_08 + M_07

         NDIG = NDIG2

         M_04 = M_05/M_08



         NDIG = NDSAV1

         IF (INT(M_04%MFM(2)) < 0) THEN

             M_09 = M_04 + M_09

         ELSE

             M_03 = M_04 + M_03

         ENDIF



         IF (KFLAG < 0) EXIT

         IF (MOD(J,JCHECK) == 0) THEN

             M_04 = M_03 + M_09

             DO K = NDIG+1, 1, -1

                IF (M_04%MFM(K) /= M_10%MFM(K)) THEN

                    M_10 = M_04

                    CYCLE METHOD1

                ENDIF

             ENDDO

             EXIT

         ENDIF

      ENDDO METHOD1



      M_09 = (M_03 + M_09)*(M_20**M_21)



      IF (NMETHD == 1) THEN

          GO TO 180

      ELSE

          GO TO 170

      ENDIF



!             Method 2.  Continued fraction expansion for B(x,a,b).



!             M_10 is the current approximation.

!             M_09 is the previous approximation.

!             M_05, M_06 are the latest numerators (positive part).

!             M_25, M_26 are the latest numerators (negative part).

!             M_07, M_08 are the latest denominators (positive part).

!             M_27, M_28 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(M_20%MFM,M_20%MFM,NDIG,NDIG+JEXTRA,1)

          CALL FMEQ2(M_21%MFM,M_21%MFM,NDIG,NDIG+JEXTRA,1)

          CALL FMEQ2(M_22%MFM,M_22%MFM,NDIG,NDIG+JEXTRA,1)

      ENDIF

      NDIG = NDIG + JEXTRA

      M_05 = 0

      M_06 = 1

      M_07 = 1

      M_08 = 1

      M_25 = 0

      M_26 = 0

      M_27 = 0

      M_28 = 0

      M_09 = 0

      M_10 = 0

      M_11 = (M_21 + M_08)*2

      M_12 = (M_11 - M_08 + M_22)*M_20

      M_16 = M_22*M_20 - M_20*3

      M_17 = (M_21 + M_22)*M_21*M_20

      M_18 = M_16 + 2*M_20

      M_19 = M_21**2 + M_21



      JCHECK = 5



!             Method 2 continued fraction loop.



      DO J = 0, NTERMS

         M_03 = -M_17/M_19

         IF (M_03 >= 0) THEN

             M_05 = M_03*M_05 + M_06

             M_25 = M_03*M_25 + M_26

             M_07 = M_03*M_07 + M_08

             M_27 = M_03*M_27 + M_28

         ELSE

             M_24 = M_05

             M_05 = M_03*M_25 + M_06

             M_25 = M_03*M_24 + M_26

             M_24 = M_07

             M_07 = M_03*M_27 + M_08

             M_27 = M_03*M_24 + M_28

         ENDIF

         M_19 = M_19 + M_11

         J4 = J*4

         M_19 = M_19 + J4

         M_04 = M_18/M_19

         IF (M_04 >= 0) THEN

             M_06 = M_04*M_06 + M_05

             M_26 = M_04*M_26 + M_25

             M_08 = M_04*M_08 + M_07

             M_28 = M_04*M_28 + M_27

         ELSE

             M_24 = M_06

             M_06 = M_04*M_26 + M_05

             M_26 = M_04*M_24 + M_25

             M_24 = M_08

             M_08 = M_04*M_28 + M_07

             M_28 = M_04*M_24 + M_27

         ENDIF



!             Form the quotient and check for convergence.



         IF (MOD(J,JCHECK) == 0) THEN

             M_09 = M_10

             M_10 = (M_06+M_26)/(M_08+M_28)

             IF (KFLAG == -4) THEN

                 M_09%MFM(0) = -2

                 GO TO 180

             ENDIF

             NGOAL = 1.06*(INT(REAL(NDSAVE)*ALOGM2) + 29)

             IF (M_10%MFM(0) < NGOAL) THEN

                 KICK = -2

                 EXIT

             ENDIF



             M_24 = ABS(M_10-M_09)

             IF (J >= 1000*(NUMTRY+1)) THEN

                 IF (M_24 > M_29) THEN

                     KICK = -2

                     EXIT

                 ENDIF

             ENDIF

             M_29 = M_24

             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 (M_09%MFM(K) /= M_10%MFM(K)) GO TO 140

             ENDDO

             EXIT

         ENDIF



  140    M_19 = M_19 + M_11 + (J*4 + 2)

         M_02 = M_20*(J*2)

         M_17 = M_17 + M_12 + M_02

         M_18 = M_18 + M_16 - M_02

      ENDDO



      M_07 = LOG(M_20)*M_21

      IF (M_20%MFM(1)*(-10) >= NDIG) THEN

          M_03 = M_20

          M_08 = M_20

          DO K = 2, NTERMS

             M_03 = M_03*M_20

             M_08 = M_08 + M_03/K

             IF (KFLAG /= 0) EXIT

          ENDDO

          M_08 = -M_08*M_22

      ELSE

          M_08 = LOG(1 - M_20)*M_22

      ENDIF

      M_09 = M_10*EXP(M_07 + M_08)

      IF (M_09%MFM(1) == MUNKNO) THEN

          IF (M_10 > 0) THEN

              M_09 = EXP(LOG(M_10) + M_07 + M_08)

          ELSE

              M_09 = -EXP(LOG(-M_10) + M_07 + M_08)

          ENDIF

      ENDIF

      IF (ABS(M_09%MFM(1)) < MEXPOV) M_09 = M_09/M_21

      IF (NMETHD == 2) THEN

          GO TO 180

      ELSE

          GO TO 170

      ENDIF



!             Method 5.  Continued fraction expansion 2 for B(x,a,b).



!             M_10 is the current approximation.

!             M_09 is the previous approximation.

!             M_05, M_06 are the latest numerators (positive part).

!             M_25, M_26 are the latest numerators (negative part).

!             M_07, M_08 are the latest denominators (positive part).

!             M_27, M_28 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(M_20%MFM,M_20%MFM,NDIG,NDIG+JEXTRA,1)

          CALL FMEQ2(M_21%MFM,M_21%MFM,NDIG,NDIG+JEXTRA,1)

          CALL FMEQ2(M_22%MFM,M_22%MFM,NDIG,NDIG+JEXTRA,1)

      ENDIF

      NDIG = NDIG + JEXTRA

      KPTMJ1 = 0

      KPTMJ2 = (LUNPCK+2)

      KPTMJ3 = 2*(LUNPCK+2)

      KPTMJ4 = 3*(LUNPCK+2)

      KPTMJ5 = 4*(LUNPCK+2)

      KPTMJ6 = 5*(LUNPCK+2)

      KPTMJ7 = 6*(LUNPCK+2)



      M_05 = 0

      M_06 = 1

      M_07 = 1

      M_09 = 0

      M_10 = 0



      M_14 = M_21 - M_06

      CALL FMSUB(M_14%MFM,M_06%MFM,MJSUMS(KPTMJ5))

      CALL FMSQR(M_20%MFM,MJSUMS(KPTMJ4))



      IF (NMETHD == 6) THEN

          M_13 = M_21 - (M_21 + M_22)*M_20

          CALL FMEQ2(MX,M_12%MFM,NDSAVE,NDIG,0)

          M_15 = (M_21 + M_22)*M_12 - M_22

          IF (M_13%MFM(0) > M_15%MFM(0)) M_15 = M_13

      ELSE

          M_15 = M_21 - (M_21 + M_22)*M_20

      ENDIF

      IF (M_15%MFM(0) == 0 .AND. M_15%MFM(2) == 0) THEN

          M_15%MFM(0) = M_06%MFM(0)

      ENDIF



      M_12 = 0

      M_13 = M_14*M_14



      CALL FMMPY(MJSUMS(KPTMJ4),MJSUMS(KPTMJ5),M_02%MFM)

      CALL FMADD(MJSUMS(KPTMJ5),M_22%MFM,M_03%MFM)

      M_02 = M_02*M_03

      M_03 = M_22 + M_06

      CALL FMMPY(M_02%MFM,M_03%MFM,MJSUMS(KPTMJ1))



      CALL FMSUB(MJSUMS(KPTMJ5),M_06%MFM,M_02%MFM)

      CALL FMMPY(MJSUMS(KPTMJ5),M_02%MFM,M_02%MFM)

      M_03 = (M_14 + M_22)*M_22

      M_02 = (M_03 - M_02)*2

      CALL FMMPY(M_02%MFM,MJSUMS(KPTMJ4),MJSUMS(KPTMJ2))



      CALL FMMPY(MJSUMS(KPTMJ4),MJSUMS(KPTMJ5),M_02%MFM)

      CALL FMMPYI(M_02%MFM,-6,MJSUMS(KPTMJ3))



      CALL FMMPYI(MJSUMS(KPTMJ4),-4,MJSUMS(KPTMJ4))



      CALL FMMPYI(MJSUMS(KPTMJ5),4,M_11%MFM)



      M_02 = (M_22 + 4 - M_21)*M_20

      CALL FMADD(MJSUMS(KPTMJ5),M_15%MFM,M_03%MFM)

      M_03 = M_02 + 3*M_03

      CALL FMMPY(M_03%MFM,M_14%MFM,MJSUMS(KPTMJ5))



      M_02 = (M_21*(-2) + M_22 + 3)*M_20

      M_03 = 5*M_21

      M_02 = M_02 + M_03 + M_15 - 6

      CALL FMMPYI(M_02%MFM,4,MJSUMS(KPTMJ6))



      M_02 = M_20 - 2

      CALL FMMPYI(M_02%MFM,-12,MJSUMS(KPTMJ7))



      M_15 = (M_06 + M_15)*M_21*M_14



      M_16 = (M_06 + M_21)*M_14



      M_14 = 4*M_14

      M_08 = M_15/M_16

      M_25 = 0

      M_26 = 0

      M_27 = 0

      M_28 = 0

      IF (M_08 < 0) THEN

          M_28 = M_08

          M_08 = 0

      ENDIF

      JCHECK = 5



!             Method 5 continued fraction loop.



      METHOD5:    DO J = 1, NTERMS

         CALL FMMPYI(MJSUMS(KPTMJ4),J,M_02%MFM)

         CALL FMADD(M_02%MFM,MJSUMS(KPTMJ3),M_02%MFM)

         M_02 = M_02*J

         CALL FMADD(M_02%MFM,MJSUMS(KPTMJ2),M_02%MFM)

         M_02 = M_02*J

         CALL FMADD(M_02%MFM,MJSUMS(KPTMJ1),M_02%MFM)



         CALL FMADDI(M_11%MFM,8)

         M_12 = M_12 + M_02

         M_13 = M_13 + M_11

         M_02 = M_12/M_13



         CALL FMMPYI(MJSUMS(KPTMJ7),J,M_03%MFM)

         CALL FMADD(M_03%MFM,MJSUMS(KPTMJ6),M_03%MFM)

         M_03 = M_03*J

         CALL FMADD(M_03%MFM,MJSUMS(KPTMJ5),M_03%MFM)



         CALL FMADDI(M_14%MFM,8)



         M_15 = M_15 + M_03

         M_16 = M_16 + M_14

         M_03 = M_15/M_16



         IF (M_02 >= 0 .AND. M_03 >= 0) THEN

             M_04 = M_02*M_05 + M_03*M_06

             M_24 = M_02*M_25 + M_03*M_26

             M_05 = M_06

             M_06 = M_04

             M_25 = M_26

             M_26 = M_24

             M_04 = M_02*M_07 + M_03*M_08

             M_24 = M_02*M_27 + M_03*M_28

             M_07 = M_08

             M_08 = M_04

             M_27 = M_28

             M_28 = M_24

         ELSE IF (M_02 >= 0 .AND. M_03 < 0) THEN

             M_04 = M_02*M_05 + M_03*M_26

             M_24 = M_02*M_25 + M_03*M_06

             M_05 = M_06

             M_06 = M_04

             M_25 = M_26

             M_26 = M_24

             M_04 = M_02*M_07 + M_03*M_28

             M_24 = M_02*M_27 + M_03*M_08

             M_07 = M_08

             M_08 = M_04

             M_27 = M_28

             M_28 = M_24

         ELSE IF (M_02 < 0 .AND. M_03 >= 0) THEN

             M_04 = M_02*M_25 + M_03*M_06

             M_24 = M_02*M_05 + M_03*M_26

             M_05 = M_06

             M_06 = M_04

             M_25 = M_26

             M_26 = M_24

             M_04 = M_02*M_27 + M_03*M_08

             M_24 = M_02*M_07 + M_03*M_28

             M_07 = M_08

             M_08 = M_04

             M_27 = M_28

             M_28 = M_24

         ELSE

             M_04 = M_02*M_25 + M_03*M_26

             M_24 = M_02*M_05 + M_03*M_06

             M_05 = M_06

             M_06 = M_04

             M_25 = M_26

             M_26 = M_24

             M_04 = M_02*M_27 + M_03*M_28

             M_24 = M_02*M_07 + M_03*M_08

             M_07 = M_08

             M_08 = M_04

             M_27 = M_28

             M_28 = M_24

         ENDIF



!             Form the quotient and check for convergence.



         IF (MOD(J,JCHECK) == 0) THEN

             M_09 = M_10

             M_10 = (M_06+M_26)/(M_08+M_28)

             IF (KFLAG == -4) THEN

                 M_09%MFM(0) = -2

                 GO TO 180

             ENDIF

             NGOAL = 1.06*(INT(REAL(NDSAVE)*ALOGM2) + 29)

             IF (M_10%MFM(0) < NGOAL) THEN

                 KICK = -2

                 EXIT

             ENDIF



             M_24 = ABS(M_10-M_09)

             IF (J >= 1000*(NUMTRY+1)) THEN

                 IF (M_24 > M_29) THEN

                     KICK = -2

                     EXIT

                 ENDIF

             ENDIF

             M_29 = M_24

             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 (M_09%MFM(K) /= M_10%MFM(K)) CYCLE METHOD5

             ENDDO

             EXIT

         ENDIF



      ENDDO METHOD5



      IF (M_20 == 1 .AND. NMETHD == 6) THEN

          CALL FMEQ2(MX,M_07%MFM,NDSAVE,NDIG,0)

          M_07 = -M_07*M_21

      ELSE IF (MX(1) <= -1 .AND. NMETHD == 6) THEN

          CALL FMEQ2(MX,M_07%MFM,NDSAVE,NDIG,0)

          M_03 = M_07

          M_08 = M_07

          DO K = 2, NTERMS

             M_03 = M_03*M_07

             M_08 = M_08 + M_03/K

             IF (KFLAG /= 0) EXIT

          ENDDO

          M_07 = -M_08*M_21

      ELSE

          M_07 = LOG(M_20)*M_21

      ENDIF

      IF (NMETHD == 6) THEN

          CALL FMEQ2(MX,M_08%MFM,NDSAVE,NDIG,0)

          M_08 = LOG(M_08)*M_22

      ELSE IF (M_20%MFM(1) <= -1) THEN

          M_03 = M_20

          M_08 = M_20

          DO K = 2, NTERMS

             M_03 = M_03*M_20

             M_08 = M_08 + M_03/K

             IF (KFLAG /= 0) EXIT

          ENDDO

          M_08 = -M_08*M_22

      ELSE

          M_08 = LOG(1 - M_20)*M_22

      ENDIF

      M_09 = EXP(M_07 + M_08)*M_10

      IF (M_09%MFM(1) == MUNKNO) THEN

          IF (M_10 > 0) THEN

              M_09 = EXP(LOG(M_10) + M_07 + M_08)

          ELSE

              M_09 = -EXP(LOG(-M_10) + M_07 + M_08)

          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 = M_20%MFM(0)

      M_20 = 1 - M_20

      M_20%MFM(0) = MLA

      DO J = 0, NDIG+1

         MLA = M_21%MFM(J)

         M_21%MFM(J) = M_22%MFM(J)

         M_22%MFM(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

      M_18 = M_09

      CALL FMBETA(M_21%MFM,M_22%MFM,M_23%MFM)

      NWDS1 = INT(MAX(M_23%MFM(1),M_18%MFM(1)))

      M_09 = M_23 - M_18

      NWDS1 = MAX(0,NWDS1-INT(M_09%MFM(1)))

      IF (K /= NWDS1 .AND. NUMTRY >= 1) THEN

          IF (KASHIFT == 0 .AND. KBSHIFT == 0) M_09%MFM(0) = -1

      ENDIF



!             Check for too much cancellation.



  180 K = KFLAG

      IF (KICK < 0) M_09%MFM(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. M_09%MFM(0) > 0) THEN

          CALL FMEQ2(MX,M_10%MFM,NDSAVE,NDIG,0)

          CALL FMEQ2(MA,M_11%MFM,NDSAVE,NDIG,0)

          CALL FMEQ2(MB,M_12%MFM,NDSAVE,NDIG,0)

          IF (KBSHIFT > 0) M_12 = M_12 + KBSHIFT

          M_07 = 1

          M_04 = M_11 + M_12

          M_08 = M_04/(M_11+1)

          M_05 = 1 - M_10

          M_06 = M_10

          M_07 = M_07 + M_08*M_10

          DO J = 2, KASHIFT-1

             M_08 = M_08*(M_04+(J-1))/(M_11+J)

             M_06 = M_06*M_10

             M_07 = M_07 + M_08*M_06

          ENDDO

          IF (M_10%MFM(1)*(-10) >= NDIG) THEN

              M_03 = M_10

              M_05 = M_10

              DO K = 2, NTERMS

                 M_03 = M_03*M_10

                 M_05 = M_05 + M_03/K

                 IF (KFLAG /= 0) EXIT

              ENDDO

              M_06 = EXP(-M_05*M_12)

              M_03 = M_07

              M_07 = M_07*M_10**M_11*M_06/M_11

              IF (M_07%MFM(1) == MUNKNO) THEN

                  M_07 = EXP(LOG(M_03)+M_11*LOG(M_10)-M_05*M_12-LOG(M_11))

              ENDIF

          ELSE

              M_07 = M_07*M_10**M_11*M_05**M_12/M_11

          ENDIF

          M_08 = M_09*M_08*(M_04+(KASHIFT-1))/M_11

          M_09 = M_08 + M_07

      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. M_09%MFM(0) > 0) THEN

          CALL FMEQ2(MX,M_10%MFM,NDSAVE,NDIG,0)

          CALL FMEQ2(MA,M_11%MFM,NDSAVE,NDIG,0)

          CALL FMEQ2(MB,M_12%MFM,NDSAVE,NDIG,0)

          M_07 = 1

          M_08 = (M_11+M_12)/(M_12+1)

          M_04 = M_11 + M_12

          M_05 = 1 - M_10

          M_06 = M_05

          M_07 = M_07 + M_08*M_06

          DO J = 2, KBSHIFT-1

             M_08 = M_08*(M_04+(J-1))/(M_12+J)

             M_06 = M_06*M_05

             M_07 = M_07 + M_08*M_06

          ENDDO

          IF (M_10%MFM(1)*(-10) >= NDIG) THEN

              M_03 = M_10

              M_05 = M_10

              DO K = 2, NTERMS

                 M_03 = M_03*M_10

                 M_05 = M_05 + M_03/K

                 IF (KFLAG /= 0) EXIT

              ENDDO

              M_05 = EXP(-M_05*M_12)

              M_07 = M_07*M_10**M_11*M_05/M_12

          ELSE

              M_07 = M_07*M_10**M_11*M_05**M_12/M_12

          ENDIF

          M_08 = M_09*M_08*(M_04+(KBSHIFT-1))/M_12

          M_09 = M_08 - M_07

      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 (M_09%MFM(0) <= NGOAL) THEN

          IF (NUMTRY > 0) THEN

              IF (M_09%MFM(2) == 0 .OR. K < 0) GO TO 190

              DO J = 1, NDGOAL+1

                 IF (MRETRY(J) /= M_09%MFM(J)) GO TO 190

              ENDDO

              M_03 = 1

              M_09%MFM(0) = M_03%MFM(0)

              GO TO 200

          ENDIF

  190     IEXTRA = INT(REAL(NGOAL-M_09%MFM(0))/ALOGM2 + 23.03/ALOGMB) + 1

          NDOLD = NDIG

          NDIG = NDIG + IEXTRA

          IF (M_09%MFM(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 FM_ST2M('UNKNOWN',M_09)

              GO TO 200

          ENDIF

          CALL FMEQ2(M_20%MFM,M_20%MFM,NDSAVE,NDIG,1)

          CALL FMEQ2(M_21%MFM,M_21%MFM,NDSAVE,NDIG,1)

          CALL FMEQ2(M_22%MFM,M_22%MFM,NDSAVE,NDIG,1)

          IF (NMETHD == 3 .OR. NMETHD == 4 .OR. NMETHD == 6) THEN

              CALL FMEQ2(MX,M_20%MFM,NDSAVE,NDIG,0)

              DO J = 0, NDIG+1

                 MLA = M_21%MFM(J)

                 M_21%MFM(J) = M_22%MFM(J)

                 M_22%MFM(J) = MLA

              ENDDO

          ENDIF



          IF (KASHIFT > 0) THEN

              CALL FMEQ2(MA,M_21%MFM,NDSAVE,NDIG,0)

              IF (KASHIFT <= 2000) THEN

                  KASHIFT = 9*KASHIFT

              ELSE

                  KASHIFT = NDIG

              ENDIF

              M_21 = M_21 + KASHIFT

          ENDIF

          IF (KBSHIFT > 0) THEN

              CALL FMEQ2(MB,M_22%MFM,NDSAVE,NDIG,0)

              IF (KBSHIFT <= 2000) THEN

                  KBSHIFT = 9*KBSHIFT

              ELSE

                  KBSHIFT = NDIG

              ENDIF

              M_22 = M_22 + 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.



          IF (NUMTRY == 0 .AND. M_21 <= 200 .AND. M_22 >= M_21) THEN

              KASHIFT = 2*NDIG

              M_21 = M_21 + 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.



          IF (NUMTRY == 0 .AND. M_21 >= 100 .AND. M_22 <= 2) THEN

              KBSHIFT = 2*NDIG

              M_22 = M_22 + 2*NDIG

          ENDIF



          IF (NUMTRY > 0 .AND. KASHIFT == 0 .AND. M_21 <= 40*NUMTRY .AND.  &

              M_22 >= 100) THEN

              KASHIFT = 2*NDIG

              M_21 = M_21 + 2*NDIG

          ENDIF



          IF (NUMTRY > 0 .AND. KBSHIFT == 0 .AND. M_21 >= 100 .AND.  &

              M_22 <= 40*NUMTRY) THEN

              KBSHIFT = 2*NDIG

              M_22 = M_22 + 2*NDIG

          ENDIF



          NUMTRY = NUMTRY + 1

          CALL FMEQ2(M_09%MFM,MRETRY,NDOLD,NDIG,0)

          IF (KASHIFT == 2*NDIG .OR. KBSHIFT == 2*NDIG) THEN

              NDIG = MAX(NDIG,NDOLD+2)

          ENDIF

          GO TO 110

      ENDIF



  200 MACMAX = NINT(NDSAVE*ALOGM2)

      M_09%MFM(0) = MIN(M_09%MFM(0),MACCX,MACCA,MACCB,MACMAX)

      IF (KBIGAB /= 0) THEN

          IF ((M_09%MFM(1) >= -MXSAVE  .AND. KBIGAB == -1) .OR.  &

              (M_09%MFM(1) <= MXSAVE+1 .AND. KBIGAB ==  1) .OR.  &

              (KBIGAB == -9)) THEN

              CALL FM_ST2M('UNKNOWN',M_09)

              KFLAG = -4

          ENDIF

      ENDIF

      CALL FMEXT2(M_09%MFM,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

      USE FMZM

      IMPLICIT NONE



      DOUBLE PRECISION 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 /)



      K_RETURN_CODE = 0

      M_23 = 0

      M_29 = HUGE(M_20)

      NDSAV1 = NDIG



!             If B is small, use more guard digits.



      IF (M_22 <= 1.0D-10) THEN

          IEXTRA = NGRD52

          IF (NDIG+IEXTRA <= NDG2MX) THEN

              CALL FMEQ2(M_20%MFM,M_20%MFM,NDIG,NDIG+IEXTRA,1)

              CALL FMEQ2(M_21%MFM,M_21%MFM,NDIG,NDIG+IEXTRA,1)

              CALL FMEQ2(M_22%MFM,M_22%MFM,NDIG,NDIG+IEXTRA,1)

          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 FM_ST2M('UNKNOWN',M_09)

             K_RETURN_CODE = 2

             RETURN

          ENDIF

      ENDIF



      NTERMS = INT(INTMAX/10)

      NMETHD = 0



!             Check for special cases.



      IF (M_20%MFM(2) == 0) THEN

          M_09 = 0

          K_RETURN_CODE = 1

          RETURN

      ENDIF

      M_16 = 1

      IF (M_16 == M_20) THEN

          CALL FMBETA(M_21%MFM,M_22%MFM,M_19%MFM)

          M_19%MFM(0) = 1.06*M_19%MFM(0)

          M_09 = M_19

          K_RETURN_CODE = 1

          RETURN

      ELSE IF (M_20%MFM(2) < 0 .OR. M_20 > M_16) THEN

          CALL FM_ST2M('UNKNOWN',M_09)

          KFLAG = -4

          K_RETURN_CODE = 2

          RETURN

      ENDIF

      IF (M_21%MFM(2) < 0) THEN

          CALL FM_ST2M('UNKNOWN',M_09)

          KFLAG = -4

          K_RETURN_CODE = 2

          RETURN

      ENDIF

      IF (M_22%MFM(2) < 0) THEN

          CALL FM_ST2M('UNKNOWN',M_09)

          KFLAG = -4

          K_RETURN_CODE = 2

          RETURN

      ENDIF

      IF (M_21%MFM(1) < (-NDIG) .AND. M_22%MFM(1) < (-NDIG)) THEN

          M_09 = (M_16/M_21 - LOG(M_16-M_20))*(M_20**M_21)

          K_RETURN_CODE = 1

          RETURN

      ENDIF

      IF (M_20*(1-M_22)+M_16 == M_16) THEN

          M_09 = EXP(M_21*LOG(M_20)-LOG(M_21))

          K_RETURN_CODE = 2

          RETURN

      ENDIF



!             When A or B is large, check for an underflowed result.



      IF (M_21 > 1.0E7 .OR. M_22 > 1.0E7) THEN



!             If B is much larger than A, approximate BETA(A,B) and use

!             that as an upper bound.



          IF (M_22%MFM(1) >= M_21%MFM(1)+NDIG) THEN

              M_11 = M_21*LOG(M_22+M_21)

              M_15 = M_21

              CALL FMLNGM(M_15%MFM,M_12%MFM)

              M_09 = EXP(M_12 - M_11)

              IF (M_09%MFM(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)



          IF (M_21 > 2 .AND. M_22 < 2) THEN

              M_11 = MIN(M_20,(M_21-2)/(M_21+M_22-2))

              M_15 = LOG(M_21-1) + LOG(M_20) - LOG(M_22) + (M_21-2)*LOG(M_11)  &

                     + M_22*LOG(1-M_11)

              M_09 = EXP(M_15)

              IF (M_09%MFM(1) <= -MXSAVE-1) THEN

                  K_RETURN_CODE = 2

                  RETURN

              ENDIF

              M_11 = MIN(M_20,(M_21-1)/(M_21+M_22-2))

              M_15 = M_21*LOG(M_20) + (M_22-1)*LOG(1-M_11)

              M_09 = EXP(M_15)

              IF (M_09%MFM(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)



          IF (M_21 > 2 .AND. M_22 > 2) THEN

              M_11 = MIN(M_20,(M_21-1)/(M_21+M_22-2))

              M_15 = LOG(M_20) + (M_21-1)*LOG(M_11) + (M_22-1)*LOG(1-M_11)

              M_09 = EXP(M_15)

              IF (M_09%MFM(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.



      IF (M_21 > 1 .AND. M_21+M_22 > 2) THEN

          M_19 = (M_21 - 1)/(M_21 + M_22 - 2)

          IF (M_19 < 1 .AND. M_20 > M_19 .AND. (M_21+M_22-3) /= 0) THEN

              M_18 = (M_21-1)*(M_22-1)/(M_21+M_22-3)

              IF (M_18 >= 0) THEN

                  M_18 = ( (M_21-1) + SQRT(M_18) ) / (M_21+M_22-2)

              ELSE

                  M_18 = 1.1

              ENDIF

              IF (M_18 > M_19 .AND. M_18 < 1 .AND. M_20 >= M_18) THEN



!                 Approximate B(A,B).



                  IF (M_21+M_22 == M_21) THEN

                      M_17 = (M_22-0.5D0)*LOG(M_22) - M_22 - DLOGTP/2 -  &

                             M_22*LOG(M_21)

                  ELSE IF (M_21+M_22 == M_22) THEN

                      M_17 = (M_21-0.5D0)*LOG(M_21) - M_21 - DLOGTP/2 -  &

                             M_21*LOG(M_22)

                  ELSE

                      M_17 = (M_21-0.5D0)*LOG(M_21) + (M_22-0.5D0)*LOG(M_22)  &

                             - (M_21+M_22-0.5D0)*LOG(M_21+M_22) - DLOGTP/2

                  ENDIF

                  M_17 = EXP(M_17)



!                 Bound the area from X to 1.



                  IF (1-M_20 == 1) THEN

                      M_16 = (M_21-1)*LOG(M_20) - M_20*(M_22-1) -  &

                             LOG((1-M_20)/2)

                  ELSE

                      M_16 = (M_21-1)*LOG(M_20) + (M_22-1)*LOG(1-M_20) +  &

                             LOG((1-M_20)/2)

                  ENDIF

                  M_16 = EXP(M_16)

                  IF (M_17-M_16 == M_17) THEN

                      M_24 = M_16

                      CALL FMBETA(M_21%MFM,M_22%MFM,M_19%MFM)

                      IF (M_19-M_24 == M_19) THEN

                          M_19%MFM(0) = 1.06*M_19%MFM(0)

                          M_09 = M_19

                          K_RETURN_CODE = 1

                          RETURN

                      ENDIF

                  ENDIF

              ENDIF

          ENDIF

      ELSE IF (M_21 < 1 .AND. M_22 > 1) THEN



!                 Approximate B(A,B).



          IF (M_21+M_22 == M_21) THEN

              M_17 = (M_22-0.5D0)*LOG(M_22) - M_22 - DLOGTP/2 -  &

                     M_22*LOG(M_21)

          ELSE IF (M_21+M_22 == M_22) THEN

              M_17 = (M_21-0.5D0)*LOG(M_21) - M_21 - DLOGTP/2 -  &

                     M_21*LOG(M_22)

          ELSE

              M_17 = (M_21-0.5D0)*LOG(M_21) + (M_22-0.5D0)*LOG(M_22) -  &

                     (M_21+M_22-0.5D0)*LOG(M_21+M_22) - DLOGTP/2

          ENDIF

          M_17 = EXP(M_17)



!                 Bound the area from X to 1.



          IF (1-M_20 == 1) THEN

              M_16 = (M_21-1)*LOG(M_20) - M_20*(M_22-1) -  &

                     LOG((1-M_20)/2)

              M_16 = EXP(M_16)

          ELSE

              M_16 = (M_21-1)*LOG(M_20) + (M_22-1)*LOG(1-M_20) +  &

                     LOG((1-M_20)/2)

              M_16 = EXP(M_16)

          ENDIF

          IF (M_17-M_16 == M_17) THEN

              CALL FMBETA(M_21%MFM,M_22%MFM,M_19%MFM)

              M_19%MFM(0) = 1.06*M_19%MFM(0)

              M_09 = M_19

              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.



      IF ((1+M_22 == 1 .AND. M_21+M_22 == M_21) ) THEN

          IF (M_20 <= 0.5) THEN

              M_10 = 0

              M_11 = M_20

              M_12 = M_11/(M_21+1)

              NDSAV1 = NDIG

              DO J = 2, NTERMS

                 M_10 = M_10 + M_12

                 IF (KFLAG /= 0 .AND. J >= 3) EXIT

                 NDIG = MIN(NDSAV1,MAX(2,NDSAV1-INT(M_10%MFM(1)-M_12%MFM(1))+1))

                 M_11 = M_11*M_20

                 M_12 = M_11/(M_21+J)

                 NDIG = NDSAV1

              ENDDO

              M_10 = M_20**M_21*(1/M_21 + M_10)

              M_09 = M_10

              K_RETURN_CODE = 1

              RETURN

          ENDIF

          IF ((M_20 > 0.5 .AND. M_21 < 20)) THEN

              M_10 = 0

              M_13 = 1 - M_20

              M_11 = (1-M_21)*M_13**(M_22+1)

              M_12 = M_11

              NDSAV1 = NDIG

              DO J = 2, NTERMS

                 M_10 = M_10 + M_12

                 IF (KFLAG /= 0 .AND. J >= 3) EXIT

                 NDIG = MIN(NDSAV1,MAX(2,NDSAV1-INT(M_10%MFM(1)-M_12%MFM(1))+1))

                 M_11 = M_11*(J-M_21)*M_13/J

                 M_12 = M_11/J

                 NDIG = NDSAV1

              ENDDO

              M_11 = 1/M_21 - LOG(M_13) - M_10

              CALL FMEULR(M_12%MFM)

              M_13 = M_21 + 1

              CALL FMPSI(M_13%MFM,M_13%MFM)

              M_09 = M_11 - M_12 - M_13

              K_RETURN_CODE = 1

              RETURN

          ENDIF



          IF ((M_20 > 0.5 .AND. M_21 >= 20)) THEN

              M_16 = 0.7*REAL(NDIG)*ALOGMT

              IF (M_21 >= M_16) THEN

                  NUP = 0

                  M_23 = M_21

                  M_24 = 0

              ELSE

                  NUP = M_16 - M_21 + 1

                  M_23 = M_21 + NUP

                  M_24 = 1

                  M_11 = M_21

                  NDSAV1 = NDIG

                  DO J = 1, NUP-1

                     M_11 = M_11*M_20

                     M_12 = M_11/(M_21+J)

                     NDIG = NDSAV1

                     M_24 = M_24 + M_12

                     NDIG = MIN(NDSAV1,  &

                             MAX(2,NDSAV1-INT(M_24%MFM(1)-M_12%MFM(1))+1))

                  ENDDO

                  NDIG = NDSAV1

                  M_24 = M_24*M_20**M_21*(1-M_20)**M_22/M_21

              ENDIF



              M_17 = M_23 - TO_FM(1)/TO_FM(2)

              M_18 = -M_17*LOG(M_20)

              CALL FMIGM2(M_22%MFM,M_18%MFM,M_19%MFM)

              M_19 = M_19/(EXP(-M_18)*M_18**M_22)

              M_10 = M_19

              M_11 = 4*M_17*M_17

              M_12 = 1

              M_13 = 1

              M_14 = 1

              M_16 = (LOG(M_20)/2)**2

              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

                     M_13 = M_13*4

                     M_14 = ((2*J-1)*M_14)*(2*J)

                     M_15 = (2-M_13)/M_14

                     CALL FMBERN(2*J,M_15%MFM,M_15%MFM)

                 ELSE

                     IF (J4 == 0) THEN

                         J4 = 1

                         N = 2*J

                         DO K = 1, 8

                            KPT = (K-1)*(NDSAV1+2)

                            CALL FMI2M(KPRIME(K),MJSUMS(KPT))

                            CALL FMIPWR(MJSUMS(KPT),N,MJSUMS(KPT))

                         ENDDO

                     ELSE

                         DO K = 1, 8

                            KPT = (K-1)*(NDSAV1+2)

                            CALL FMMPYI(MJSUMS(KPT),KPRIME(K)**2,MJSUMS(KPT))

                         ENDDO

                     ENDIF

                     CALL FM_PI(M_06)

                     M_02 = 1

                     M_03 = 1

                     DO K = 1, 8

                        KPT = (K-1)*(NDSAV1+2)

                        CALL FMEQ(MJSUMS(KPT),M_05%MFM)

                        M_04 = M_02 - (KPRIME(K)**2 - 1)/(M_05 - M_02)

                        IF (M_04 == 1) EXIT

                        M_03 = M_03*M_04

                     ENDDO

                     CALL FMEQ(MJSUMS,M_05%MFM)

                     M_04 = -1/(M_06*M_06)*((2-M_05)/(8-M_05))*M_03

                     M_15 = M_04*M_15

                 ENDIF

                 M_19 = (((M_22+(2*J-2))*M_19)*(2*J-1) + M_12*(M_18+2*J-1))/M_11

                 M_12 = M_12*M_16

                 M_07 = M_15*M_19

                 NDIG = NDSAV1

                 M_10 = M_10 + M_07

                 IF (KFLAG /= 0 .AND. J >= 3) EXIT

                 NDIG = MIN(NDSAV1,MAX(2,NDSAV1-INT(M_10%MFM(1)-M_07%MFM(1))+1))

              ENDDO

              NDIG = NDSAV1

              M_09 = M_24 + M_10*M_20**M_17*(-LOG(M_20))**M_22

              K_RETURN_CODE = 1

              RETURN

          ENDIF

      ENDIF



!             If A or B is large in magnitude, use more guard digits.



      IEXTRA = MIN(MAX(INT(M_21%MFM(1)),INT(M_22%MFM(1)),0) ,  &

                   INT(1.0+ALOGMX/ALOGMB))

      IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN

          CALL FMEQ2(M_20%MFM,M_20%MFM,NDIG,NDIG+IEXTRA,1)

          CALL FMEQ2(M_21%MFM,M_21%MFM,NDIG,NDIG+IEXTRA,1)

          CALL FMEQ2(M_22%MFM,M_22%MFM,NDIG,NDIG+IEXTRA,1)

      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 FM_ST2M('UNKNOWN',M_09)

          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

      USE FMZM

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



!             Scratch array usage during FMIGM1:  M_01 - M_16



      DOUBLE PRECISION FMDPLG,X,A,B,SMALL,BIG,TOL,T1,BIGJ

      DOUBLE PRECISION 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

      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,M_15%MFM,NDSAVE,NDIG,0)

      M_15%MFM(0) = NINT(NDIG*ALOGM2)

      CALL FMEQ2(MB,M_16%MFM,NDSAVE,NDIG,0)

      M_16%MFM(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.



      IF (M_15+1 == 1) THEN

          M_09 = M_16**M_15 / M_15

          IF (M_09%MFM(1) /= MUNKNO) GO TO 180

      ENDIF



!             Check to see if X is large enough so that the result

!             is Gamma(A).



      IF (M_16 > 1 .AND. ABS(M_15/M_16) <= 0.001) THEN

          M_14 = EXP((M_15-1)*LOG(M_16)-M_16)

          IF (M_14%MFM(1) /= MUNKNO) THEN

              CALL FMGAM(M_15%MFM,M_13%MFM)

              IF (M_13%MFM(1) > M_14%MFM(1)+NDIG .AND.  &

                  M_13%MFM(1) /= MUNKNO) THEN

                  M_09 = M_13

                  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

      INTG = M_15

      KFLAGI = KFLAG

      IF (KFLAG == 0) INTA = INTG

      A = M_15

      KFLAGA = KFLAG

      IF (KFLAG /= 0 .AND. M_15%MFM(1) < 0) THEN

          A = 1.0D0/DPMAX

          IF (M_15%MFM(2) < 0) A = -A

          KFLAGA = 0

      ENDIF

      X = M_16

      KFLAGX = KFLAG

      IF (KFLAG /= 0 .AND. M_16%MFM(1) < 0) THEN

          X = 1.0D0/DPMAX

          IF (M_16%MFM(2) < 0) X = -X

          KFLAGX = 0

      ENDIF

      KWARN = KWRNSV



!             If A or X is large in magnitude, use more guard digits.



      IEXTRA = MIN(MAX(INT(M_15%MFM(1)),INT(M_16%MFM(1)),0) ,  &

                   INT(1.0+ALOGMX/ALOGMB))

      IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN

          CALL FMEQ2(M_15%MFM,M_15%MFM,NDIG,NDIG+IEXTRA,1)

          CALL FMEQ2(M_16%MFM,M_16%MFM,NDIG,NDIG+IEXTRA,1)

      ENDIF

      NDOLD = NDIG

      NDIG = NDIG + IEXTRA

      IF (NDIG > NDG2MX) THEN

          KFLAG = -9

          CALL FMWRN2

          NDIG = NDOLD

          CALL FM_ST2M('UNKNOWN',M_09)

          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 (M_15%MFM(1) == MEXPOV .OR. M_16%MFM(1) == MEXPOV) THEN

          IF (M_15%MFM(1) == MEXPOV .AND. M_15%MFM(2) >= 1) THEN

              IF (M_16%MFM(2) == 0) THEN

                  M_09 = 0

                  GO TO 160

              ENDIF

              IF (M_16%MFM(1) == MEXPOV .AND. M_16%MFM(2) >= 1) THEN

                  CALL FM_ST2M('OVERFLOW',M_09)

                  KFLAG = -5

                  GO TO 160

              ELSE IF (M_16%MFM(2) > 0) THEN

                  M_09 = 1

                  IF (M_16 <= M_09) THEN

                      CALL FM_ST2M('UNDERFLOW',M_09)

                      KFLAG = -6

                      GO TO 160

                  ELSE

                      CALL FM_ST2M('OVERFLOW',M_09)

                      KFLAG = -5

                      GO TO 160

                  ENDIF

              ENDIF

          ENDIF

          IF (M_16%MFM(1) == MEXPOV .AND. M_16%MFM(2) >= 1) THEN

              CALL FMGAM(M_15%MFM,M_14%MFM)

              M_09 = M_14

              GO TO 160

          ENDIF

          IF (M_16%MFM(1) == MEXPOV .AND. M_16%MFM(2) <= -1  &

                               .AND. M_15%MFM(2) > 0) THEN

              IF (M_15%MFM(1) /= MEXPOV) THEN

                  M_08 = AINT(M_15)

                  IF (M_15 == M_08) THEN

                      M_05 = 2

                      M_05 = MOD(M_08,M_05)

                      IF (M_05%MFM(2) /= 0) THEN

                          CALL FM_ST2M('-OVERFLOW',M_09)

                          KFLAG = -5

                          GO TO 160

                      ELSE

                          CALL FM_ST2M('OVERFLOW',M_09)

                          KFLAG = -5

                          GO TO 160

                      ENDIF

                  ENDIF

              ENDIF

          ENDIF

          CALL FM_ST2M('UNKNOWN',M_09)

          KFLAG = -4

          GO TO 180

      ENDIF



      IF (M_15%MFM(1) == MEXPUN .OR. M_16%MFM(1) == MEXPUN) THEN

          IF (ABS(M_15) < 1 .AND. M_16%MFM(1) == MEXPUN) THEN

              CALL FM_ST2M('UNKNOWN',M_09)

              KFLAG = -4

              GO TO 180

          ENDIF

          IF (ABS(M_15) >= 1 .AND. M_16%MFM(1) == MEXPUN .AND.  &

              M_16%MFM(2) > 0) THEN

              CALL FM_ST2M('UNDERFLOW',M_09)

              KFLAG = -6

              GO TO 180

          ENDIF

      ENDIF



      IF (M_15%MFM(2) <= 0) THEN

          M_08 = AINT(M_15)

          IF (M_15 == M_08) THEN

              CALL FM_ST2M('UNKNOWN',M_09)

              KFLAG = -4

              GO TO 180

          ENDIF

      ENDIF

      IF (M_16%MFM(2) == 0) THEN

          IF (M_15%MFM(2) <= 0) THEN

              CALL FM_ST2M('UNKNOWN',M_09)

              KFLAG = -4

              GO TO 180

          ELSE

              M_09 = 0

              GO TO 180

          ENDIF

      ENDIF

      IF (M_16%MFM(2) < 0) THEN

          M_08 = AINT(M_15)

          IF (M_15 == M_08) THEN

              KXNEG = 1

              M_05 = 2

              M_05 = MOD(M_08,M_05)

              IF (M_05%MFM(2) /= 0) MODA2 = 1

          ELSE

              CALL FM_ST2M('UNKNOWN',M_09)

              KFLAG = -4

              GO TO 180

          ENDIF

      ENDIF

      IF (MAX(M_15,M_16) >= 1.0D6 .AND. MIN(M_15,M_16) >= 100.0) THEN

          M_02 = M_15 - 1

          M_04 = MIN(M_02,M_16) - 1

          M_06 = EXP(-M_04 + M_02*LOG(M_04))

          IF ((M_06%MFM(1) == MEXPOV .AND. M_06%MFM(2) >= 1) .OR.  &

              M_06%MFM(1) > MXSAVE+1) THEN

              CALL FM_ST2M('OVERFLOW',M_09)

              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.



      M_04 = -10000

      M_05 = 10000

      M_07 = ABS(M_15)

      M_08 = ABS(M_16)

      M_06 = M_08 - M_07

      IF (M_06 <= M_04) THEN

          NMETHD = 1

      ELSE IF (M_06 >= M_05 .AND. M_15%MFM(2) > 0  &

               .AND. M_16%MFM(2) > 0) THEN

          NMETHD = 2

      ELSE IF (M_06 >= M_05) THEN

          NMETHD = 3

      ELSE IF (M_15%MFM(2) > 0 .AND. M_16%MFM(2) > 0) THEN

          M_04 = SQRT(DPMAX)

          IF (M_16 >= M_04) THEN

              KFLAG = -5

              CALL FM_ST2M('OVERFLOW',M_09)

              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 (M_15%MFM(2) < 0 .AND. M_16%MFM(2) > 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

              M_04 = C * M_15

              M_04%MFM(2) = ABS(M_04%MFM(2))

              IF (M_16 > M_04) THEN

                  NMETHD = 3

              ELSE

                  NMETHD = 1

              ENDIF

          ENDIF

      ELSE IF (M_15%MFM(2) > 0 .AND. M_16%MFM(2) < 0) THEN

          M_04 = -0.8 * M_15

          IF (M_04 < M_16) 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.



!             M_09 is the current sum.

!             M_05 is the current term.

!             M_04 is (A+N)/X.

!             M_13 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 (M_15%MFM(2) < 0) THEN

          M_09 = ANINT(M_15)

          M_13 = M_15 - M_09

          IEXTRA = MAX(-INT(M_13%MFM(1)),0)

          IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN

              CALL FMEQ2(M_15%MFM,M_15%MFM,NDIG,NDIG+IEXTRA,1)

              CALL FMEQ2(M_16%MFM,M_16%MFM,NDIG,NDIG+IEXTRA,1)

          ENDIF

          NDOLD = NDIG

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDOLD

              CALL FM_ST2M('UNKNOWN',M_09)

              GO TO 180

          ENDIF

      ENDIF



      JEXTRA = 0



  120 M_09 = 1

      M_02 = 1

      M_04 = M_15 + M_02

      M_05 = M_16 / M_04

      M_04 = M_04 / M_16

      M_13 = M_02 / M_16

      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 (M_15%MFM(2) < 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

          IF (ABS(M_15) > ABS(M_16)) 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,M_05%MFM(1))

         M_09 = M_09 + M_05

         IF (KFLAG /= 0) THEN

             IF (KFLGOK == 0 .AND. KFLAGA == 0 .AND. KFLAGX == 0) THEN

                 IF (DBLE(J) > X-A) EXIT

             ELSE

                 EXIT

             ENDIF

         ENDIF



         M_04 = M_04 + M_13



         NDIG2 = MAX(2,NDSAV1-INT(M_09%MFM(1)-M_05%MFM(1)))

         NDIG = MIN(NDSAV1,NDIG2+JEXTRA)

         NMNNDG = MIN(NMNNDG,NDIG)

         NMXDIF = MAX(NMXDIF,NDIG-NMNNDG)

         M_05 = M_05 / M_04

      ENDDO



      NDIG = NDSAV1

      IF (NMXDIF > JEXTRA+1) THEN

          JEXTRA = NMXDIF

          GO TO 120

      ENDIF



      M_13 = M_15 * LOG(ABS(M_16)) - M_16

      M_14 = EXP(M_13)

      M_08 = M_09 / M_15

      M_07 = M_14 * M_08

      IF (M_07%MFM(1) == MUNKNO) THEN

          M_13 = M_13 + LOG(M_09) - LOG(M_15)

          M_09 = EXP(M_13)

      ELSE

          M_09 = M_07

      ENDIF

      IF (KXNEG == 1 .AND. MODA2 == 1 .AND. M_09%MFM(1) /= MUNKNO) THEN

          M_09%MFM(2) = -M_09%MFM(2)

      ENDIF



      GO TO 160



!             Method 2.  Use the Pochhammer(A-N,N)/X**N series.



!             M_09 is the current sum.

!             M_05 is the current term.

!             M_04 is (A-N)/X.

!             M_13 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 (M_15%MFM(2) > 0) THEN

          M_09 = ANINT(M_15)

          M_13 = M_15 - M_09

          IEXTRA = MAX(-INT(M_13%MFM(1)),0)

          IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN

              CALL FMEQ2(M_15%MFM,M_15%MFM,NDIG,NDIG+IEXTRA,1)

              CALL FMEQ2(M_16%MFM,M_16%MFM,NDIG,NDIG+IEXTRA,1)

          ENDIF

          NDOLD = NDIG

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDOLD

              CALL FM_ST2M('UNKNOWN',M_09)

              GO TO 180

          ENDIF

      ENDIF



      CALL FMGAM(M_15%MFM,M_14%MFM)

      IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN

          NT = INT(((A-1)*LOG(ABS(X)+1.0D-10) - X)/DLOGMB)

          LESS = MAX(0,INT(M_14%MFM(1)) - NT - 1)

          IF (LESS > NDIG .AND. ABS(A) < ABS(X)) THEN

              M_09 = M_14

              GO TO 160

          ENDIF

      ENDIF

      IF (KFLAG /= 0) THEN

          M_09 = M_14

          GO TO 160

      ENDIF

      IF (KXNEG == 0) THEN

          M_13 = LOG(M_16)

          M_09 = M_15 * M_13 - M_16

          M_13 = M_09 - M_13

          M_05 = EXP(M_13)

      ELSE

          M_09 = M_15 - 1

          M_13 = M_16 ** M_09

          M_08 = EXP(M_16)

          M_05 = M_13 / M_08

      ENDIF



!             Here M_05 is X**(A-1)/EXP(X).



      M_05%MFM(2) = -M_05%MFM(2)

      M_09 = M_14

      M_04 = M_15 / M_16

      M_13 = 1 / M_16

      M_13%MFM(2) = -M_13%MFM(2)

      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

         M_09 = M_09 + M_05

         IF (KFLAG /= 0 .AND. J > 1) GO TO 140

         M_04 = M_04 + M_13

         IF (REAL(J) >= BIGJ) THEN

             NDIG2 = MAX(2,NDSAV1-INT(M_09%MFM(1)-M_05%MFM(1)))

             NDIG = MIN(NDSAV1,NDIG2)

         ENDIF

         M_05 = M_05 * M_04

      ENDDO



  140 NDIG = NDSAV1

      GO TO 160



!             Method 3.  Use the continued fraction expansion.



!             M_13 is the current approximation.

!             M_09 is the previous approximation.

!             M_05, M_06 are the latest numerators.

!             M_07, M_08 are the latest denominators.



  150 CALL FMGAM(M_15%MFM,M_14%MFM)

      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(M_14%MFM(1)) - NT - 1)

          IF (LESS > NDIG) THEN

              M_09 = M_14

              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(M_15%MFM,M_15%MFM,NDSAV1,NDSAV1+JEXTRA,1)

          CALL FMEQ2(M_16%MFM,M_16%MFM,NDSAV1,NDSAV1+JEXTRA,1)

      ENDIF

      NDIG = NDIG + JEXTRA

      M_05 = 0

      M_06 = 1

      M_07 = 1

      CALL FMEQ2(M_16%MFM,M_08%MFM,NDSAV1,NDIG,0)

      M_13 = 0

      CALL FMEQ2(M_15%MFM,M_04%MFM,NDSAV1,NDIG,0)

      M_04%MFM(2) = -M_04%MFM(2)

      M_03 = 1



      JCHECK = 10

      IF (INTA == 1) M_13 = M_06 / M_16



!             Method 3 continued fraction loop.



      METHOD3:    DO J = 1, MIN(NTERMS,INTA-1)

         M_04 = M_04 + M_03

         M_05 = M_06 + M_04 * M_05

         M_07 = M_08 + M_04 * M_07

         M_06 = M_16 * M_05 + M_06 * J

         M_08 = M_16 * M_07 + M_08 * J



!             Normalize to make overflow or underflow less likely.



         KMID = INT((MAX(M_05%MFM(1),M_06%MFM(1),M_07%MFM(1),M_08%MFM(1)) +  &

                     MIN(M_05%MFM(1),M_06%MFM(1),M_07%MFM(1),M_08%MFM(1))) / 2)

         M_05%MFM(1) = M_05%MFM(1) - KMID

         M_06%MFM(1) = M_06%MFM(1) - KMID

         M_07%MFM(1) = M_07%MFM(1) - KMID

         M_08%MFM(1) = M_08%MFM(1) - KMID



!             Form the quotient and check for convergence.



         IF (MOD(J,JCHECK) == 0 .OR. J == INTA-1) THEN

             M_09 = M_13

             M_13 = M_06 / M_08

             DO K = NDIG-JEXTRA, 1, -1

                IF (M_09%MFM(K) /= M_13%MFM(K)) CYCLE METHOD3

             ENDDO

             EXIT

         ENDIF

      ENDDO METHOD3



      CALL FMEQ2(M_13%MFM,M_13%MFM,NDIG,NDSAV1,1)

      NDIG = NDSAV1

      IF (M_16%MFM(2) > 0) THEN

          M_08 = EXP(M_15 * LOG(M_16) - M_16)

      ELSE IF (KFLAGI == 0) THEN

          M_09 = EXP(M_16)

          M_08 = M_16 ** INTA / M_09

      ELSE

          M_08 = EXP(M_15 * LOG(ABS(M_16)) - M_16)

          IF (MODA2 == 1) M_08%MFM(2) = -M_08%MFM(2)

      ENDIF



      IF (M_08%MFM(1) /= MEXPOV) THEN

          M_09 = M_08 * M_13

      ELSE IF (M_08%MFM(1)+M_13%MFM(1) >= MXEXP2/2) THEN

          M_09 = M_08

          IF (M_13%MFM(2) < 0) M_09%MFM(2) = -M_09%MFM(2)

      ELSE

          M_09 = M_08 * M_13

      ENDIF

      M_09 = M_14 - M_09



!             Check for too much cancellation.



  160 IF (NCALL <= 1) THEN

          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17

      ELSE

          NGOAL = INT(-MXEXP2)

      ENDIF

      IF (M_09%MFM(0) <= NGOAL) THEN

          IF (NUMTRY > 0) THEN

              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)

              DO J = 1, NDGOAL+1

                 IF (MRETRY(J) /= M_09%MFM(J)) GO TO 170

              ENDDO

              GO TO 180

          ENDIF

  170     IEXTRA = INT(REAL(NGOAL-M_09%MFM(0))/ALOGM2 + 23.03/ALOGMB) + 1

          NDOLD = NDIG

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDOLD

              CALL FM_ST2M('UNKNOWN',M_09)

              GO TO 180

          ENDIF

          CALL FMEQ2(M_15%MFM,M_15%MFM,NDSAVE,NDIG,1)

          CALL FMEQ2(M_16%MFM,M_16%MFM,NDSAVE,NDIG,1)

          NUMTRY = NUMTRY + 1

          CALL FMEQ2(M_09%MFM,MRETRY,NDOLD,NDIG,0)

          GO TO 110

      ENDIF



  180 MACMAX = NINT(NDSAVE*ALOGM2)

      M_09%MFM(0) = MIN(M_09%MFM(0),MACCA,MACCB,MACMAX)

      CALL FMEXT2(M_09%MFM,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

      USE FMZM

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK)



!             Scratch array usage during FMIGM2:  M_01 - M_16



      DOUBLE PRECISION FMDPLG,X,A,B,SMALL,BIG,TOL,T1,T2,BIGJ,C1,C2

      DOUBLE PRECISION MA2,MACCA,MACCB,MACMAX,MAXM09,MB2,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



      CALL FMENT2('FMIGM2',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE,  &

                  KOVUN)

      IF (KRESLT /= 0) RETURN



      KACCSW = 1

      MA2 = MA(2)

      MB2 = MB(2)

      MACCA = MA(0)

      MACCB = MB(0)

      CALL FMEQ2(MA,M_15%MFM,NDSAVE,NDIG,0)

      M_15%MFM(0) = NINT(NDIG*ALOGM2)

      CALL FMEQ2(MB,M_16%MFM,NDSAVE,NDIG,0)

      M_16%MFM(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

      INTG = M_15

      KFLAGI = KFLAG

      IF (KFLAG == 0) INTA = INTG

      A = M_15

      KFLAGA = KFLAG

      IF (KFLAG /= 0 .AND. M_15%MFM(1) < 0) THEN

          A = 1.0D0/DPMAX

          IF (M_15%MFM(2) < 0) A = -A

          KFLAGA = 0

      ENDIF

      X = M_16

      KFLAGX = KFLAG

      IF (KFLAG /= 0 .AND. M_16%MFM(1) < 0) THEN

          X = 1.0D0/DPMAX

          IF (M_16%MFM(2) < 0) X = -X

          KFLAGX = 0

      ENDIF

      KWARN = KWRNSV



!             If A or X is large in magnitude use more guard digits.



      IEXTRA = MIN(MAX(INT(M_15%MFM(1)),INT(M_16%MFM(1)),0) ,  &

                   INT(1.0+ALOGMX/ALOGMB))

      IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN

          CALL FMEQ2(M_15%MFM,M_15%MFM,NDIG,NDIG+IEXTRA,1)

          CALL FMEQ2(M_16%MFM,M_16%MFM,NDIG,NDIG+IEXTRA,1)

      ENDIF

      NDIG = NDIG + IEXTRA

      IF (NDIG > NDG2MX) THEN

          KFLAG = -9

          CALL FMWRN2

          NDIG = NDIG - IEXTRA

          CALL FM_ST2M('UNKNOWN',M_09)

          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 (M_15%MFM(1) == MEXPOV .OR. M_16%MFM(1) == MEXPOV) THEN

          IF (M_15%MFM(1) == MEXPOV .AND. M_15%MFM(2) >= 1) THEN

              IF (M_16%MFM(1) /= MEXPOV) THEN

                  CALL FM_ST2M('OVERFLOW',M_09)

                  KFLAG = -5

                  GO TO 170

              ENDIF

          ENDIF

          IF (M_16%MFM(1) == MEXPOV .AND. M_16%MFM(2) >= 1) THEN

              M_10 = HUGE(M_15)

              M_10%MFM(1) = MXSAVE + 1

              M_11 = M_10 / LOG(M_10)

              IF (M_15 <= M_11) THEN

                  CALL FM_ST2M('UNDERFLOW',M_09)

                  KFLAG = -6

                  GO TO 170

              ELSE

                  CALL FM_ST2M('UNKNOWN',M_09)

                  KFLAG = -4

                  GO TO 190

              ENDIF

          ENDIF

          IF (M_16%MFM(1) == MEXPOV .AND. M_16%MFM(2) <= -1  &

                               .AND. M_15%MFM(2) > 0) THEN

              IF (M_15%MFM(1) /= MEXPOV) THEN

                  M_08 = AINT(M_15)

                  IF (M_15 == M_08) THEN

                      M_05 = 2

                      M_05 = MOD(M_08,M_05)

                      IF (M_05%MFM(2) /= 0) THEN

                          CALL FM_ST2M('OVERFLOW',M_09)

                          KFLAG = -5

                          GO TO 170

                      ELSE

                          CALL FM_ST2M('-OVERFLOW',M_09)

                          KFLAG = -5

                          GO TO 170

                      ENDIF

                  ENDIF

              ENDIF

          ENDIF

          IF (M_15%MFM(1) == MEXPOV .AND. M_15%MFM(2) >= -1) THEN

              IF (M_16%MFM(1) /= MEXPOV .AND. M_16%MFM(2) > 0) THEN

                  IF (M_16 < 1) THEN

                      CALL FM_ST2M('OVERFLOW',M_09)

                      KFLAG = -5

                      GO TO 170

                  ELSE

                      CALL FM_ST2M('UNDERFLOW',M_09)

                      KFLAG = -6

                      GO TO 170

                  ENDIF

              ENDIF

          ENDIF

          CALL FM_ST2M('UNKNOWN',M_09)

          KFLAG = -4

          GO TO 190

      ENDIF



      IF (M_15%MFM(1) == MEXPUN .OR. M_16%MFM(1) == MEXPUN) THEN

          IF (M_15%MFM(1) == MEXPUN .AND. M_16%MFM(1) == MEXPUN) THEN

              CALL FM_ST2M('UNKNOWN',M_09)

              KFLAG = -4

              GO TO 190

          ENDIF

          IF (M_16%MFM(1) == MEXPUN .AND. M_16%MFM(2) >= 1) THEN

              IF (M_15%MFM(1) >= 1) THEN

                  CALL FMGAM(M_15%MFM,M_14%MFM)

                  M_09 = M_14

                  GO TO 170

              ELSE

                  CALL FM_ST2M('UNKNOWN',M_09)

                  KFLAG = -4

                  GO TO 190

              ENDIF

          ENDIF

      ENDIF



      IF (M_16%MFM(2) == 0) THEN

          IF (M_15%MFM(2) <= 0) THEN

              CALL FM_ST2M('UNKNOWN',M_09)

              KFLAG = -4

              GO TO 190

          ELSE

              CALL FMGAM(M_15%MFM,M_14%MFM)

              M_09 = M_14

              GO TO 170

          ENDIF

      ENDIF

      IF (M_16%MFM(2) < 0) THEN

          M_08 = AINT(M_15)

          IF (M_15 == M_08 .AND. M_15%MFM(2) > 0) THEN

              KXNEG = 1

              M_05 = 2

              M_05 = MOD(M_08,M_05)

              IF (M_05%MFM(2) /= 0) MODA2 = 1

          ELSE

              CALL FM_ST2M('UNKNOWN',M_09)

              KFLAG = -4

              GO TO 190

          ENDIF

      ENDIF

      IF (M_16%MFM(1) == MEXPUN) THEN

          CALL FMGAM(M_15%MFM,M_14%MFM)

          M_09 = M_14

          GO TO 170

      ENDIF

      IF (M_15%MFM(1) == MEXPUN) THEN

          M_15 = 0

          MA2 = 0

      ENDIF

      IF (MAX(M_15,M_16) >= 1.0D6 .AND. MIN(M_15,M_16) >= 100.0) THEN

          M_02 = M_15 - 1

          M_04 = MAX(M_02,M_16) + 1

          M_06 = EXP(-M_04 + M_02*LOG(M_04))

          IF ((M_06%MFM(1) == MEXPOV .AND. M_06%MFM(2) >= 1) .OR.  &

              M_06%MFM(1) > MXSAVE+1) THEN

              CALL FM_ST2M('OVERFLOW',M_09)

              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.



      M_04 = -10000

      M_05 = 10000

      M_07 = ABS(M_15)

      M_08 = ABS(M_16)

      M_06 = M_08 - M_07

      KABIGR = 1

      IF (M_06%MFM(2) >= 0) KABIGR = 0

      NMETHD = 0

      IF (M_06 <= M_04) THEN

          IF (M_15%MFM(2) > 0) THEN

              NMETHD = 1

          ELSE

              NMETHD = 3

          ENDIF

      ELSE IF (M_06 >= M_05.AND.M_15%MFM(2) > 0  &

               .AND. M_16%MFM(2) > 0) THEN

          NMETHD = 2

      ELSE IF (M_06 >= M_05) THEN

          NMETHD = 3

      ELSE IF (M_15%MFM(2) >= 0 .AND. M_16%MFM(2) > 0) THEN

          M_04 = SQRT(DPMAX)

          IF (M_16 >= M_04) THEN

              KFLAG = -5

              CALL FM_ST2M('OVERFLOW',M_09)

              GO TO 170

          ENDIF



          IF (M_15%MFM(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*M_15%MFM(1) > NDIG .OR. M_15%MFM(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 (M_15%MFM(2) < 0 .AND. M_16%MFM(2) > 0) THEN

          M_04 = SQRT(DPMAX)

          IF (M_16 >= M_04) THEN

              KFLAG = -6

              CALL FM_ST2M('UNDERFLOW',M_09)

              GO TO 170

          ENDIF



          C1 = MAX( 10.0D0 , DBLE(NDSAVE)*DLOGMB/7.0D0 )

          C2 = -2.0D0*A

          IF (X < C1) THEN

              IF (-2*M_15%MFM(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 (M_15%MFM(2) > 0 .AND. M_16%MFM(2) < 0) THEN

          M_04 = M_16

          M_04%MFM(2) = -M_04%MFM(2)

          M_05 = M_15 * 2

          IF (M_04 < M_15) THEN

              NMETHD = 1

          ELSE IF (M_04 < M_05) 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.



!             M_09 is the current sum.

!             M_05 is the current term.

!             M_04 is (A+N)/X.

!             M_13 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 (M_15%MFM(2) < 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

          M_09 = ANINT(M_15)

          IF (M_09 == M_15) 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

          M_13 = M_15 - M_09

          IEXTRA = MAX(-2*INT(M_13%MFM(1)),-INT(M_15%MFM(1))+1,0)

      ELSE

          IEXTRA = MAX(-INT(M_15%MFM(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(M_15%MFM,M_15%MFM,NDIG,NDIG+IEXTRA,1)

          CALL FMEQ2(M_16%MFM,M_16%MFM,NDIG,NDIG+IEXTRA,1)

      ENDIF

      NDIG = NDIG + IEXTRA

      IF (NDIG > NDG2MX) THEN

          KFLAG = -9

          CALL FMWRN2

          NDIG = NDIG - IEXTRA

          CALL FM_ST2M('UNKNOWN',M_09)

          GO TO 190

      ENDIF



      JEXTRA = 0



  120 IF (KABIGR == 1) THEN

          CALL FMGAM(M_15%MFM,M_14%MFM)

          IF (KFLAG /= 0) THEN

              M_09 = M_14

              GO TO 170

          ENDIF

          M_09 = M_14

      ELSE

          M_09 = 0

      ENDIF



      MAXM09 = M_09%MFM(1)



      M_13 = ABS(M_16)

      M_13 = LOG(M_13)

      M_13 = M_15 * M_13

      M_13 = M_13 - M_16

      M_14 = EXP(M_13)

      M_05 = M_14 / M_15

      IF (M_05%MFM(1) == MUNKNO) THEN

          M_08 = LOG(M_15)

          M_13 = M_13 - M_08

          M_05 = EXP(M_13)

      ENDIF

      IF (KXNEG == 1 .AND. MODA2 == 1 .AND. M_05%MFM(1) /= MUNKNO) THEN

          M_05%MFM(2) = -M_05%MFM(2)

      ENDIF



      M_05%MFM(2) = -M_05%MFM(2)

      M_09 = M_09 + M_05

      MAXM09 = MAX(MAXM09,M_09%MFM(1))



      M_02 = 1

      M_04 = M_15 + M_02

      M_05 = M_05 / M_04

      M_05 = M_05 * M_16

      M_04 = M_04 / M_16

      M_13 = M_02 / M_16

      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 (M_15%MFM(2) < 0) THEN

          KFLGOK = 0

          M_15%MFM(2) = ABS(M_15%MFM(2))

          M_16%MFM(2) = ABS(M_16%MFM(2))

          IF (M_15 > M_16) 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

          M_15%MFM(2) = MA2

          M_16%MFM(2) = MB2

      ENDIF



      NMNNDG = NDSAV1

      NMXDIF = 0



!             Method 1 summation loop.



      DO J = 1, NTERMS

         NDIG = NDSAV1

         M_09 = M_09 + M_05

         MAXM09 = MAX(MAXM09,M_09%MFM(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



         M_04 = M_04 + M_13



         NDIG2 = MAX(2,NDSAV1-INT(M_09%MFM(1)-M_05%MFM(1)))

         NDIG = MIN(NDSAV1,NDIG2+JEXTRA)

         NMNNDG = MIN(NMNNDG,NDIG)

         NMXDIF = MAX(NMXDIF,NDIG-NMNNDG)

         M_05 = M_05 / M_04

      ENDDO



      NDIG = NDSAV1

      IF (KABIGR == 0) THEN

          M_13 = M_09

          CALL FMGAM(M_15%MFM,M_14%MFM)

          IF (KFLAG /= 0) THEN

              M_09 = M_14

              GO TO 170

          ENDIF

          M_09 = M_14 + M_13

      ENDIF



!             If too much cancellation occurred, raise the precision

!             and do the calculation again.



      IEXTRA = NDIG - NDSAVE

      IF (INT(MAXM09-M_09%MFM(1)) >= IEXTRA-NGRD52/2) THEN

          IEXTRA = IEXTRA + NGRD52

          IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN

              CALL FMEQ2(M_15%MFM,M_15%MFM,NDIG,NDIG+IEXTRA,1)

              CALL FMEQ2(M_16%MFM,M_16%MFM,NDIG,NDIG+IEXTRA,1)

          ENDIF

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDIG - IEXTRA

              CALL FM_ST2M('UNKNOWN',M_09)

              GO TO 190

          ENDIF

          GO TO 120

      ENDIF



      GO TO 170



!             Method 2.  Use the Pochhammer(A-N,N)/X**N series.



!             M_09 is the current sum.

!             M_05 is the current term.

!             M_04 is (A-N)/X.

!             M_13 is -1/X



  130 M_13 = ABS(M_16)

      M_13 = LOG(M_13)

      M_09 = M_15 * M_13

      M_13 = M_09 - M_13

      M_13 = M_13 - M_16

      M_05 = EXP(M_13)

      IF (KXNEG == 1 .AND. MODA2 == 0) M_05%MFM(2) = -M_05%MFM(2)

      IF (ABS(M_05%MFM(1)) >= MXEXP2) THEN

          M_09 = M_05

          GO TO 170

      ENDIF



!             Here M_05 is X**(A-1)/EXP(X).



      M_09 = 0

      M_04 = M_15

      M_04 = M_04 / M_16

      M_02 = 1

      M_13 = M_02 / M_16

      M_13%MFM(2) = -M_13%MFM(2)

      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 (M_15%MFM(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

         M_09 = M_09 + M_05

         IF (KFLAG /= 0 .AND. J > 1) GO TO 140

         M_04 = M_04 + M_13

         IF (REAL(J) >= BIGJ) THEN

             NDIG2 = MAX(2,NDSAV1-INT(M_09%MFM(1)-M_05%MFM(1)))

             NDIG = MIN(NDSAV1,NDIG2)

         ENDIF

         M_05 = M_05 * M_04

      ENDDO



  140 NDIG = NDSAV1

      GO TO 170



!             Method 3.  Use the continued fraction expansion.



!             M_13 is the current approximation.

!             M_09 is the previous approximation.

!             M_05, M_06 are the latest numerators.

!             M_07, M_08 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 FM_ST2M('UNKNOWN',M_09)

                      GO TO 190

                  ENDIF

              ENDIF

          ENDIF

      ENDIF

      NDSAV1 = NDIG

      IF (NDIG+JEXTRA > NDG2MX) JEXTRA = NDG2MX - NDIG

      IF (NDIG+JEXTRA > NDSAV1) THEN

          CALL FMEQ2(M_15%MFM,M_15%MFM,NDSAV1,NDSAV1+JEXTRA,1)

          CALL FMEQ2(M_16%MFM,M_16%MFM,NDSAV1,NDSAV1+JEXTRA,1)

      ENDIF

      NDIG = NDIG + JEXTRA

      M_05 = 0

      M_06 = 1

      M_07 = 1

      CALL FMEQ2(M_16%MFM,M_08%MFM,NDSAV1,NDIG,0)

      M_13 = 0

      CALL FMEQ2(M_15%MFM,M_04%MFM,NDSAV1,NDIG,0)

      M_04%MFM(2) = -M_04%MFM(2)

      M_03 = 1



      JTERMS = NTERMS

      JCHECK = 10

      IF (INTA == 1) M_13 = M_06 / M_16

      IF (INTA > 0) JTERMS = INTA - 1



!             Method 3 continued fraction loop.



      METHOD3:    DO J = 1, JTERMS

         M_04 = M_04 + M_03

         M_05 = M_04 * M_05

         M_05 = M_06 + M_05

         M_07 = M_04 * M_07

         M_07 = M_08 + M_07

         M_06 = M_06 * J

         M_14 = M_16 * M_05

         M_06 = M_14 + M_06

         M_08 = M_08 * J

         M_14 = M_16 * M_07

         M_08 = M_14 + M_08



!             Normalize to make overflow or underflow less likely.



         KMID = INT((MAX(M_05%MFM(1),M_06%MFM(1),M_07%MFM(1),M_08%MFM(1)) +  &

                     MIN(M_05%MFM(1),M_06%MFM(1),M_07%MFM(1),M_08%MFM(1))) / 2)

         M_05%MFM(1) = M_05%MFM(1) - KMID

         M_06%MFM(1) = M_06%MFM(1) - KMID

         M_07%MFM(1) = M_07%MFM(1) - KMID

         M_08%MFM(1) = M_08%MFM(1) - KMID



!             Form the quotient and check for convergence.



         IF (MOD(J,JCHECK) == 0 .OR. J == INTA-1) THEN

             M_09 = M_13

             M_13 = M_06 / M_08

             DO K = NDIG-JEXTRA, 1, -1

                IF (M_09%MFM(K) /= M_13%MFM(K)) CYCLE METHOD3

             ENDDO

             EXIT

         ENDIF

      ENDDO METHOD3



      CALL FMEQ2(M_13%MFM,M_13%MFM,NDIG,NDSAV1,1)

      NDIG = NDSAV1

      M_08 = ABS(M_16)

      M_08 = LOG(M_08)

      M_08 = M_15 * M_08

      M_08 = M_08 - M_16

      M_08 = EXP(M_08)

      IF (KXNEG == 1 .AND. MODA2 == 1) M_08%MFM(2) = -M_08%MFM(2)

      IF (ABS(M_08%MFM(1)) >= MXEXP2) THEN

          M_09 = M_08

          IF (M_13%MFM(2) < 0) M_09%MFM(2) = -M_09%MFM(2)

          GO TO 170

      ENDIF



      M_09 = M_08 * M_13

      GO TO 170



!             Method 4.  Use the O(A**2) formula when A is small.



!             M_09 is the current term.

!             M_13 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

          M_15 = 0

          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(M_15%MFM,M_15%MFM,NDIG,NDIG+IEXTRA,1)

          CALL FMEQ2(M_16%MFM,M_16%MFM,NDIG,NDIG+IEXTRA,1)

      ENDIF

      NDIG = NDIG + IEXTRA

      IF (NDIG > NDG2MX) THEN

          KFLAG = -9

          CALL FMWRN2

          NDIG = NDIG - IEXTRA

          CALL FM_ST2M('UNKNOWN',M_09)

          GO TO 190

      ENDIF



      CALL FMEULR(M_13%MFM)

      M_14 = M_13

      M_13%MFM(2) = -M_13%MFM(2)

      M_09 = ABS(M_16)

      M_08 = LOG(M_09)

      M_13 = M_13 - M_08

      IF (M_15%MFM(2) /= 0 .AND. M_15%MFM(1) >= -NDIG-1) THEN

          M_09 = M_08**2 * M_15 / 2

          M_13 = M_13 - M_09



          M_07 = M_14 ** 2

          CALL FM_PI(M_06)

          M_06 = M_06**2 / 6

          M_07 = (M_06 + M_07) * M_15 / 2

          M_13 = M_13 + M_07

      ENDIF



      NDSAV1 = NDIG

      M_07 = 1

      M_06 = M_15 + M_07

      IF (M_07 == M_06) THEN

          M_09 = -1

          DO J = 1, NTERMS

             NDIG2 = MAX(2,NDSAV1-INT(M_13%MFM(1)-M_09%MFM(1)))

             NDIG = MIN(NDSAV1,NDIG2)

             M_09 = M_09 * M_16

             M_09%MFM(2) = -M_09%MFM(2)

             M_09 = M_09 / J

             M_08 = M_09 / J

             NDIG = NDSAV1

             M_13 = M_13 + M_08

             IF (KFLAG /= 0) EXIT

          ENDDO

      ELSE

          M_09 = M_16 ** M_15

          M_09%MFM(2) = -M_09%MFM(2)

          M_14 = M_15

          DO J = 1, NTERMS

             NDIG2 = MAX(2,NDSAV1-INT(M_13%MFM(1)-M_09%MFM(1)))

             NDIG = MIN(NDSAV1,NDIG2)

             M_09 = M_09 * M_16

             M_09%MFM(2) = -M_09%MFM(2)

             M_09 = M_09 / J

             NDIG = NDSAV1

             M_14 = M_14 + M_07

             NDIG = MIN(NDSAV1,NDIG2)

             M_08 = M_09 / M_14

             NDIG = NDSAV1

             M_13 = M_13 + M_08

             IF (KFLAG /= 0) EXIT

          ENDDO

      ENDIF

      M_09 = M_13



!             Use the recurrence relation if A was a negative integer.



      IF (KFLAGI == 0 .AND. INTA < 0) THEN

          N = -INTA

          M_13 = 1

          M_13 = M_13 / M_16

          M_08 = M_13

          M_07 = M_13

          DO J = 1, N-1

             M_08 = M_08 * J

             M_08 = M_08 * M_07

             M_08%MFM(2) = -M_08%MFM(2)

             M_13 = M_13 + M_08

          ENDDO

          M_07 = EXP(M_16)

          M_13 = M_13 / M_07

          M_09 = M_09 - M_13

          CALL FMFCTI(N,M_07%MFM)

          M_09 = M_09 / M_07

          IF (MOD(N,2) == 1) M_09%MFM(2) = -M_09%MFM(2)

      ENDIF



!             Check for too much cancellation.



  170 IF (NCALL <= 1) THEN

          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17

      ELSE

          NGOAL = INT(-MXEXP2)

      ENDIF

      IF (M_09%MFM(0) <= NGOAL) THEN

          IF (NUMTRY > 0) THEN

              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)

              DO J = 1, NDGOAL+1

                 IF (MRETRY(J) /= M_09%MFM(J)) GO TO 180

              ENDDO

              GO TO 190

          ENDIF

  180     IEXTRA = INT(REAL(NGOAL-M_09%MFM(0))/ALOGM2 + 23.03/ALOGMB) + 1

          NDOLD = NDIG

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDIG - IEXTRA

              CALL FM_ST2M('UNKNOWN',M_09)

              GO TO 190

          ENDIF

          CALL FMEQ2(M_15%MFM,M_15%MFM,NDSAVE,NDIG,1)

          IF (KMETH4 == 1) THEN

              M_15 = INTA

          ENDIF

          CALL FMEQ2(M_16%MFM,M_16%MFM,NDSAVE,NDIG,1)

          NUMTRY = NUMTRY + 1

          CALL FMEQ2(M_09%MFM,MRETRY,NDOLD,NDIG,0)

          GO TO 110

      ENDIF



  190 MACMAX = NINT(NDSAVE*ALOGM2)

      M_09%MFM(0) = MIN(M_09%MFM(0),MACCA,MACCB,MACMAX)

      CALL FMEXT2(M_09%MFM,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)

      RETURN

      END SUBROUTINE FMIGM2

      SUBROUTINE FMLNGM(MA,MB)



!  MB = LN(GAMMA(MA))



      USE FMVALS

      USE FMZM

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMLNGM:  M_01 - M_10



      DOUBLE PRECISION MA2,MACCA,MACMAX,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



      CHARACTER(155) :: STRING



      CALL FMENT2('FMLNGM',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE,  &

                  KOVUN)

      IF (KRESLT /= 0) RETURN

      MA2 = MA(2)

      KACCSW = 1

      MACCA = MA(0)

      CALL FMEQ2(MA,M_09%MFM,NDSAVE,NDIG,0)

      M_09%MFM(0) = NINT(NDIG*ALOGM2)

      M_10 = M_09

      NUMTRY = 0



!             Near zero Gamma(x) is about 1/x.



  110 IF (M_10%MFM(1) < (-NDIG-3)) THEN

          M_06 = -LOG(M_10)

          GO TO 140

      ENDIF



!             Check for special cases.



      IF (MA2 < 0) THEN

          KFL = 0

          IF (M_09%MFM(1) <= NDSAVE) THEN

              M_05 = AINT(M_10)

              IF (M_10 == M_05) KFL = -4

              M_06 = 2

              M_05 = ABS(M_05)

              M_06 = MOD(M_05,M_06)

              IF (M_06 == 0) KFL = -4

          ELSE

              KFL = -4

          ENDIF

          IF (KFL /= 0) THEN

              CALL FM_ST2M('UNKNOWN',M_06)

              KFLAG = -4

              GO TO 160

          ELSE

              M_10 = 1 - M_10

          ENDIF

      ENDIF



!             To speed the asymptotic series calculation, increase

!             the argument by LSHIFT.



      IEXTRA = 0

      KWRNSV = KWARN

      KWARN = 0

      INTA = M_10

      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

                  M_06 = 0

                  GO TO 140

              ENDIF

              INTA = INTA - 1

              CALL FMFCTI(INTA,M_10%MFM)

              M_06 = LOG(M_10)

              GO TO 140

          ENDIF

      ENDIF



      IF (LSHIFT /= 0) THEN

          M_08 = M_10 + LSHIFT

      ELSE

          M_08 = M_10

      ENDIF



!             Sum the asymptotic series.



!       M_10 is Z

!       M_08 is Z + LSHIFT

!       M_05 is X**J2 = (1/(Z+LSHIFT)**2)**J2

!       M_06 is the current power of X

!       M_07 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+2),J2))

      NDSAV1 = NDIG

      M_06 = 1

      J = -2*J2

      M_05 = M_08 ** J

      IF (ABS(M_05%MFM(1)) >= MEXPAB) THEN

          J2 = 1

          M_05 = M_08 ** (-2)

      ENDIF

      DO J = 1, J2

         NTERM = 2*J

         CALL FMBERN(NTERM,M_06%MFM,M_07%MFM)

         IF (KFLAG == -11) THEN

             CALL FM_ST2M('UNKNOWN',M_06)

             KFLAG = -4

             GO TO 160

         ENDIF

         NDENOM = NTERM*(NTERM-1)

         KPT = (J-1)*(NDSAV1+2)

         CALL FMDIVI(M_07%MFM,NDENOM,MJSUMS(KPT))

      ENDDO



      NDIG2 = NDIG

  120 M_06 = M_06 * M_05

      NMXDIF = 2

      DO J = 1, J2

         NTERM = NTERM + 2

         CALL FMBERN(NTERM,M_06%MFM,M_07%MFM)

         IF (KFLAG == -11) THEN

             CALL FM_ST2M('UNKNOWN',M_06)

             KFLAG = -4

             GO TO 160

         ENDIF

         NDENOM = NTERM*(NTERM-1)

         IF (NDENOM <= MXBASE) THEN

             M_07 = M_07 / NDENOM

         ELSE

             M_07 = M_07 / NTERM

             NDENOM = NTERM - 1

             M_07 = M_07 / NDENOM

         ENDIF

         NDIG = NDSAV1

         KPT = (J-1)*(NDSAV1+2)

         CALL FMADD(MJSUMS(KPT),M_07%MFM,MJSUMS(KPT))

         NMXDIF = MAX(NMXDIF,NDSAV1-INT(MJSUMS(KPT+1)-M_07%MFM(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+2)

          M_07 = M_08 ** 2

          M_07 = 1 / M_07

          CALL FMEQ(MJSUMS(KPT),M_05%MFM)

          DO J = J2-1, 1, -1

             M_05 = M_05 * M_07

             KPT = (J-1)*(NDSAV1+2)

             CALL FMADD(M_05%MFM,MJSUMS(KPT),M_05%MFM)

          ENDDO

          CALL FMEQ(M_05%MFM,MJSUMS)

      ENDIF



!             Add the log terms to the asymptotic series.



!       M_06 is the current sum as the log terms are added

!       M_07 is now LN(Z+LSHIFT)



      CALL FMDIV(MJSUMS,M_08%MFM,M_06%MFM)

      M_07 = LOG(M_08)

      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 FM_ST2M(STRING,M_LN_2PI)

              M_LN_2PI%MFM(0) = NINT(NDIG*ALOGM2)

              MBS2PI = MBASE

              NDG2PI = NDIG

              IF (ABS(M_LN_2PI%MFM(1)) > 10) NDG2PI = 0

              NDIG = NDSV

          ELSE

              NDSV = NDIG

              NDIG = MIN(NDIG+2,NDG2MX)

              CALL FM_PI(M_05)

              M_LN_2PI = LOG(2*M_05)

              MBS2PI = MBASE

              NDG2PI = NDIG

              IF (ABS(M_LN_2PI%MFM(1)) > 10) NDG2PI = 0

              NDIG = NDSV

          ENDIF

      ENDIF

      M_05 = (M_LN_2PI - M_07) / 2

      M_06 = M_06 + M_05

      M_06 = M_06 - M_08

      M_05 = M_07 * M_08

      M_06 = M_06 + M_05



!             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.



!             M_10 is Z

!             M_01 is Z**2

!             M_02 is Z**3

!             M_03 is (Z+K)*...*(Z+K+3)

!             M_07 is the current product



      IF (LSHIFT > 0) THEN

          M_01 = M_10 ** 2

          M_02 = M_10 * M_01

          M_03 = M_01 ** 2

          M_08 = M_02 * 6

          M_03 = M_03 + M_08

          M_08 = M_01 * 11

          M_03 = M_03 + M_08

          M_08 = M_10 * 6

          M_03 = M_03 + M_08

          M_07 = M_03

          M_02 = M_02 * 16

          DO K = 0, LSHIFT-8, 4

             M_03 = M_03 + M_02

             K2 = 24*(2*K + 7)

             M_08 = M_01 * K2

             M_03 = M_03 + M_08

             IF (K <= SQRT(REAL(INTMAX)/49.0)) THEN

                 K1 = 8*(6*K*K + 42*K + 79)

                 M_08 = M_10 * K1

                 M_03 = M_03 + M_08

             ELSE

                 K1 = 48*K

                 M_08 = M_10 * K1

                 M_08 = M_08 * K

                 M_03 = M_03 + M_08

                 K1 = 336*K + 632

                 M_08 = M_10 * K1

                 M_03 = M_03 + M_08

             ENDIF

             IF (K <= (REAL(INTMAX)/17.0)**0.3333) THEN

                 K0 = 8*(2*K + 7)*(K*K + 7*K + 15)

                 M_08 = K0

                 M_03 = M_03 + M_08

             ELSE IF (K <= SQRT(REAL(INTMAX)*0.9)) THEN

                 K0 = 8*(2*K + 7)

                 M_08 = K0

                 K0 = K*K + 7*K + 15

                 M_08 = M_08 * K0

                 M_03 = M_03 + M_08

             ELSE

                 K0 = 8*(2*K + 7)

                 M_08 = K0

                 M_05 = M_08 * K

                 M_05 = M_05 * K

                 M_03 = M_03 + M_05

                 K0 = 7*K + 15

                 M_08 = M_08 * K0

                 M_03 = M_03 + M_08

             ENDIF

             M_07 = M_07 * M_03

          ENDDO

          M_07 = LOG(M_07)

          M_06 = M_06 - M_07

      ENDIF



!             Use the reflection formula if MA was negative.



      IF (MA2 < 0) THEN



!             Reduce the argument before multiplying by Pi.



          M_01 = ANINT(M_10)

          M_02 = M_01 / 2

          M_02 = AINT(M_02)

          M_03 = M_02 * 2

          KSIGN = -1

          IF (M_01 == M_03) KSIGN = 1

          M_05 = M_10 - M_01

          M_05%MFM(0) = M_10%MFM(0)

          CALL FM_PI(M_07)

          M_07 = M_07 * M_05

          KRSAVE = KRAD

          KRAD = 1

          M_07 = SIN(M_07)

          M_07%MFM(2) = KSIGN*M_07%MFM(2)

          KRAD = KRSAVE

          CALL FMDIV(MPISAV,M_07%MFM,M_07%MFM)

          M_07 = LOG(M_07)

          M_06 = M_07 - M_06

      ENDIF



!             Check for too much cancellation.



  140 IF (NCALL <= 1) THEN

          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17

      ELSE

          NGOAL = INT(-MXEXP2)

      ENDIF

      IF (M_06%MFM(0) <= NGOAL) THEN

          IF (NUMTRY > 0) THEN

              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)

              DO J = 1, NDGOAL+1

                 IF (MRETRY(J) /= M_06%MFM(J)) GO TO 150

              ENDDO

              GO TO 160

          ENDIF

  150     IEXTRA = INT(REAL(NGOAL-M_06%MFM(0))/ALOGM2 + 23.03/ALOGMB) + 1

          NDOLD = NDIG

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDIG - IEXTRA

              CALL FM_ST2M('UNKNOWN',M_06)

              GO TO 160

          ENDIF

          CALL FMEQ2(M_09%MFM,M_09%MFM,NDSAVE,NDIG,1)

          M_10 = M_09

          NUMTRY = NUMTRY + 1

          CALL FMEQ2(M_06%MFM,MRETRY,NDOLD,NDIG,0)

          GO TO 110

      ENDIF



  160 MACMAX = NINT(NDSAVE*ALOGM2)

      M_06%MFM(0) = MIN(M_06%MFM(0),MACCA,MACMAX)

      CALL FMEXT2(M_06%MFM,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)

      RETURN

      END SUBROUTINE FMLNGM

      SUBROUTINE FMPGAM(N,MA,MB)



!  MB = POLYGAMMA(N,MA)      (Nth Derivative of PSI)



      USE FMVALS

      USE FMZM

      IMPLICIT NONE



      INTEGER N

      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMPGAM:  M_01 - M_12



      DOUBLE PRECISION 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 /)



      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,M_12%MFM,NDSAVE,NDIG,0)

      M_12%MFM(0) = NINT(NDIG*ALOGM2)

      M_11 = M_12

      NUMTRY = 0



  110 IF (N == 0) THEN

          CALL FMPSI(M_12%MFM,M_12%MFM)

          M_08 = M_12

          GO TO 150

      ENDIF

      IF (N < 0 .OR. MA(2) == 0) THEN

          CALL FM_ST2M('UNKNOWN',M_08)

          KFLAG = -4

          GO TO 170

      ENDIF



!             Near zero PGAM(x) is about n!/(-x)**(n+1).



      IF (M_11%MFM(1) < (-NDIG-1)) THEN

          CALL FMFCTI(N,M_10%MFM)

          M_11%MFM(2) = -M_11%MFM(2)

          M_09 = M_11 ** (N+1)

          M_08 = M_10 / M_09

          GO TO 150

      ENDIF



!             Check for special cases.



      KRFLCT = 0

      M_02 = -0.5

      IF (M_11 <= M_02) THEN

          KRFLCT = 1

          KFL = 0

          IF (MA(1) <= NDSAVE) THEN

              M_07 = AINT(M_11)

              IF (M_11 == M_07) KFL = -4

          ELSE

              KFL = -4

          ENDIF

          IF (KFL /= 0) THEN

              CALL FM_ST2M('UNKNOWN',M_08)

              KFLAG = -4

              GO TO 170

          ELSE

              M_11 = 1 - M_11

          ENDIF

      ENDIF

      IF (MA(1) > NDIG+3) THEN

          M_08 = M_11 ** (-N)

          IF (M_08%MFM(1) /= MEXPUN) THEN

              CALL FMFCTI(N-1,M_07%MFM)

              M_08 = M_08 * M_07

          ENDIF

          IF (MOD(N-1,2) == 1) M_08%MFM(2) = -M_08%MFM(2)

          GO TO 150

      ENDIF



!             To speed the asymptotic series calculation, increase

!             the argument by LSHIFT.



      IEXTRA = 0

      KWRNSV = KWARN

      KWARN = 0

      INTA = M_11

      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

          M_10 = M_11 + LSHIFT

      ELSE

          M_10 = M_11

      ENDIF



!             Sum the asymptotic series.



      J2 = INT(0.3*ALOGMB + 0.2*SQRT(REAL(NDIG)))

      J2 = MAX(1,MIN(LJSUMS/(LUNPCK+2),J2))



!             M_11 is Z

!             M_10 is Z + LSHIFT

!             M_07 is X**J2 = (1/(Z+LSHIFT)**2)**J2

!             M_08 is the current power of X times the quotient of

!                 factorials in each term

!             M_09 is the current term in the sum

!             M_06 is (N+1)!

!             MJSUMS holds the partial sums



      NDSAV1 = NDIG

      CALL FMFCTI(N+1,M_06%MFM)

      M_08 = M_06 / 2

      J = -2*J2

      M_07 = M_10 ** J

      IF (ABS(M_07%MFM(1)) >= MEXPAB) THEN

          J2 = 1

          M_07 = M_10 ** (-2)

      ENDIF

      DO J = 1, J2

         NTERM = 2*J

         KPT = (J-1)*(NDSAV1+2)

         CALL FMBERN(NTERM,M_08%MFM,MJSUMS(KPT))

         IF (KFLAG == -11) THEN

             CALL FM_ST2M('UNKNOWN',M_08)

             KFLAG = -4

             GO TO 170

         ENDIF

         NTOP = (N+NTERM)*(N+NTERM+1)

         M_08 = M_08 * NTOP

         NBOT = (NTERM+1)*(NTERM+2)

         M_08 = M_08 / NBOT

      ENDDO



      NDIG2 = NDIG

  120 M_08 = M_08 * M_07

      NMXDIF = 2

      DO J = 1, J2

         NTERM = NTERM + 2

         CALL FMBERN(NTERM,M_08%MFM,M_09%MFM)

         IF (KFLAG == -11) THEN

             CALL FM_ST2M('UNKNOWN',M_08)

             KFLAG = -4

             GO TO 170

         ENDIF

         NDIG = NDSAV1

         KPT = (J-1)*(NDSAV1+2)

         CALL FMADD(MJSUMS(KPT),M_09%MFM,MJSUMS(KPT))

         IF (KFLAG /= 0) THEN

             GO TO 130

         ELSE

             NMXDIF = MAX(NMXDIF,NDSAV1-INT(MJSUMS(KPT+1)-M_09%MFM(1)))

             NDIG = NDIG2

             NTOP = (N+NTERM)*(N+NTERM+1)

             M_08 = M_08 * NTOP

             NBOT = (NTERM+1)*(NTERM+2)

             M_08 = M_08 / 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+2)

          M_07 = 1

          M_09 = M_10 ** 2

          M_09 = M_07 / M_09

          CALL FMEQ(MJSUMS(KPT),M_07%MFM)

          DO J = J2-1, 1, -1

             M_07 = M_07 * M_09

             KPT = (J-1)*(NDSAV1+2)

             CALL FMADD(M_07%MFM,MJSUMS(KPT),M_07%MFM)

          ENDDO

          CALL FMEQ(M_07%MFM,MJSUMS)

      ENDIF

      M_03 = M_10 ** (N+2)

      CALL FMDIV(MJSUMS,M_03%MFM,MJSUMS)



!             Add the initial terms to the asymptotic series.



      M_07 = M_06 / (N+1)

      M_06 = M_07 / N

      M_04 = M_10 * 2

      M_08 = N

      M_04 = M_04 + M_08

      M_04 = M_04 * M_06

      M_03 = M_03 * 2

      M_03 = M_03 / M_10

      M_08 = M_04 / M_03

      CALL FMADD(MJSUMS,M_08%MFM,M_08%MFM)

      IF (MOD(N-1,2) == 1) M_08%MFM(2) = -M_08%MFM(2)



!             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.



!             M_11 is Z

!             M_07 is N!

!             M_08 is the sum of the asymptotic series

!             M_09 is the sum 1/(MA)**(N+1) + ... +

!                            1/(MA+LSHIFT-1)**(N+1)



      IF (LSHIFT > 0) THEN

          M_03 = 1

          M_04 = M_11

          N1 = -(N + 1)

          M_09 = M_04 ** N1

          DO K = 1, LSHIFT-1

             M_04 = M_04 + M_03

             M_10 = M_04 ** N1

             M_09 = M_09 + M_10

          ENDDO

          M_09 = M_07 * M_09

          IF (MOD(N+1,2) == 1) M_09%MFM(2) = -M_09%MFM(2)

          M_08 = M_08 + M_09

      ENDIF



!             Use the reflection formula if MA was less than -1/2.



      IF (KRFLCT == 1) THEN



!             M_09 is COT(Pi*Z)

!             M_07 is M_09**2



!             Reduce the argument before multiplying by Pi.



          M_02 = M_11 * 2

          M_07 = AINT(M_02)

          IF (M_02 == M_07) THEN

              M_09 = 0

              M_07 = M_09

          ELSE

              M_02 = ANINT(M_11)

              M_07 = M_11 - M_02

              NDSV2 = NDIG

  140         CALL FM_PI(M_09)

              M_09 = M_09 * M_07

              KRSAVE = KRAD

              KRAD = 1

              M_09 = TAN(M_09)

              KRAD = KRSAVE

              IF ((M_09%MFM(1) < 0 .OR. M_09%MFM(1) > 1) .AND.  &

                  NDSV2 == NDIG) THEN

                  IEXTRA = INT(MAX(-M_09%MFM(1),M_09%MFM(1)))

                  IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN

                      CALL FMEQ2(M_07%MFM,M_07%MFM,NDIG,NDIG+IEXTRA,1)

                  ENDIF

                  NDIG = NDIG + IEXTRA

                  IF (NDIG > NDG2MX) THEN

                      KFLAG = -9

                      CALL FMWRN2

                      NDIG = NDIG - IEXTRA

                      CALL FM_ST2M('UNKNOWN',M_08)

                      GO TO 170

                  ENDIF

                  GO TO 140

              ENDIF



              NDIG = NDSV2

              M_02 = 1

              M_09 = M_02 / M_09

              M_07 = M_09 ** 2

          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

                  M_03 = 1

              ELSE

                  M_03 = M_07 * KCOEFF(JSTART)

              ENDIF

              DO J = 2, NC

                 M_04 = KCOEFF(JSTART+J-1)

                 M_03 = M_03 + M_04

                 IF (J < NC) M_03 = M_03 * M_07

              ENDDO

              IF (MOD(N,2) == 0) M_03 = M_03 * M_09

              IF (N > 1) M_03 = M_03 * KGCD(N)

          ELSE

              IF (NC*(NDIG+1) > 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+1),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+2)

                 CALL FMI2M(KCOEFF(J+49),MJSUMS(JPT))

                 CALL FMMPYI(MJSUMS(JPT),KGCD(14),MJSUMS(JPT))

              ENDDO

              DO JN = 15, N

                 JNC = (JN+1)/2

                 DO K = JNC, 2, -1

                    KPT1 = (K-2)*(NDIG+2)

                    KPT2 = (K-1)*(NDIG+2)

                    IF (K == JNC .AND. MOD(JN,2) == 1) THEN

                        CALL FMEQ(MJSUMS(KPT1),MJSUMS(KPT2))

                    ELSE

                        CALL FMADD(MJSUMS(KPT1),MJSUMS(KPT2),  &

                                   MJSUMS(KPT2))

                        CALL FMMPYI(MJSUMS(KPT2),JN-2*(K-1),  &

                                    MJSUMS(KPT2))

                    ENDIF

                 ENDDO

                 CALL FMMPYI(MJSUMS,JN,MJSUMS)

              ENDDO



!             MJSUMS now has the coefficients needed for the polynomial

!             in Cot**2 that defines the Nth derivative of Cot.



              CALL FMEQ(MJSUMS,M_03%MFM)

              DO J = 2, NC

                 M_03 = M_03 * M_07

                 KPT = (J-1)*(NDIG+2)

                 CALL FMADD(M_03%MFM,MJSUMS(KPT),M_03%MFM)

              ENDDO

              IF (MOD(N,2) == 0) M_03 = M_03 * M_09

          ENDIF



!             To complete the calculation of the Nth derivative of

!             Cot, multiply the polynomial in Cot**2 by Csc**2.



          M_04 = M_07 + M_02

          M_03 = M_03 * M_04



          CALL FMIPWR(MPISAV,N+1,M_04%MFM)

          M_03 = M_03 * M_04

          IF (MOD(N,2) == 1) M_08%MFM(2) = -M_08%MFM(2)

          M_08 = M_08 + M_03

      ENDIF



!             Check for too much cancellation.



  150 IF (NCALL <= 1) THEN

          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17

      ELSE

          NGOAL = INT(-MXEXP2)

      ENDIF

      IF (M_08%MFM(0) <= NGOAL) THEN

          IF (NUMTRY > 0) THEN

              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)

              DO J = 1, NDGOAL+1

                 IF (MRETRY(J) /= M_08%MFM(J)) GO TO 160

              ENDDO

              GO TO 170

          ENDIF

  160     IEXTRA = INT(REAL(NGOAL-M_08%MFM(0))/ALOGM2 + 23.03/ALOGMB) + 1

          NDOLD = NDIG

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDIG - IEXTRA

              CALL FM_ST2M('UNKNOWN',M_08)

              GO TO 170

          ENDIF

          CALL FMEQ2(M_12%MFM,M_12%MFM,NDSAVE,NDIG,1)

          M_11 = M_12

          NUMTRY = NUMTRY + 1

          CALL FMEQ2(M_08%MFM,MRETRY,NDOLD,NDIG,0)

          GO TO 110

      ENDIF



  170 MACMAX = NINT(NDSAVE*ALOGM2)

      M_08%MFM(0) = MIN(M_08%MFM(0),MACCA,MACMAX)

      CALL FMEXT2(M_08%MFM,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

      USE FMZM

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)

      INTEGER N



!             Scratch array usage during FMPOCH:  M_01 - M_14



      DOUBLE PRECISION MA2,MACCA,MACMAX,MBSIGN,MXSAVE

      INTEGER IEXTRA,J,K,K0,K1,K2,KASAVE,KLAST,KM12,KMB,KOVUN,KRESLT,  &

              LT,NDGOAL,NDOLD,NDSAVE,NGOAL,NT,NUMTRY

      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)

      NT = N

      KACCSW = 1

      MACCA = MA(0)

      CALL FMEQ2(MA,M_14%MFM,NDSAVE,NDIG,0)

      M_14%MFM(0) = NINT(NDIG*ALOGM2)

      M_11 = M_14

      NUMTRY = 0



!             Check for special cases.



  110 IEXTRA = 0

      IF (NT < 0) THEN

          M_14 = M_14 + NT

          M_11 = M_14

          NT = -NT

          MA2 = M_14%MFM(2)

      ENDIF

      IF (MA2 == 0) THEN

          IF (NT > 0) THEN

              M_07 = 0

              GO TO 130

          ELSE

              CALL FM_ST2M('UNKNOWN',M_07)

              KFLAG = -4

              GO TO 150

          ENDIF

      ENDIF

      IF (NT == 0) THEN

          M_07 = 1

          GO TO 130

      ELSE IF (NT == 1) THEN

          CALL FMEQ2(M_14%MFM,M_07%MFM,NDSAVE,NDIG,0)

          GO TO 130

      ENDIF

      IF (M_14%MFM(1) == MEXPOV) THEN

          CALL FM_ST2M('OVERFLOW',M_07)

          IF (MA2 < 0) M_07%MFM(2) = (-1)**NT

          GO TO 130

      ELSE IF (M_14%MFM(1) == MEXPUN) THEN

          IF (NT == 2) THEN

              CALL FM_ST2M('UNDERFLOW',M_07)

              IF (MA2 < 0) M_07%MFM(2) = -1

          ELSE

              CALL FM_ST2M('UNKNOWN',M_07)

              KFLAG = -4

          ENDIF

          GO TO 150

      ELSE IF (M_14+1 == 1) 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,M_07%MFM)

              M_07 = M_14 * M_07

              GO TO 130

          ENDIF

      ENDIF



!             Look for cases where overflow is easy to detect.



      M_05 = NT

      M_03 = ABS(M_11)

      IF (M_11%MFM(1) > 0 .AND. M_05 < M_03) THEN

          M_04 = M_11 + M_05

          M_04%MFM(2) = ABS(M_04%MFM(2))

          M_06 = MIN(M_03,M_04)

          IF (INT(M_06%MFM(1))-1 > INTMAX/NT) THEN

              CALL FM_ST2M('OVERFLOW',M_07)

              IF (M_11%MFM(2) > 0) THEN

                  M_07%MFM(2) = 1

              ELSE

                  M_07%MFM(2) = (-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 (M_14%MFM(1) > LT) THEN

          M_07 = M_11 ** NT

          GO TO 130

      ENDIF



      MBSIGN = 1

      IF (MA2 < 0) THEN

          M_04 = AINT(M_11)

          M_05 = NT

          M_06 = M_11 + M_05

          IF (M_11 == M_04) THEN



!                  If MA is a negative integer and MA+NT is positive,

!                  then the result is zero.



              IF (M_06%MFM(2) > 0) THEN

                  M_07 = 0

                  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).



          M_07 = 1

          IF (M_06 < M_07) THEN



!                 Extra guard digits may be required to insure the

!                 reflection formula is accurate.



              IEXTRA = MAX(INT(M_11%MFM(1)),IEXTRA)

              IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN

                  CALL FMEQ2(M_11%MFM,M_11%MFM,NDIG,NDIG+IEXTRA,1)

              ENDIF

              NDIG = NDIG + IEXTRA

              IF (NDIG > NDG2MX) THEN

                  KFLAG = -9

                  CALL FMWRN2

                  NDIG = NDIG - IEXTRA

                  CALL FM_ST2M('UNKNOWN',M_07)

                  GO TO 150

              ENDIF



              M_07 = NT-1

              M_11%MFM(2) = -M_11%MFM(2)

              M_11 = M_11 - M_07

              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

          M_12 = M_11 + NT



!             Compute IEXTRA, the number of extra digits required

!             to compensate for cancellation error.



          IF (MAX(M_11%MFM(1),M_12%MFM(1)) > IEXTRA) THEN

              IEXTRA = INT(MAX(M_11%MFM(1),M_12%MFM(1)))

          ENDIF

          IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN

              CALL FMEQ2(M_11%MFM,M_11%MFM,NDIG,NDIG+IEXTRA,1)

          ENDIF

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDIG - IEXTRA

              CALL FM_ST2M('UNKNOWN',M_07)

              GO TO 150

          ENDIF



          M_13 = -1

          IF (IEXTRA > 0) THEN

              M_12 = M_11 + NT

          ENDIF

          M_05 = 2

          KMB = 0

          IF (M_11%MFM(2) < 0) THEN

              M_04 = MOD(M_11,M_05)

              IF (M_04 > M_13) KMB = 1

          ENDIF

          KM12 = 0

          IF (M_12%MFM(2) < 0) THEN

              M_04 = MOD(M_12,M_05)

              IF (M_04 > M_13) KM12 = 1

          ENDIF

          M_13 = 1

          IF (M_11%MFM(2) < 0 .AND. KMB == 1) THEN

              M_13 = M_11

              M_11 = M_11 + 1

              CALL FMLNGM(M_11%MFM,M_11%MFM)

          ELSE

              CALL FMLNGM(M_11%MFM,M_11%MFM)

          ENDIF

          IF (M_12%MFM(2) < 0 .AND. KM12 == 1) THEN

              M_03 = -1

              M_12 = M_12 + M_03

              M_13 = M_13 * M_12

              CALL FMLNGM(M_12%MFM,M_12%MFM)

          ELSE

              CALL FMLNGM(M_12%MFM,M_12%MFM)

          ENDIF



          M_07 = M_12 - M_11

          M_07 = EXP(M_07)

          M_07 = M_07 * M_13

          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.



!             M_11 is Z

!             M_02 is Z**2

!             M_03 is Z**3

!             M_04 is (Z+K)*...*(Z+K+3)

!             M_07 is the current product



!             If M_11 is negative and M_11+NT is positive, extra

!             digits are required when M_11 is close to an integer.



      IF (M_11%MFM(2) < 0) THEN

          M_04 = NT

          M_05 = M_11 + M_04

          IF (M_05%MFM(2) > 0) THEN

              M_06 = ANINT(M_11)

              IF (M_06%MFM(2) /= 0) THEN

                  M_05 = M_11 - M_06

                  IEXTRA = MAX(IEXTRA,NDIG-NDSAVE)

                  IF (MAX(M_11%MFM(1),M_05%MFM(1)) > IEXTRA) THEN

                      IEXTRA = INT(MAX(M_11%MFM(1),M_05%MFM(1)))

                  ENDIF

                  IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN

                      CALL FMEQ2(M_11%MFM,M_11%MFM,NDIG,NDIG+IEXTRA,1)

                  ENDIF

                  NDIG = NDIG + IEXTRA

                  IF (NDIG > NDG2MX) THEN

                      KFLAG = -9

                      CALL FMWRN2

                      NDIG = NDIG - IEXTRA

                      CALL FM_ST2M('UNKNOWN',M_07)

                      GO TO 150

                  ENDIF

              ENDIF

          ENDIF

      ENDIF



      M_07 = 1

      IF (NT >= 4) THEN

          M_02 = M_11 ** 2

          M_03 = M_11 * M_02

          M_04 = M_02 ** 2

          M_08 = M_03 * 6

          M_04 = M_04 + M_08

          M_08 = M_02 * 11

          M_04 = M_04 + M_08

          M_08 = M_11 * 6

          M_04 = M_04 + M_08

          M_07 = M_04

          M_03 = M_03 * 16

          DO K = 0, NT-8, 4

             M_04 = M_04 + M_03

             K2 = 24*(2*K + 7)

             M_08 = M_02 * K2

             M_04 = M_04 + M_08

             IF (K <= SQRT(REAL(INTMAX)/49.0)) THEN

                 K1 = 8*(6*K*K + 42*K + 79)

                 M_08 = M_11 * K1

                 M_04 = M_04 + M_08

             ELSE

                 K1 = 48*K

                 M_08 = M_11 * K1

                 M_08 = M_08 * K

                 M_04 = M_04 + M_08

                 K1 = 336*K + 632

                 M_08 = M_11 * K1

                 M_04 = M_04 + M_08

             ENDIF

             IF (K <= (REAL(INTMAX)/17.0)**0.3333) THEN

                 K0 = 8*(2*K + 7)*(K*K + 7*K + 15)

                 M_08 = K0

                 M_04 = M_04 + M_08

             ELSE IF (K <= SQRT(REAL(INTMAX)*0.9)) THEN

                 K0 = 8*(2*K + 7)

                 M_08 = K0

                 K0 = K*K + 7*K + 15

                 M_08 = M_08 * K0

                 M_04 = M_04 + M_08

             ELSE

                 K0 = 8*(2*K + 7)

                 M_08 = K0

                 M_05 = M_08 * K

                 M_05 = M_05 * K

                 M_04 = M_04 + M_05

                 K0 = 7*K + 15

                 M_08 = M_08 * K0

                 M_04 = M_04 + M_08

             ENDIF

             M_07 = M_07 * M_04

          ENDDO

      ENDIF



      KLAST = (NT/4)*4

      DO J = KLAST, NT-1

         M_05 = J

         M_05 = M_11 + M_05

         M_07 = M_07 * M_05

      ENDDO



!             If the reflection formula was used, multiply by (-1)**NT.



  120 M_07%MFM(2) = MBSIGN*M_07%MFM(2)



!             Check for too much cancellation.



  130 IF (NCALL <= 1) THEN

          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17

      ELSE

          NGOAL = INT(-MXEXP2)

      ENDIF

      IF (M_07%MFM(0) <= NGOAL) THEN

          IF (NUMTRY > 0) THEN

              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)

              DO J = 1, NDGOAL+1

                 IF (MRETRY(J) /= M_07%MFM(J)) GO TO 140

              ENDDO

              GO TO 150

          ENDIF

  140     IEXTRA = INT(REAL(NGOAL-M_07%MFM(0))/ALOGM2 + 23.03/ALOGMB) + 1

          NDOLD = NDIG

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDIG - IEXTRA

              CALL FM_ST2M('UNKNOWN',M_07)

              GO TO 150

          ENDIF

          CALL FMEQ2(M_14%MFM,M_14%MFM,NDSAVE,NDIG,1)

          M_11 = M_14

          NUMTRY = NUMTRY + 1

          CALL FMEQ2(M_07%MFM,MRETRY,NDOLD,NDIG,0)

          GO TO 110

      ENDIF



  150 MACMAX = NINT(NDSAVE*ALOGM2)

      IF (N < 0) THEN

          M_02 = 1

          M_07 = M_02 / M_07

      ENDIF

      M_07%MFM(0) = MIN(M_07%MFM(0),MACCA,MACMAX)

      CALL FMEXT2(M_07%MFM,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)

      RETURN

      END SUBROUTINE FMPOCH

      SUBROUTINE FMPSI(MA,MB)



!  MB = PSI(MA)      (Derivative of Ln(Gamma(MA))



      USE FMVALS

      USE FMZM

      IMPLICIT NONE



      DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK)



!             Scratch array usage during FMPSI:  M_01 - M_10



      DOUBLE PRECISION 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



      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,M_09%MFM,NDSAVE,NDIG,0)

      M_09%MFM(0) = NINT(NDIG*ALOGM2)

      M_10 = M_09

      NUMTRY = 0



!             Near zero Psi(x) is about -1/x.



  110 IF (M_10%MFM(1) < (-NDIG-1)) THEN

          M_06 = -1 / M_10

          GO TO 140

      ENDIF



!             Check for special cases.



      KRFLCT = 0

      M_02 = -0.5

      IF (M_10 <= M_02) THEN

          KRFLCT = 1

          KFL = 0

          IF (MA(1) <= NDSAVE) THEN

              M_05 = AINT(M_10)

              IF (M_10 == M_05) KFL = -4

          ELSE

              KFL = -4

          ENDIF

          IF (KFL /= 0) THEN

              CALL FM_ST2M('UNKNOWN',M_06)

              KFLAG = -4

              GO TO 160

          ELSE

              M_10 = 1 - M_10

          ENDIF

      ENDIF



!             To speed the asymptotic series calculation, increase

!             the argument by LSHIFT.



      IEXTRA = 0

      KWRNSV = KWARN

      KWARN = 0

      INTA = M_10

      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

          M_08 = M_10 + LSHIFT

      ELSE

          M_08 = M_10

      ENDIF



!             Sum the asymptotic series.



      J2 = INT(0.3*ALOGMB + 0.2*SQRT(REAL(NDIG)))

      J2 = MAX(1,MIN(LJSUMS/(LUNPCK+2),J2))



!             M_10 is Z

!             M_08 is Z + LSHIFT

!             M_05 is X**J2 = (1/(Z+LSHIFT)**2)**J2

!             M_06 is the current power of X

!             M_07 is the current term in the sum

!             MJSUMS is the partial sum



      NDSAV1 = NDIG

      M_06 = 1

      J = -2*J2

      M_05 = M_08 ** J

      IF (ABS(M_05%MFM(1)) >= MEXPAB) THEN

          J2 = 1

          M_05 = M_08 ** (-2)

      ENDIF

      DO J = 1, J2

         NTERM = 2*J

         CALL FMBERN(NTERM,M_06%MFM,M_07%MFM)

         IF (KFLAG == -11) THEN

             CALL FM_ST2M('UNKNOWN',M_06)

             KFLAG = -4

             GO TO 160

         ENDIF

         NDENOM = NTERM

         KPT = (J-1)*(NDSAV1+2)

         CALL FMDIVI(M_07%MFM,NDENOM,MJSUMS(KPT))

      ENDDO



      NDIG2 = NDIG

  120 M_06 = M_06 * M_05

      NMXDIF = 2

      DO J = 1, J2

         NTERM = NTERM + 2

         CALL FMBERN(NTERM,M_06%MFM,M_07%MFM)

         IF (KFLAG == -11) THEN

             CALL FM_ST2M('UNKNOWN',M_06)

             KFLAG = -4

             GO TO 160

         ENDIF

         NDENOM = NTERM

         M_07 = M_07 / NDENOM

         NDIG = NDSAV1

         KPT = (J-1)*(NDSAV1+2)

         CALL FMADD(MJSUMS(KPT),M_07%MFM,MJSUMS(KPT))

         NMXDIF = MAX(NMXDIF,NDSAV1-INT(MJSUMS(KPT+1)-M_07%MFM(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

      M_05 = 1

      M_07 = M_08 ** 2

      M_07 = M_05 / M_07

      IF (J2 > 1) THEN

          KPT = (J2-1)*(NDSAV1+2)

          CALL FMEQ(MJSUMS(KPT),M_05%MFM)

          DO J = J2-1, 1, -1

             M_05 = M_05 * M_07

             KPT = (J-1)*(NDSAV1+2)

             CALL FMADD(M_05%MFM,MJSUMS(KPT),M_05%MFM)

          ENDDO

          CALL FMEQ(M_05%MFM,MJSUMS)

      ENDIF



!             Add the log term to the asymptotic series.



!             M_06 is the current sum as the log terms are added

!             M_07 is now LN(Z+LSHIFT)



      CALL FMMPY(MJSUMS,M_07%MFM,M_06%MFM)

      M_07 = LOG(M_08)

      M_02 = 1

      M_03 = M_02 / M_08

      M_03 = M_03 / 2

      M_03 = M_07 - M_03

      M_06 = M_03 - M_06



!             Now Psi of the shifted argument has been

!             computed.  Reverse the shifting.

!             The sum 1/(MA) + ... + 1/(MA+LSHIFT-1) is computed.



!             M_10 is Z

!             M_02 is X**2

!             M_03 is 16*Z**3

!             M_04 is the current four-term numerator

!             M_05 is the current four-term denominator

!             M_07 is the current sum



      IF (LSHIFT > 0) THEN

          M_02 = M_10 ** 2

          M_03 = M_10 * M_02

          M_04 = M_02 ** 2

          M_08 = M_03 * 6

          M_04 = M_04 + M_08

          M_08 = M_02 * 11

          M_04 = M_04 + M_08

          M_08 = M_10 * 6

          M_05 = M_04 + M_08

          M_04 = M_03 * 4

          M_08 = M_02 * 18

          M_04 = M_04 + M_08

          M_08 = M_10 * 22

          M_04 = M_04 + M_08

          M_08 = 6

          M_04 = M_04 + M_08

          M_07 = M_04 / M_05

          M_03 = M_03 * 16

          DO K = 4, LSHIFT-4, 4

             M_05 = M_05 + M_03



             M_08 = M_02 * 48

             M_04 = M_04 + M_08



             K2 = 8*(6*K - 3)

             M_08 = M_02 * K2

             M_05 = M_05 + M_08



             K1 = 16*(6*K - 3)

             M_08 = M_10 * K1

             M_04 = M_04 + M_08



             IF (K <= SQRT(REAL(INTMAX)/49.0)) THEN

                 K1 = 8*(6*K*K - 6*K + 7)

                 M_08 = M_10 * K1

                 M_05 = M_05 + M_08



                 M_08 = K1

                 M_04 = M_04 + M_08

             ELSE

                 K1 = 48*K

                 M_08 = M_10 * K1

                 M_08 = M_08 * K

                 M_05 = M_05 + M_08

                 K1B = 8*(-6*K + 7)

                 M_08 = M_10 * K1B

                 M_05 = M_05 + M_08



                 M_08 = K1

                 M_08 = M_08 * K

                 M_04 = M_04 + M_08

                 M_08 = K1B

                 M_04 = M_04 + M_08

             ENDIF

             IF (K <= (REAL(INTMAX)/17.0)**0.3333) THEN

                 K0 = 8*(2*K - 1)*(K*K - K + 3)

                 M_08 = K0

                 M_05 = M_05 + M_08

             ELSE IF (K <= SQRT(REAL(INTMAX)*0.9)) THEN

                 K0 = 8*(2*K - 1)

                 M_08 = K0

                 K0B = K*K - K + 3

                 M_08 = M_08 * K0B

                 M_05 = M_05 + M_08

             ELSE

                 K0 = 8*(2*K - 1)

                 M_08 = K0

                 M_08 = M_08 * K

                 M_08 = M_08 * K

                 M_05 = M_05 + M_08

                 K0B = -K + 3

                 M_08 = K0

                 M_08 = M_08 * K0B

                 M_05 = M_05 + M_08

             ENDIF

             M_08 = M_04 / M_05

             M_07 = M_07 + M_08

          ENDDO

          M_06 = M_06 - M_07

      ENDIF



!             Use the reflection formula if MA was less than -1/2.



      IF (KRFLCT == 1) THEN



!             Reduce the argument before multiplying by Pi.



          M_02 = ANINT(M_10)

          M_05 = M_10 - M_02

          M_05%MFM(0) = M_10%MFM(0)

          CALL FM_PI(M_07)

          M_07 = M_07 * M_05

          KRSAVE = KRAD

          KRAD = 1

          M_07 = TAN(M_07)

          KRAD = KRSAVE

          CALL FMDIV(MPISAV,M_07%MFM,M_07%MFM)

          M_06 = M_06 + M_07

      ENDIF



!             Check for too much cancellation.



  140 IF (NCALL <= 1) THEN

          NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17

      ELSE

          NGOAL = INT(-MXEXP2)

      ENDIF

      IF (M_06%MFM(0) <= NGOAL) THEN

          IF (NUMTRY > 0) THEN

              NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)

              DO J = 1, NDGOAL+1

                 IF (MRETRY(J) /= M_06%MFM(J)) GO TO 150

              ENDDO

              GO TO 160

          ENDIF

  150     IEXTRA = INT(REAL(NGOAL-M_06%MFM(0))/ALOGM2 + 23.03/ALOGMB) + 1

          NDOLD = NDIG

          NDIG = NDIG + IEXTRA

          IF (NDIG > NDG2MX) THEN

              KFLAG = -9

              CALL FMWRN2

              NDIG = NDIG - IEXTRA

              CALL FM_ST2M('UNKNOWN',M_06)

              GO TO 160

          ENDIF

          CALL FMEQ2(M_09%MFM,M_09%MFM,NDSAVE,NDIG,1)

          M_10 = M_09

          NUMTRY = NUMTRY + 1

          CALL FMEQ2(M_06%MFM,MRETRY,NDOLD,NDIG,0)

          GO TO 110

      ENDIF



  160 MACMAX = NINT(NDSAVE*ALOGM2)

      M_06%MFM(0) = MIN(M_06%MFM(0),MACCA,MACMAX)

      CALL FMEXT2(M_06%MFM,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

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      INTEGER INT

      CALL FMUNPK(MA,MPA)

      CALL FMBERN(INT,MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPBERN

      SUBROUTINE FPBETA(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMBETA(MPA,MPB,MPA)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPBETA

      SUBROUTINE FPCMBI(N,K,MA)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0: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

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMCOMB(MPA,MPB,MPA)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPCOMB

      SUBROUTINE FPEULR(MA)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK)

      CALL FMEULR(MPA)

      CALL FMPACK(MPA,MA)

      RETURN

      END SUBROUTINE FPEULR

      SUBROUTINE FPFACT(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMFACT(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPFACT

      SUBROUTINE FPGAM(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMGAM(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPGAM

      SUBROUTINE FPIBTA(MA,MB,MC,MD)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK),MD(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMUNPK(MC,MPC)

      CALL FMIBTA(MPA,MPB,MPC,MPA)

      CALL FMPACK(MPA,MD)

      RETURN

      END SUBROUTINE FPIBTA

      SUBROUTINE FPIGM1(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMIGM1(MPA,MPB,MPA)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPIGM1

      SUBROUTINE FPIGM2(MA,MB,MC)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK),MC(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMUNPK(MB,MPB)

      CALL FMIGM2(MPA,MPB,MPA)

      CALL FMPACK(MPA,MC)

      RETURN

      END SUBROUTINE FPIGM2

      SUBROUTINE FPLNGM(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMLNGM(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPLNGM

      SUBROUTINE FPPGAM(N,MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      INTEGER N

      CALL FMUNPK(MA,MPA)

      CALL FMPGAM(N,MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPPGAM

      SUBROUTINE FPPOCH(MA,N,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      INTEGER N

      CALL FMUNPK(MA,MPA)

      CALL FMPOCH(MPA,N,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPPOCH

      SUBROUTINE FPPSI(MA,MB)

      USE FMVALS

      IMPLICIT NONE

      DOUBLE PRECISION MA(0:LPACK),MB(0:LPACK)

      CALL FMUNPK(MA,MPA)

      CALL FMPSI(MPA,MPA)

      CALL FMPACK(MPA,MB)

      RETURN

      END SUBROUTINE FPPSI

