C C FM 1.1 David M. Smith 5-19-97 C C C C The FM routines in this package perform floating-point C multiple-precision arithmetic, and the IM routines perform C integer multiple-precision arithmetic. C C C C 1. INITIALIZING THE PACKAGE C C Before calling any routine in the package, several variables in C the common blocks /FMUSER/, /FM/, /FMBUFF/, and /FMSAVE/ must be C initialized. These four common blocks contain information that C is saved between calls, so they should be declared in the main C program. C C Subroutine FMSET initializes these variables to default values and C defines all machine-dependent values in the package. After calling C FMSET once at the start of a program, the user may sometimes want C to reset some of the variables in these common blocks. These C variables are described below. C C C C 2. REPRESENTATION OF FM NUMBERS C C MBASE is the base in which the arithmetic is done. MBASE must be C bigger than one, and less than or equal to the square root of C the largest representable integer. For best efficiency MBASE C should be large, but no more than about 1/4 of the square root C of the largest representable integer. Input and output C conversions are much faster when MBASE is a power of ten. C C NDIG is the number of base MBASE digits that are carried in the C multiple precision numbers. NDIG must be at least two. The C upper limit for NDIG is defined in the PARAMETER statement at C the top of each routine and is restricted only by the amount C of memory available. C C Sometimes it is useful to dynamically vary NDIG during the program. C Use FMEQU to round numbers to lower precision or zero-pad them to C higher precision when changing NDIG. C C It is rare to need to change MBASE during a program. Use FMCONS to C reset some saved constants that depend on MBASE. FMCONS should be C called immediately after changing MBASE. C C There are two representations for a floating multiple precision C number. The unpacked representation used by the routines while C doing the computations is base MBASE and is stored in NDIG+2 words. C A packed representation is available to store the numbers in the C user's program in compressed form. In this format, the NDIG C (base MBASE) digits of the mantissa are packed two per word to C conserve storage. Thus the external, packed form of a number C requires (NDIG+1)/2+2 words. C C This version uses double precision arrays to hold the numbers. C Version 1.0 of FM used integer arrays, which are faster on some C machines. The package can easily be changed to use integer C arrays -- see section 11 on EFFICIENCY below. C C The unpacked format of a floating multiple precision number is as C follows. A number MA is kept in an array with MA(1) containing C the exponent and MA(2) through MA(NDIG+1) containing one digit of C the mantissa, expressed in base MBASE. The array is dimensioned C to start at MA(0), with the approximate number of bits of precision C stored in MA(0). This precision value is intended to be used by FM C functions that need to monitor cancellation error in addition and C subtraction. The cancellation monitor code is usually disabled for C user calls, and FM functions only check for cancellation when they C must. Tracking cancellation causes most routines to run slower, C with addition and subtraction being affected the most. C C The exponent is a power of MBASE and the implied radix point is C immediately before the first digit of the mantissa. Every nonzero C number is normalized so that the second array element (the first C digit of the mantissa) is nonzero. C C In both representations the sign of the number is carried on the C second array element only. Elements 3,4,... are always nonnegative. C The exponent is a signed integer and may be as large in magnitude as C MXEXP (defined in FMSET). C C For MBASE = 10,000 and NDIG = 4, the number -pi would have these C representations: C Word 1 2 3 4 5 C C Unpacked: 1 -3 1415 9265 3590 C Packed: 1 -31415 92653590 C C Word 0 would be 42 in both formats, indicating that the mantissa C has about 42 bits of precision. C C Because of normalization in a large base, the equivalent number C of base 10 significant digits for an FM number may be as small as C LOG10(MBASE)*(NDIG-1) + 1. C C The integer routines use the FMLIB format to represent numbers, C without the number of digits (NDIG) being fixed. Integers in IM C format are essentially variable precision, using the minimum number C of words to represent each value. C C For programs using both FM and IM numbers, FM routines should not C be called with IM numbers, and IM routines should not be called C with FM numbers, since the implied value of NDIG used for an IM C number may not match the explicit NDIG expected by an FM routine. C Use the conversion routines IMFM2I and IMI2FM to change between C the FM and IM formats. C C C C 3. INPUT/OUTPUT ROUTINES C C All versions of the input routines perform free-format conversion C from characters to FM numbers. C C a. Conversion to or from a character array C C FMINP converts from a character*1 array to an FM number. C C FMOUT converts an FM number to base 10 and formats it for output C as an array of type character*1. The output is left C justified in the array, and the format is defined by two C variables in common, so that a separate format definition C does not have to be provided for each output call. C C The user sets JFORM1 and JFORM2 to determine the output format. C C JFORM1 = 0 E format ( .314159M+6 ) C = 1 1PE format ( 3.14159M+5 ) C = 2 F format ( 314159.000 ) C C JFORM2 is the number of significant digits to display (if C JFORM1 = 0 or 1). If JFORM2.EQ.0 then a default number C of digits is chosen. The default is roughly the full C precision of the number. C JFORM2 is the number of digits after the decimal point (if C JFORM1 = 2). See the FMOUT documentation for more details. C C b. Conversion to or from a character string C C FMST2M converts from a character string to an FM number. C C FMFORM converts an FM number to a character string according to C a format provided in each call. The format description C is more like that of a Fortran FORMAT statement, and C integer or fixed-point output is right justified. C C c. Direct read or write C C FMPRNT uses FMOUT to print one FM number. C C FMFPRT uses FMFORM to print one FM number. C C FMWRIT writes FM numbers for later input using FMREAD. C C FMREAD reads FM numbers written by FMWRIT. C C The values given to JFORM1 and JFORM2 can be used to define a C default output format when FMOUT or FMPRNT are called. The C explicit format used in a call to FMFORM or FMFPRT overrides C the settings of JFORM1 and JFORM2. C C KW is the unit number to be used for standard output from C the package, including error and warning messages, and C trace output. C C For multiple precision integers, the corresponding routines C IMINP, IMOUT, IMST2M, IMFORM, IMPRNT, IMFPRT, IMWRIT, and C IMREAD provide similar input and output conversions. For C output of IM numbers, JFORM1 and JFORM2 are ignored and C integer format (JFORM1=2, JFORM2=0) is used. C C For further description of these routines, see sections C 9 and 10 below. C C C C 4. ARITHMETIC TRACING C C NTRACE and LVLTRC control trace printout from the package. C C NTRACE = 0 No printout except warnings and errors. C = 1 The result of each call to one of the routines C is printed in base 10, using FMOUT. C = -1 The result of each call to one of the routines C is printed in internal base MBASE format. C = 2 The input arguments and result of each call to one C of the routines is printed in base 10, using FMOUT. C = -2 The input arguments and result of each call to one C of the routines is printed in base MBASE format. C C LVLTRC defines the call level to which the trace is done. LVLTRC = 1 C means only FM routines called directly by the user are traced, C LVLTRC = 2 also prints traces for FM routines called by other C FM routines called directly by the user, etc. C C In the above description, internal MBASE format means the number is C printed as it appears in the array --- an exponent followed by NDIG C base MBASE digits. C C C C 5. ERROR CONDITIONS C C KFLAG is a condition parameter returned by the package after each C call to one of the routines. Negative values indicate C conditions for which a warning message will be printed C unless KWARN = 0. Positive values indicate conditions C that may be of interest but are not errors. C No warning message is printed if KFLAG is nonnegative. C C KFLAG = 0 Normal operation. C C = 1 One of the operands in FMADD or FMSUB was C insignificant with respect to the other, so C that the result was equal to the argument of C larger magnitude. C = 2 In converting an FM number to a one word integer C in FMM2I, the FM number was not exactly an C integer. The next integer toward zero was C returned. C C = -1 NDIG was less than 2 or more than NDIGMX. C = -2 MBASE was less than 2 or more than MXBASE. C = -3 An exponent was out of range. C = -4 Invalid input argument(s) to an FM routine. C UNKNOWN was returned. C = -5 + or - OVERFLOW was generated as a result from an C FM routine. C = -6 + or - UNDERFLOW was generated as a result from an C FM routine. C = -7 The input string (array) to FMINP was not legal. C = -8 The character array was not large enough in an C input or output routine. C = -9 Precision could not be raised enough to provide all C requested guard digits. Increasing NDIGMX in C all the PARAMETER statements may fix this. C UNKNOWN was returned. C = -10 An FM input argument was too small in magnitude to C convert to the machine's single or double C precision in FMM2SP or FMM2DP. Check that the C definitions of SPMAX and DPMAX in FMSET are C correct for the current machine. C Zero was returned. C C When a negative KFLAG condition is encountered, the value of KWARN C determines the action to be taken. C C KWARN = 0 Execution continues and no message is printed. C = 1 A warning message is printed and execution continues. C = 2 A warning message is printed and execution stops. C C The default setting is KWARN = 1. C C When an overflow or underflow is generated for an operation in which C an input argument was already an overflow or underflow, no additional C message is printed. When an unknown result is generated and an input C argument was already unknown, no additional message is printed. In C these cases the negative KFLAG value is still returned. C C IM routines handle exceptions like OVERFLOW or UNKNOWN in the same C way as FM routines. When using IMMPY, the product of two large C positive integers will return +OVERFLOW. The routine IMMPYM can C be used to obtain a modular result without overflow. The largest C representable IM integer is MBASE**NDIGMX - 1. For example, if C MBASE is 10**7 and NDIGMX is set to 256, integers less than 10**1792 C can be used. C C C C 6. OTHER PARAMETERS C C KRAD = 0 All angles in the trigonometric functions and C inverse functions are measured in degrees. C = 1 All angles are measured in radians. (Default) C C C KROUND = 0 All final results are chopped (rounded toward C zero). Intermediate results are rounded. C = 1 All results are rounded to the nearest FM C number, or to the value with an even last C digit if the result is halfway between two C FM numbers. (Default) C C KSWIDE defines the maximum screen width to be used for C all unit KW output. Default is 80. C C KESWCH controls the action taken in FMINP and other input routines C for strings like 'E7' that have no digits before the exponent C field. Default is for 'E7' to translate like '1.0E+7'. C C CMCHAR defines the exponent letter to be used for FM variable C output. Default is 'M', as in 1.2345M+678. C C KDEBUG = 0 Error checking is not done for valid input arguments C and parameters like NDIG and MBASE upon entry to C each routine. (Default) C = 1 Some error checking is done. (Slower speed) C C See FMSET for additional description of these and other variables C defining various FM conditions. C C C C 7. ARRAY DIMENSIONS C C The dimensions of the arrays in the FM package are defined using C a PARAMETER statement at the top of each routine. The size of C these arrays depends on the values of parameters NDIGMX and NBITS. C NDIGMX is the maximum value the user may set for NDIG. C NBITS is the number of bits used to represent integers for a C given machine. See the EFFICIENCY discussion below. C C The standard version of FMLIB sets NDIGMX = 256, so on a 32-bit C machine using MBASE = 10**7 the maximum precision is about C 7*255+1 = 1786 significant digits. To change dimensions so that C 10,000 significant digit calculation can be done, NDIGMX needs to C be at least 10**4/7 + 5 = 1434. This allows for a few user guard C digits to be defined when the package is initialized using C CALL FMSET(10000). Changing 'NDIGMX=256' to 'NDIGMX=1434' C everywhere in the package and the user's calling program will C define all the new array sizes. C C If NDIG much greater than 256 is to be used and elementary functions C will be needed, they will be faster if array MJSUMS is larger. The C parameter defining the size of MJSUMS is set in the standard version C by LJSUMS = 8*(LUNPCK+2). The 8 means that up to eight concurrent C sums can be used by the elementary functions. The approximate number C needed for best speed is given by the formula C 0.051*Log(MBASE)*NDIG**(1/3) + 1.85 C For example, with MBASE=10**7 and NDIG=1434 this gives 11. Changing C 'LJSUMS = 8*(LUNPCK+2)' to 'LJSUMS =11*(LUNPCK+2)' everywhere in the C package and the user's calling program will give slightly better C speed. C C FM numbers in packed format have dimension 0:LPACK, and those C in unpacked format have dimension 0:LUNPCK. C C C C 8. PORTABILITY C C In FMSET there is some machine-dependent code that attempts to C approximate the largest representable integer value. The current C code works on all machines tested, but if an FM run fails, check C the MAXINT and INTMAX loops in FMSET. Values for SPMAX and DPMAX C are also defined in FMSET that should be set to values near overflow C for single precision and double precision. Setting KDEBUG = 1 may C also identify some errors if a run fails. C C Some compilers object to a function like FMCOMP with side effects C such as changing KFLAG or other common variables. Blocks of code C in FMCOMP and IMCOMP that modify common are identified so they may C be removed or commented out to produce a function without side C effects. This disables trace printing in FMCOMP and IMCOMP, and C error codes are not returned in KFLAG. See FMCOMP and IMCOMP for C further details. C C All variables are explicitly declared in each routine. There is C a commented IMPLICIT NONE statement in each routine that can be C enabled to get more compiler diagnostic information in some testing C or debugging situations. C C C 9. LIST OF ROUTINES C C These are the FM routines that are designed to be called by C the user. All are subroutines except logical function FMCOMP. C MA, MB, MC refer to FM format numbers. C C In each case it is permissible to use the same array more than C once in the calling sequence. The statement MA = MA*MA can C be written CALL FMMPY(MA,MA,MA). C C For each of these routines there is also a version available for C which the argument list is the same but all FM numbers are in packed C format. The routines using packed numbers have the same names except C 'FM' is replaced by 'FP' at the start of each name. C C C FMABS(MA,MB) MB = ABS(MA) C C FMACOS(MA,MB) MB = ACOS(MA) C C FMADD(MA,MB,MC) MC = MA + MB C C FMADDI(MA,IVAL) MA = MA + IVAL Increment an FM number by a one C word integer. Note this call C does not have an "MB" result C like FMDIVI and FMMPYI. C C FMASIN(MA,MB) MB = ASIN(MA) C C FMATAN(MA,MB) MB = ATAN(MA) C C FMATN2(MA,MB,MC) MC = ATAN2(MA,MB) C C FMBIG(MA) MA = Biggest FM number less than overflow. C C FMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA). Faster than C making two separate calls. C C FMCOMP(MA,LREL,MB) Logical comparison of MA and MB. C LREL is a CHARACTER*2 value identifying C which comparison is made. C Example: IF (FMCOMP(MA,'GE',MB)) ... C C FMCONS Set several saved constants that depend C on MBASE, the base being used. FMCONS C should be called immediately after C changing MBASE. C C FMCOS(MA,MB) MB = COS(MA) C C FMCOSH(MA,MB) MB = COSH(MA) C C FMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA). Faster than C making two separate calls. C C FMDIG(NSTACK,KST) Find a set of precisions to use during C Newton iteration for finding a simple C root starting with about double C precision accuracy. C C FMDIM(MA,MB,MC) MC = DIM(MA,MB) C C FMDIV(MA,MB,MC) MC = MA/MB C C FMDIVI(MA,IVAL,MB) MB = MA/IVAL IVAL is a one word integer. C C FMDP2M(X,MA) MA = X Convert from double precision to FM. C C FMDPM(X,MA) MA = X Convert from double precision to FM. C Much faster than FMDP2M, but MA agrees C with X only to D.P. accuracy. See C the comments in the two routines. C C FMEQ(MA,MB) MB = MA Both have precision NDIG. C This is the version to use for C standard B = A statements. C C FMEQU(MA,MB,NA,NB) MB = MA Version for changing precision. C MA has NA digits (i.e., MA was C computed using NDIG = NA), and MB C will be defined having NB digits. C MB is zero-padded if NB.GT.NA C MB is rounded if NB.LT.NA C C FMEXP(MA,MB) MB = EXP(MA) C C FMFORM(FORM,MA,STRING) MA is converted to a character string C using format FORM and returned in C STRING. FORM can represent I, F, C E, or 1PE formats. Example: C CALL FMFORM('F60.40',MA,STRING) C C FMFPRT(FORM,MA) Print MA on unit KW using FORM format. C C FMI2M(IVAL,MA) MA = IVAL Convert from one word integer C to FM. C C FMINP(LINE,MA,LA,LB) MA = LINE Input conversion. C Convert LINE(LA) through LINE(LB) C from characters to FM. C C FMINT(MA,MB) MB = INT(MA) Integer part of MA. C C FMIPWR(MA,IVAL,MB) MB = MA**IVAL Raise an FM number to a one C word integer power. C C FMLG10(MA,MB) MB = LOG10(MA) C C FMLN(MA,MB) MB = LOG(MA) C C FMLNI(IVAL,MA) MA = LOG(IVAL) Natural log of a one word C integer. C C FMM2DP(MA,X) X = MA Convert from FM to double precision. C C FMM2I(MA,IVAL) IVAL = MA Convert from FM to integer. C C FMM2SP(MA,X) X = MA Convert from FM to single precision. C C FMMAX(MA,MB,MC) MC = MAX(MA,MB) C C FMMIN(MA,MB,MC) MC = MIN(MA,MB) C C FMMOD(MA,MB,MC) MC = MA mod MB C C FMMPY(MA,MB,MC) MC = MA*MB C C FMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer. C C FMNINT(MA,MB) MB = NINT(MA) Nearest FM integer. C C FMOUT(MA,LINE,LB) LINE = MA Convert from FM to character. C LINE is a character array of C length LB. C C FMPI(MA) MA = pi C C FMPRNT(MA) Print MA on unit KW using current format. C C FMPWR(MA,MB,MC) MC = MA**MB C C FMREAD(KREAD,MA) MA is returned after reading one (possibly C multi-line) FM number on unit KREAD. This C routine reads numbers written by FMWRIT. C C FMRPWR(MA,K,J,MB) MB = MA**(K/J) Rational power. Faster than C FMPWR for functions like the cube root. C C FMSET(NPREC) Set default values and machine-dependent C variables to give at least NPREC base 10 C digits plus three base 10 guard digits. C Must be called to initialize FM package. C C FMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer. C C FMSIN(MA,MB) MB = SIN(MA) C C FMSINH(MA,MB) MB = SINH(MA) C C FMSP2M(X,MA) MA = X Convert from single precision to FM. C C FMSQR(MA,MB) MB = MA*MA Faster than FMMPY. C C FMSQRT(MA,MB) MB = SQRT(MA) C C FMST2M(STRING,MA) MA = STRING C Convert from character string to FM. C Often more convenient than FMINP, which C converts an array of CHARACTER*1 values. C Example: CALL FMST2M('123.4',MA). C C FMSUB(MA,MB,MC) MC = MA - MB C C FMTAN(MA,MB) MB = TAN(MA) C C FMTANH(MA,MB) MB = TANH(MA) C C FMULP(MA,MB) MB = One Unit in the Last Place of MA. C C FMWRIT(KWRITE,MA) Write MA on unit KWRITE. C Multi-line numbers will have '&' as the C last nonblank character on all but the last C line. These numbers can then be read C easily using FMREAD. C C C These are the integer routines that are designed to be called by C the user. All are subroutines except logical function IMCOMP. C MA, MB, MC refer to IM format numbers. In each case the version C of the routine to handle packed IM numbers has the same name, C with 'IM' replaced by 'IP'. C C IMABS(MA,MB) MB = ABS(MA) C C IMADD(MA,MB,MC) MC = MA + MB C C IMBIG(MA) MA = Biggest IM number less than overflow. C C IMCOMP(MA,LREL,MB) Logical comparison of MA and MB. C LREL is a CHARACTER*2 value identifying C which comparison is made. C Example: IF (IMCOMP(MA,'GE',MB)) ... C C IMDIM(MA,MB,MC) MC = DIM(MA,MB) C C IMDIV(MA,MB,MC) MC = int(MA/MB) C Use IMDIVR if the remainder is also needed. C C IMDIVI(MA,IVAL,MB) MB = int(MA/IVAL) C IVAL is a one word integer. Use IMDVIR C to get the remainder also. C C IMDIVR(MA,MB,MC,MD) MC = int(MA/MB), MD = MA mod MB C When both the quotient and remainder are C needed, this routine is twice as fast as C calling both IMDIV and IMMOD. C C IMDVIR(MA,IVAL,MB,IREM) MB = int(MA/IVAL), IREM = MA mod IVAL C IVAL and IREM are one word integers. C C IMEQ(MA,MB) MB = MA C C IMFM2I(MAFM,MB) MB = MAFM Convert from real (FM) format C to integer (IM) format. C C IMFORM(FORM,MA,STRING) MA is converted to a character string C using format FORM and returned in C STRING. FORM can represent I, F, C E, or 1PE formats. Example: C CALL IMFORM('I70',MA,STRING) C C IMFPRT(FORM,MA) Print MA on unit KW using FORM format. C C IMGCD(MA,MB,MC) MC = greatest common divisor of MA and MB. C C IMI2FM(MA,MBFM) MBFM = MA Convert from integer (IM) format C to real (FM) format. C C IMI2M(IVAL,MA) MA = IVAL Convert from one word integer C to IM. C C IMINP(LINE,MA,LA,LB) MA = LINE Input conversion. C Convert LINE(LA) through LINE(LB) C from characters to IM. C C IMM2DP(MA,X) X = MA Convert from IM to double precision. C C IMM2I(MA,IVAL) IVAL = MA Convert from IM to one word integer. C C IMMAX(MA,MB,MC) MC = MAX(MA,MB) C C IMMIN(MA,MB,MC) MC = MIN(MA,MB) C C IMMOD(MA,MB,MC) MC = MA mod MB C C IMMPY(MA,MB,MC) MC = MA*MB C C IMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer. C C IMMPYM(MA,MB,MC,MD) MD = MA*MB mod MC C Slightly faster than calling IMMPY and C IMMOD separately, and it works for cases C where IMMPY would return OVERFLOW. C C IMOUT(MA,LINE,LB) LINE = MA Convert from IM to character. C LINE is a character array of C length LB. C C IMPMOD(MA,MB,MC,MD) MD = MA**MB mod MC C C IMPRNT(MA) Print MA on unit KW. C C IMPWR(MA,MB,MC) MC = MA**MB C C IMREAD(KREAD,MA) MA is returned after reading one (possibly C multi-line) IM number on unit KREAD. This C routine reads numbers written by IMWRIT. C C IMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer. C C IMSQR(MA,MB) MB = MA*MA Faster than IMMPY. C C IMST2M(STRING,MA) MA = STRING C Convert from character string to IM. C Often more convenient than IMINP, which C converts an array of CHARACTER*1 values. C Example: CALL IMST2M('12345678901',MA). C C IMSUB(MA,MB,MC) MC = MA - MB C C IMWRIT(KWRITE,MA) Write MA on unit KWRITE. C Multi-line numbers will have '&' as the C last nonblank character on all but the last C line. These numbers can then be read C easily using IMREAD. C C Many of the IM routines call FM routines, but none of the FM C routines call IM routines, so the IM routines can be omitted C if none are called explicitly from a program. C C C C 10. NEW FOR VERSION 1.1 C C Version 1.0 used integer arrays and integer arithmetic internally C to perform the multiple precision operations. Version 1.1 uses C double precision arithmetic and arrays internally. This is usually C faster at higher precisions, and on many machines it is also faster C at lower precisions. Version 1.1 is written so that the arithmetic C used can easily be changed from double precision to integer, or any C other available arithmetic type. This permits the user to make the C best use of a given machine's arithmetic hardware. C See the EFFICIENCY discussion below. C C Several routines have undergone minor modification, but only a few C changes should affect programs that used FM 1.0. Many of the C routines are faster in version 1.1, because code has been added to C take advantage of special cases for individual functions instead of C using general formulas that are more compact. For example, there C are separate routines using series for SINH and COSH instead of C just calling EXP. C C FMEQU was the only routine that required the user to give the value C of the current precision. This was to allow automatic C rounding or zero-padding when changing precision. Since few C user calls change precision, a new routine has been added for C this case. C FMEQ now handles this case and has a simple argument list that C does not include the value of NDIG. C FMEQU is used for changing precision. C See the list of FM routines above for details. C C All variable names beginning with M in the package are now declared C as double precision, so FM common blocks in the user's program need C D.P. declarations, and FM variables (arrays) used in the calling C program need to be D.P. C C /FMUSER/ is a common block holding parameters that define the C arithmetic to be used and other user options. Several C new variables have been added, including screen width to C be used for output. See above for further description. C C /FMSAVE/ is a common block for saving constants to avoid C re-computing them. Several new variables have been added. C C /FMBUFF/ is a common block containing a character array used to C format FM numbers for output. Two new items have been C added. C C New routines: C C All the IM routines are new for version 1.1. C C FMADDI increments an FM number by a small integer. C It runs in O(1) time, on the average. C C FMCHSH returns both SINH(MA) and COSH(MA). C When both are needed, this is almost twice as fast C as making separate calls to FMCOSH and FMSINH. C C FMCSSN returns both SIN(MA) and COS(MA). C When both are needed, this is almost twice as fast C as making separate calls to FMCOS and FMSIN. C C FMFORM uses a format string to convert an FM number to a C character string. C C FMFPRT prints an FM number using a format string. C C FMREAD reads an FM number written using FMWRIT. C C FMRPWR computes an FM number raised to a rational power. For cube C roots and similar rational powers it is usually much faster C than FMPWR. C C FMSQR squares an FM number. It is faster than using FMMPY. C C FMST2M converts character strings to FM format. Since FMINP converts C character arrays, this routine can be more convenient for C easily defining an FM number. C For example, CALL FMST2M('123.4',MA). C C FMWRIT writes an FM number using a format for multi-line numbers C with '&' at the end of all but the last line of a multi-line C number. This allows automatic reading of FM numbers without C needing to know the base, precision or format under which they C were written. C C One extra word has been added to the dimensions of all FM numbers. C Word zero in each array contains a value used to monitor cancellation C error arising from addition or subtraction. This value approximates C the number of bits of precision for an FM value. It allows higher C level FM functions to detect cases where too much cancellation has C occurred. KACCSW is a switch variable in COMMON /FM/ used internally C to enable cancellation error monitoring. C C C 11. EFFICIENCY C C To take advantage of hardware architecture on different machines, the C package has been designed so that the arithmetic used to perform the C multiple precision operations can easily be changed. All variables C that must be changed to get a different arithmetic have names C beginning with 'M' and are declared using DOUBLE PRECISION M.... C C For example, to change the package to use integer arithmetic C internally, make these two changes everywhere in the package: C change 'DOUBLE PRECISION M' to 'INTEGER M', C change 'DINT(' to 'INT('. C On some systems, changing 'DINT(' to '(' may give better speed. C C When changing to a different type of arithmetic, all FM common blocks C and arrays in the user's program must be changed to agree. In a few C places in FM, where a DINT function is not supposed to be changed, it C is spelled 'DINT (' so the global change will not find it. C C This version restricts the base used to be also representable in C integer variables, so using precision above double usually does not C save much time unless integers can also be declared at a higher C precision. Using IEEE Extended would allow a base of around 10**9 C to be chosen, but the delayed digit-normalization method used for C multiplication and division means that a slightly smaller base like C 10**8 would usually run faster. This would usually not be much C faster than using 10**7 with double precision. C C The value of NBITS defined as a parameter in most FM routines C refers to the number of bits used to represent integers in an C M-variable word. Typical values for NBITS are: 24 for IEEE single C precision, 32 for integer, 53 for IEEE double precision. NBITS C controls only array size, so setting it too high is ok, but then C the program will use more memory than necessary. C C For cases where special compiler directives or minor re-writing C of the code may improve speed, several of the most important C loops in FM are identified by comments containing the string C '(Inner Loop)'. C C -------------------------------------------------------------------- C -------------------------------------------------------------------- C C SUBROUTINE FMSET(NPREC) C C Initialize the values in common that must be set before calling C other FM routines. C C Base and precision will be set to give at least NPREC+3 decimal C digits of precision (giving the user three base ten guard digits). C C MBASE is set to a large power of ten. C JFORM1 and JFORM2 are set to 1PE format displaying NPREC C significant digits. C C The trace option is set off. C The mode for angles in trig functions is set to radians. C The rounding mode is set to symmetric rounding. C Warning error message level is set to 1. C Cancellation error monitor is set off. C Screen width for output is set to 80 columns. C The exponent character for FM output is set to 'M'. C Debug error checking is set off. C C KW, the unit number for all FM output, is set to 6. C C The size of all arrays is controlled by defining two parameters: C NDIGMX is the maximum value the user can set NDIG, C NBITS is the number of bits used to represent integers in an C M-variable word. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C C Define the array sizes: C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2 + 1 , LUNPCK = (6*NDIGMX)/5 + 20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000 + 6 ) C INTEGER NPREC C C Here are all the common blocks used in FM. C C /FMUSER/, /FM/, /FMBUFF/, and /FMSAVE/ should also be declared in the C main program, because some compilers allocate and free space used for C labelled common that is declared only in subprograms. This causes C the saved information to be lost. C C FMUSER contains values that may need to be C changed by the calling program. C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C C FM contains the work array used by the low-level C arithmetic routines, definitions for overflow C and underflow thresholds, and other C machine-dependent values. C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C FMSAVE contains information about saved constants. C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C MJSUMS is an array that can contain several FM numbers C being used to accumulate concurrent sums in exponential C and trigonometric functions. When NDIGMX = 256, eight is C about the maximum number of sums needed (but this depends C on MBASE). For larger NDIGMX, dimensioning MJSUMS to hold C more than eight FM numbers could increase the speed of the C functions. C DOUBLE PRECISION MJSUMS C COMMON /FMSUMS/ MJSUMS(0:LJSUMS) C C FMWA contains two work arrays similar to MWA. They are C used in routines FMDIVD, FMMPYD, and FMMPYE. C DOUBLE PRECISION MWD,MWE C COMMON /FMWA/ MWD(LMWA),MWE(LMWA) C C CMBUFF is a character array used by FMPRNT for printing C output from FMOUT. This array may also be used C for calls to FMOUT from outside the FM package. C CMCHAR is the letter used before the exponent field C in FMOUT. It is defined in FMSET. C NAMEST is a stack for names of the routines. It is C used for trace printing and error messages. C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C C FM1 contains scratch arrays for temporary storage of FM C numbers while computing various functions. C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C C FMPCK contains scratch arrays used to hold input arguments C in unpacked format when the packed versions of functions C are used. C DOUBLE PRECISION MPA,MPB,MPC C COMMON /FMPCK/ MPA(0:LUNPCK),MPB(0:LUNPCK),MPC(0:LUNPCK) C DOUBLE PRECISION ONE,TEMP,TWO,YT C CHARACTER LCHARS(21) DOUBLE PRECISION ML,MLD2,MLM1 INTEGER J,K,KPT,L,LTYPES(21),LVALS(21),NPSAVE C DATA LCHARS/'+','-','0','1','2','3','4','5','6','7','8','9', * '.','E','D','Q','M','e','d','q','m'/ DATA LTYPES/1,1,10*2,3,8*4/ DATA LVALS/1,-1,0,1,2,3,4,5,6,7,8,9,9*0/ C C KW is the unit number for standard output from the C FM package. This includes trace output and error C messages. C KW = 6 C C MAXINT should be set to a very large integer, possibly C the largest representable integer for the current C machine. For most 32-bit machines, MAXINT is set C to 2**53 - 1 = 9.007D+15 when double precision C arithmetic is used for M-variables. Using integer C M-variables usually gives MAXINT = 2**31 - 1 = C 2 147 483 647. C C Setting MAXINT to a smaller number is ok, but this C unnecessarily restricts the permissible range of C MBASE and MXEXP. C C The following code should set MAXINT to the largest C representable number of the form 2**J - 1. C C The FMMSET call keeps some compilers from doing the 110 C loop at the highest precision available and then rounding C to the declared precision. C MAXINT = 3 110 CALL FMMSET(MAXINT,ML,MLD2,MLM1) IF (MLD2.EQ.MAXINT .AND. MLM1.NE.ML) THEN MAXINT = ML GO TO 110 ENDIF C C INTMAX is a large value close to the overflow threshold C for integer variables. It is usually 2**31 - 1 C for machines with 32-bit integer arithmetic. C C WARNING: This loop causes integer overflow to occur, so it C is a likely place for the program to fail when C run on a different machine. The loop below has C been used successfully with Fortran compilers C for many different machines, but even different C versions of the same compiler may give different C results. Check the values of MAXINT and INTMAX C if there are problems installing FM. C INTMAX = 3 120 L = 2*INTMAX + 1 IF (INT(L/2).EQ.INTMAX) THEN INTMAX = L GO TO 120 ENDIF C C DPMAX should be set to a value near the machine's double C precision overflow threshold, so that DPMAX and C 1.0D0/DPMAX are both representable in double C precision. C DPMAX = 1.0D+74 C C SPMAX should be set to a value near the machine's single C precision overflow threshold, so that 1.01*SPMAX C and 1.0/SPMAX are both representable in single C precision. C SPMAX = 1.0E+37 C C NDG2MX is the maximum value for NDIG that can be used C internally. FM routines may raise NDIG above C NDIGMX temporarily, to compute correctly C rounded results. C In the definition of LUNPCK, the '6/5' condition C allows for converting from a large base to the C (smaller) largest power of ten base for output C conversion. C The '+ 20' condition allows for the need to carry C many guard digits when using a small base like 2. C NDG2MX = LUNPCK - 1 C C MXBASE is the maximum value for MBASE. C TEMP = MAXINT MXBASE = INT(MIN(DBLE(INTMAX),SQRT(TEMP))) C C MBASE is the currently used base for arithmetic. C K = INT(LOG10(DBLE(MXBASE)/4)) MBASE = 10**K C C NDIG is the number of digits currently being carried. C NPSAVE = NPREC NDIG = 2 + (NPREC+2)/K IF (NDIG.LT.2 .OR. NDIG.GT.NDIGMX) THEN NDIG = MAX(2,MIN(NDIGMX,NDIG)) WRITE (KW,130) NPREC,NDIG 130 FORMAT(//' Precision out of range when calling FMSET.', * ' NPREC =',I20/' The nearest valid NDIG will be used', * ' instead: NDIG =',I6//) NPSAVE = 0 ENDIF C C KFLAG is the flag for error conditions. C KFLAG = 0 C C NTRACE is the trace switch. Default is no printing. C NTRACE = 0 C C LVLTRC is the trace level. Default is to trace only C routines called directly by the user. C LVLTRC = 1 C C NCALL is the call stack pointer. C NCALL = 0 C C NAMEST is the call stack. C DO 140 J = 0, 50 NAMEST(J) = 'MAIN ' 140 CONTINUE C C Some constants that are often needed are stored with the C maximum precision to which they have been computed in the C currently used base. This speeds up the trig, log, power, C and exponential functions. C C NDIGPI is the number of digits available in the currently C stored value of pi (MPISAV). C NDIGPI = 0 C C MBSPI is the value of MBASE for the currently stored C value of pi. C MBSPI = 0 C C NDIGE is the number of digits available in the currently C stored value of e (MESAV). C NDIGE = 0 C C MBSE is the value of MBASE for the currently stored C value of e. C MBSE = 0 C C NDIGLB is the number of digits available in the currently C stored value of LN(MBASE) (MLBSAV). C NDIGLB = 0 C C MBSLB is the value of MBASE for the currently stored C value of LN(MBASE). C MBSLB = 0 C C NDIGLI is the number of digits available in the currently C stored values of the four logarithms used by FMLNI C MLN1 - MLN4. C NDIGLI = 0 C C MBSLI is the value of MBASE for the currently stored C values of MLN1 - MLN4. C MBSLI = 0 C C MXEXP is the current maximum exponent. C MXEXP2 is the internal maximum exponent. This is used to C define the overflow and underflow thresholds. C C These values are chosen so that FM routines can raise the C overflow/underflow limit temporarily while computing C intermediate results, and so that EXP(INTMAX) is greater C than MXBASE**(MXEXP2+1). C C The overflow threshold is MBASE**(MXEXP+1), and the C underflow threshold is MBASE**(-MXEXP-1). C This means the valid exponents in the first word of an FM C number can range from -MXEXP to MXEXP+1 (inclusive). C MXEXP = INT((DBLE(INTMAX))/(2.0D0*LOG(DBLE(MXBASE))) - 1.0D0) MXEXP2 = INT(2*MXEXP + MXEXP/100) C C KACCSW is a switch used to enable cancellation error C monitoring. Routines where cancellation is C not a problem run faster by skipping the C cancellation monitor calculations. C KACCSW = 0 means no error monitoring, C = 1 means error monitoring is done. C KACCSW = 0 C C MEXPUN is the exponent used as a special symbol for C underflowed results. C MEXPUN = -MXEXP2 - 5*NDIGMX C C MEXPOV is the exponent used as a special symbol for C overflowed results. C MEXPOV = -MEXPUN C C MUNKNO is the exponent used as a special symbol for C unknown FM results (1/0, SQRT(-3.0), ...). C MUNKNO = MEXPOV + 5*NDIGMX C C RUNKNO is returned from FM to real or double conversion C routines when no valid result can be expressed in C real or double precision. On systems that provide C a value for undefined results (e.g., Not A Number) C setting RUNKNO to that value is reasonable. On C other systems set it to a value that is likely to C make any subsequent results obviously wrong that C use it. In either case a KFLAG = -4 condition is C also returned. C RUNKNO = -1.01*SPMAX C C IUNKNO is returned from FM to integer conversion routines C when no valid result can be expressed as a one word C integer. KFLAG = -4 is also set. C IUNKNO = -INT(MXEXP2) C C JFORM1 indicates the format used by FMOUT. C JFORM1 = 1 C C JFORM2 indicates the number of digits used in FMOUT. C JFORM2 = NPSAVE C C KRAD = 1 indicates that trig functions use radians, C = 0 means use degrees. C KRAD = 1 C C KWARN = 0 indicates that no warning message is printed C and execution continues when UNKNOWN or another C exception is produced. C = 1 means print a warning message and continue. C = 2 means print a warning message and stop. C KWARN = 1 C C KROUND = 1 causes all results to be rounded to the C nearest FM number, or to the value with C an even last digit if the result is halfway C between two FM numbers. C = 0 causes all results to be chopped. C KROUND = 1 C C KSWIDE defines the maximum screen width to be used for C all unit KW output. C KSWIDE = 80 C C KESWCH = 1 causes input to FMINP with no digits before C the exponent letter to be treated as if there C were a leading '1'. This is sometimes better C for interactive input: 'E7' converts to C 10.0**7. C = 0 causes a leading zero to be assumed. This C gives compatibility with Fortran: 'E7' C converts to 0.0. C KESWCH = 1 C C CMCHAR defines the exponent letter to be used for C FM variable output from FMOUT, as in 1.2345M+678. C Change it to 'E' for output to be read by a C non-FM program. C CMCHAR = 'M' C C KSUB is an internal flag set during subtraction so that C the addition routine will negate its second argument. C KSUB = 0 C C KDEBUG = 0 Error checking is not done for valid input C arguments and parameters like NDIG and MBASE C upon entry to each routine. C = 1 Error checking is done. C KDEBUG = 0 C C Initialize two hash tables that are used for character C look-up during input conversion. C DO 150 J = LHASH1, LHASH2 KHASHT(J) = 5 KHASHV(J) = 0 150 CONTINUE DO 170 J = 1, 21 KPT = ICHAR(LCHARS(J)) IF (KPT.LT.LHASH1 .OR. KPT.GT.LHASH2) THEN WRITE (KW,160) LCHARS(J),KPT,LHASH1,LHASH2 160 FORMAT(/' 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.'//) ELSE KHASHT(KPT) = LTYPES(J) KHASHV(KPT) = LVALS(J) ENDIF 170 CONTINUE C C DPEPS is the approximate machine precision. C ONE = 1.0D0 TWO = 128.0D0 DPEPS = ONE C 180 DPEPS = DPEPS/TWO CALL FMDBL(ONE,DPEPS,YT) IF (YT.GT.ONE) GO TO 180 DPEPS = DPEPS*TWO TWO = 2.0D0 190 DPEPS = DPEPS/TWO CALL FMDBL(ONE,DPEPS,YT) IF (YT.GT.ONE) GO TO 190 DPEPS = DPEPS*TWO C C FMCONS sets several real and double precision constants. C CALL FMCONS C RETURN END SUBROUTINE FMABS(MA,MB) C C MB = ABS(MA) C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MD2B INTEGER KWRNSV C NCALL = NCALL + 1 NAMEST(NCALL) = 'FMABS ' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MA,1) C KFLAG = 0 KWRNSV = KWARN KWARN = 0 CALL FMEQ(MA,MB) MB(2) = ABS(MB(2)) KWARN = KWRNSV C IF (KACCSW.EQ.1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MD2B) ENDIF IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMACOS(MA,MB) C C MB = ACOS(MA) C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMACOS: M01 - M06 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MA2,MACCA,MACMAX,MXSAVE INTEGER K,KASAVE,KOVUN,KRESLT,NDSAVE C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (ABS(MA(1)).GT.MEXPAB .OR. MA(1).GT.0 .OR. MA(2).EQ.0) THEN CALL FMENTR('FMACOS',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMACOS' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MA,1) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF C MA2 = MA(2) MACCA = MA(0) CALL FMEQ2(MA,MB,NDSAVE,NDIG,0) MB(0) = NINT(NDIG*ALOGM2) C C Use ACOS(X) = ATAN(SQRT(1-X*X)/X) C 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) C CALL FMATAN(MB,MB) C IF (MA2.LT.0) THEN IF (KRAD.EQ.1) THEN CALL FMPI(M05) ELSE CALL FMI2M(180,M05) ENDIF CALL FMSUB(M05,MB,MB) ENDIF C C Round the result and return. C 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 FMADD(MA,MB,MC) C C MC = MA + MB C C This routine performs the trace printing for addition. C FMADD2 is used to do the arithmetic. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'FMADD ' CALL FMNTR(2,MA,MB,2) C CALL FMADD2(MA,MB,MC) C CALL FMNTR(1,MC,MC,1) ELSE CALL FMADD2(MA,MB,MC) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMADD2(MA,MB,MC) C C Internal addition routine. MC = MA + MB C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MA0,MA1,MA2,MB0,MB1,MB2,MB2RD INTEGER J,JCOMP,JSIGN,KRESLT,N1,NGUARD,NMWA REAL B2RDA,B2RDB C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MB(1)).GT.MEXPAB .OR. * KDEBUG.EQ.1) THEN IF (KSUB.EQ.1) THEN CALL FMARGS('FMSUB ',2,MA,MB,KRESLT) ELSE CALL FMARGS('FMADD ',2,MA,MB,KRESLT) ENDIF IF (KRESLT.NE.0) THEN NCALL = NCALL + 1 IF (KSUB.EQ.1) THEN NAMEST(NCALL) = 'FMSUB ' ELSE NAMEST(NCALL) = 'FMADD ' ENDIF CALL FMRSLT(MA,MB,MC,KRESLT) NCALL = NCALL - 1 RETURN ENDIF ELSE IF (MA(2).EQ.0) THEN MA0 = MIN(MA(0),MB(0)) CALL FMEQ(MB,MC) MC(0) = MA0 KFLAG = 1 IF (KSUB.EQ.1) THEN IF (MC(1).NE.MUNKNO) MC(2) = -MC(2) KFLAG = 0 ENDIF RETURN ENDIF IF (MB(2).EQ.0) THEN MA0 = MIN(MA(0),MB(0)) CALL FMEQ(MA,MC) MC(0) = MA0 KFLAG = 1 RETURN ENDIF ENDIF C MA0 = MA(0) IF (KACCSW.EQ.1) THEN MB0 = MB(0) MA1 = MA(1) MB1 = MB(1) ENDIF KFLAG = 0 N1 = NDIG + 1 C C NGUARD is the number of guard digits used. C IF (NCALL.GT.1) THEN NGUARD = NGRD21 IF (NGUARD.GT.NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 IF (NGUARD.GT.NDIG) NGUARD = NDIG ENDIF NMWA = N1 + NGUARD C C Save the signs of MA and MB and then work with C positive numbers. C JSIGN is the sign of the result of MA + MB. C JSIGN = 1 MA2 = MA(2) MB2 = MB(2) IF (KSUB.EQ.1) MB2 = -MB2 MA(2) = ABS(MA(2)) MB(2) = ABS(MB(2)) C C See which one is larger in absolute value. C IF (MA(1).GT.MB(1)) THEN JCOMP = 1 GO TO 120 ENDIF IF (MB(1).GT.MA(1)) THEN JCOMP = 3 GO TO 120 ENDIF C DO 110 J = 2, N1 IF (MA(J).GT.MB(J)) THEN JCOMP = 1 GO TO 120 ENDIF IF (MB(J).GT.MA(J)) THEN JCOMP = 3 GO TO 120 ENDIF 110 CONTINUE C JCOMP = 2 C 120 IF (JCOMP.LT.3) THEN IF (MA2.LT.0) JSIGN = -1 IF (MA2*MB2.GT.0) THEN CALL FMADDP(MA,MB,NGUARD,NMWA) ELSE CALL FMADDN(MA,MB,NGUARD,NMWA) ENDIF ELSE IF (MB2.LT.0) JSIGN = -1 IF (MA2*MB2.GT.0) THEN CALL FMADDP(MB,MA,NGUARD,NMWA) ELSE CALL FMADDN(MB,MA,NGUARD,NMWA) ENDIF ENDIF IF (KSUB.EQ.1) MB2 = -MB2 MB(2) = MB2 MA(2) = MA2 C C Transfer to MC and fix the sign of the result. C CALL FMMOVE(MWA,MC) IF (JSIGN.LT.0) MC(2) = -MC(2) C IF (KFLAG.LT.0) THEN IF (KSUB.EQ.1) THEN NAMEST(NCALL) = 'FMSUB ' ELSE NAMEST(NCALL) = 'FMADD ' ENDIF CALL FMWARN ENDIF C IF (KACCSW.EQ.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).EQ.0) THEN MC(0) = 0 ELSE MC(0) = MIN(MAX(MA0,MB0),MB2RD) ENDIF ELSE MC(0) = MA0 ENDIF C RETURN END SUBROUTINE FMADDI(MA,IVAL) C C MA = MA + IVAL C C Increment MA by one word integer IVAL. C C This routine is faster than FMADD when IVAL is small enough so C that it can be added to a single word of MA without often causing C a carry. Otherwise FMI2M and FMADD are used. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) INTEGER IVAL C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMADDI: M01 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MAEXP,MD2B,MKSUM INTEGER KPTMA C NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'FMADDI' CALL FMNTR(2,MA,MA,1) CALL FMNTRI(2,IVAL,0) ENDIF KFLAG = 0 C MAEXP = MA(1) IF (MAEXP.LE.0 .OR. MAEXP.GT.NDIG) GO TO 110 KPTMA = INT(MAEXP) + 1 IF (KPTMA.GT.2 .AND. MA(2).LT.0) THEN MKSUM = MA(KPTMA) - IVAL ELSE MKSUM = MA(KPTMA) + IVAL ENDIF C IF (MKSUM.GE.MBASE .OR. MKSUM.LE.(-MBASE)) GO TO 110 IF (MA(2).LT.0) THEN IF (KPTMA.GT.2) THEN IF (MKSUM.GE.0) THEN MA(KPTMA) = MKSUM GO TO 120 ELSE GO TO 110 ENDIF ELSE IF (MKSUM.LT.0) THEN MA(KPTMA) = MKSUM GO TO 120 ELSE GO TO 110 ENDIF ENDIF ELSE IF (KPTMA.GT.2) THEN IF (MKSUM.GE.0) THEN MA(KPTMA) = MKSUM GO TO 120 ELSE GO TO 110 ENDIF ELSE IF (MKSUM.GT.0) THEN MA(KPTMA) = MKSUM GO TO 120 ELSE GO TO 110 ENDIF ENDIF ENDIF C 110 CALL FMI2M(IVAL,M01) CALL FMADD(MA,M01,MA) C 120 IF (KACCSW.EQ.1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315) MA(0) = MIN(MA(0),MD2B) ENDIF IF (NTRACE.NE.0) THEN CALL FMNTR(1,MA,MA,1) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMADDN(MA,MB,NGUARD,NMWA) C C Internal addition routine. MWA = MA - MB C The arguments are such that MA.GE.MB.GE.0. C C NGUARD is the number of guard digits being carried. C NMWA is the number of words in MWA that will be used. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) INTEGER NGUARD,NMWA C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C DOUBLE PRECISION MK,MR INTEGER J,K,KL,KP1,KP2,KPT,KSH,N1,N2,NK,NK1 C N1 = NDIG + 1 C C Check for an insignificant operand. C MK = MA(1) - MB(1) IF (MK.GE.NDIG+2) THEN DO 110 J = 1, N1 MWA(J) = MA(J) 110 CONTINUE MWA(N1+1) = 0 KFLAG = 1 RETURN ENDIF K = INT(MK) IF (NGUARD.LE.1) NMWA = N1 + 2 C C Subtract MB from MA. C KP1 = MIN(N1,K+1) MWA(K+1) = 0 DO 120 J = 1, KP1 MWA(J) = MA(J) 120 CONTINUE KP2 = K + 2 C C (Inner Loop) C DO 130 J = KP2, N1 MWA(J) = MA(J) - MB(J-K) 130 CONTINUE C N2 = NDIG + 2 IF (N2-K.LE.1) N2 = 2 + K NK = MIN(NMWA,N1+K) DO 140 J = N2, NK MWA(J) = -MB(J-K) 140 CONTINUE NK1 = NK + 1 DO 150 J = NK1, NMWA MWA(J) = 0 150 CONTINUE C C Normalize. Fix the sign of any negative digit. C IF (K.GT.0) THEN DO 160 J = NMWA, KP2, -1 IF (MWA(J).LT.0) THEN MWA(J) = MWA(J) + MBASE MWA(J-1) = MWA(J-1) - 1 ENDIF 160 CONTINUE C KPT = KP2 - 1 170 IF (MWA(KPT).LT.0 .AND. KPT.GE.3) THEN MWA(KPT) = MWA(KPT) + MBASE MWA(KPT-1) = MWA(KPT-1) - 1 KPT = KPT - 1 GO TO 170 ENDIF GO TO 190 ENDIF C DO 180 J = N1, 3, -1 IF (MWA(J).LT.0) THEN MWA(J) = MWA(J) + MBASE MWA(J-1) = MWA(J-1) - 1 ENDIF 180 CONTINUE C C Shift left if there are any leading zeros in the mantissa. C 190 DO 200 J = 2, NMWA IF (MWA(J).GT.0) THEN KSH = J - 2 GO TO 210 ENDIF 200 CONTINUE MWA(1) = 0 RETURN C 210 IF (KSH.GT.0) THEN KL = NMWA - KSH DO 220 J = 2, KL MWA(J) = MWA(J+KSH) 220 CONTINUE DO 230 J = KL+1, NMWA MWA(J) = 0 230 CONTINUE MWA(1) = MWA(1) - KSH ENDIF C C Round the result. C MR = 2*MWA(NDIG+2) + 1 IF (MR.GE.MBASE) THEN IF (MR-1.GT.MBASE .AND. MWA(N1).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.1) THEN MWA(N1) = MWA(N1) + 1 MWA(N1+1) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,0) ENDIF ENDIF C C See if the result is equal to one of the input arguments. C IF (ABS(MA(1)-MB(1)).LT.NDIG) GO TO 250 IF (ABS(MA(1)-MB(1)).GT.NDIG+1) THEN KFLAG = 1 GO TO 250 ENDIF C N2 = NDIG + 4 DO 240 J = 3, N1 IF (MWA(N2-J).NE.MA(N2-J)) GO TO 250 240 CONTINUE IF (MWA(1).NE.MA(1)) GO TO 250 IF (MWA(2).NE.ABS(MA(2))) GO TO 250 KFLAG = 1 C 250 RETURN END SUBROUTINE FMADDP(MA,MB,NGUARD,NMWA) C C Internal addition routine. MWA = MA + MB C The arguments are such that MA.GE.MB.GE.0. C C NMWA is the number of words in MWA that will be used. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) INTEGER NGUARD,NMWA C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C DOUBLE PRECISION MK,MKT,MR INTEGER J,K,KP,KP2,KPT,KSHIFT,N1,N2,NK C N1 = NDIG + 1 C C Check for an insignificant operand. C MK = MA(1) - MB(1) IF (MK.GE.NDIG+1) THEN MWA(1) = MA(1) + 1 MWA(2) = 0 DO 110 J = 2, N1 MWA(J+1) = MA(J) 110 CONTINUE MWA(N1+2) = 0 KFLAG = 1 RETURN ENDIF K = INT(MK) C C Add MA and MB. C MWA(1) = MA(1) + 1 MWA(2) = 0 DO 120 J = 2, K+1 MWA(J+1) = MA(J) 120 CONTINUE KP2 = K + 2 C C (Inner Loop) C DO 130 J = KP2, N1 MWA(J+1) = MA(J) + MB(J-K) 130 CONTINUE N2 = NDIG + 2 NK = MIN(NMWA,N1+K) DO 140 J = N2, NK MWA(J+1) = MB(J-K) 140 CONTINUE DO 150 J = NK+1, NMWA MWA(J+1) = 0 150 CONTINUE C C Normalize. Fix any digit not less than MBASE. C IF (K.EQ.NDIG) GO TO 220 C IF (K.GT.0) THEN DO 160 J = N1+1, KP2, -1 IF (MWA(J).GE.MBASE) THEN MWA(J) = MWA(J) - MBASE MWA(J-1) = MWA(J-1) + 1 ENDIF 160 CONTINUE C KPT = KP2 - 1 170 IF (MWA(KPT).GE.MBASE .AND. KPT.GE.3) THEN MWA(KPT) = MWA(KPT) - MBASE MWA(KPT-1) = MWA(KPT-1) + 1 KPT = KPT - 1 GO TO 170 ENDIF GO TO 190 ENDIF C DO 180 J = N1+1, 3, -1 IF (MWA(J).GE.MBASE) THEN MWA(J) = MWA(J) - MBASE MWA(J-1) = MWA(J-1) + 1 ENDIF 180 CONTINUE C C Shift right if the leading digit is not less than MBASE. C 190 IF (MWA(2).GE.MBASE) THEN 200 KP = NMWA + 4 DO 210 J = 4, NMWA MWA(KP-J) = MWA(KP-J-1) 210 CONTINUE MKT = DINT(MWA(2)/MBASE) MWA(3) = MWA(2) - MKT*MBASE MWA(2) = MKT MWA(1) = MWA(1) + 1 IF (MWA(2).GE.MBASE) GO TO 200 ENDIF C C Round the result. C 220 KSHIFT = 0 IF (MWA(2).EQ.0) KSHIFT = 1 MR = 2*MWA(NDIG+2+KSHIFT) + 1 IF (MR.GE.MBASE) THEN IF (MR-1.GT.MBASE .AND. MWA(N1+KSHIFT).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.1) THEN MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1 MWA(N1+1+KSHIFT) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ENDIF ENDIF C C See if the result is equal to one of the input arguments. C IF (ABS(MA(1)-MB(1)).LT.NDIG) GO TO 240 IF (KSHIFT.EQ.0) GO TO 240 IF (ABS(MA(1)-MB(1)).GT.NDIG+1) THEN KFLAG = 1 GO TO 240 ENDIF C N2 = NDIG + 4 DO 230 J = 3, N1 IF (MWA(N2-J+1).NE.MA(N2-J)) GO TO 240 230 CONTINUE IF (MWA(1).NE.MA(1)+1) GO TO 240 IF (MWA(3).NE.ABS(MA(2))) GO TO 240 KFLAG = 1 C 240 RETURN END SUBROUTINE FMARGS(KROUTN,NARGS,MA,MB,KRESLT) C C Check the input arguments to a routine for special cases. C C KROUTN - Name of the subroutine that was called C NARGS - The number of input arguments (1 or 2) C MA - First input argument C MB - Second input argument (if NARGS is 2) C KRESLT - Result code returned to the calling routine. C C Result codes: C C 0 - Perform the normal operation C 1 - The result is the first input argument C 2 - The result is the second input argument C 3 - The result is -OVERFLOW C 4 - The result is +OVERFLOW C 5 - The result is -UNDERFLOW C 6 - The result is +UNDERFLOW C 7 - The result is -1.0 C 8 - The result is +1.0 C 9 - The result is -pi/2 C 10 - The result is +pi/2 C 11 - The result is 0.0 C 12 - The result is UNKNOWN C 13 - The result is +pi C 14 - The result is -pi/4 C 15 - The result is +pi/4 C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C CHARACTER *6 KROUTN DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) INTEGER NARGS,KRESLT C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MBS INTEGER J,KWRNSV,NCATMA,NCATMB,NDS INTEGER KADD(15,15),KMPY(15,15),KDIV(15,15),KPWR(15,15), * KSQRT(15),KEXP(15),KLN(15),KSIN(15),KCOS(15),KTAN(15), * KASIN(15),KACOS(15),KATAN(15),KSINH(15),KCOSH(15), * KTANH(15),KLG10(15) C C These tables define the result codes to be returned for C given values of the input argument(s). C C For example, in row 7 column 2 of this DATA statement C KADD(2,7) = 2 means that if the first argument in a call C to FMADD is in category 7 ( -UNDERFLOW ) and the second C argument is in category 2 ( near -OVERFLOW but C representable ) then the result code is 2 ( the value C of the sum is equal to the second input argument). C See routine FMCAT for descriptions of the categories. C DATA KADD/ 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,12,12, 2 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0,12, 3 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, 4 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, 5 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, 6 3, 0, 0, 0, 0, 0,12, 1,12, 0, 0, 0, 0, 0, 4, 7 3, 2, 2, 2, 2,12,12, 5,12,12, 2, 2, 2, 2, 4, 8 3, 2, 2, 2, 2, 2, 5, 2, 6, 2, 2, 2, 2, 2, 4, 9 3, 2, 2, 2, 2,12,12, 6,12,12, 2, 2, 2, 2, 4, A 3, 0, 0, 0, 0, 0,12, 1,12, 0, 0, 0, 0, 0, 4, B 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, C 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, D 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, E 12, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, F 12,12, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 / C DATA KMPY/ 4, 4, 4, 4,12,12,12,11,12,12,12, 3, 3, 3, 3, 2 4, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 3, 3 4, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 3, 4 4, 0, 0, 0, 0, 0, 6,11, 5, 0, 0, 1, 0, 0, 3, 5 12, 0, 0, 0, 0, 0, 6,11, 5, 0, 0, 1, 0, 0,12, 6 12, 0, 0, 0, 0, 0, 6,11, 5, 0, 0, 1, 0, 0,12, 7 12,12,12, 6, 6, 6, 6,11, 5, 5, 5, 5,12,12,12, 8 11,11,11,11,11,11,11,11,11,11,11,11,11,11,11, 9 12,12,12, 5, 5, 5, 5,11, 6, 6, 6, 6,12,12,12, A 12, 0, 0, 0, 0, 0, 5,11, 6, 0, 0, 1, 0, 0,12, B 12, 0, 0, 0, 0, 0, 5,11, 6, 0, 0, 1, 0, 0,12, C 3, 2, 2, 2, 2, 2, 5,11, 6, 2, 2, 2, 2, 2, 4, D 3, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 4, E 3, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 4, F 3, 3, 3, 3,12,12,12,11,12,12,12, 4, 4, 4, 4 / C DATA KDIV/12,12,12, 4, 4, 4, 4,12, 3, 3, 3, 3,12,12,12, 2 12, 0, 0, 0, 0, 0, 4,12, 3, 0, 0, 1, 0, 0,12, 3 12, 0, 0, 0, 0, 0, 4,12, 3, 0, 0, 1, 0, 0,12, 4 6, 0, 0, 0, 0, 0, 4,12, 3, 0, 0, 1, 0, 0, 5, 5 6, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 5, 6 6, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 5, 7 6, 6, 6, 6,12,12,12,12,12,12,12, 5, 5, 5, 5, 8 11,11,11,11,11,11,11,12,11,11,11,11,11,11,11, 9 5, 5, 5, 5,12,12,12,12,12,12,12, 6, 6, 6, 6, A 5, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 6, B 5, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 6, C 5, 0, 0, 0, 0, 0, 3,12, 4, 0, 0, 1, 0, 0, 6, D 12, 0, 0, 0, 0, 0, 3,12, 4, 0, 0, 1, 0, 0,12, E 12, 0, 0, 0, 0, 0, 3,12, 4, 0, 0, 1, 0, 0,12, F 12,12,12, 3, 3, 3, 3,12, 4, 4, 4, 4,12,12,12 / C DATA KPWR/12,12, 0, 5,12,12,12, 8,12,12,12, 3, 0,12,12, 2 12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12, 3 12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12, 4 12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12, 5 12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12, 6 12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12, 7 12,12, 0, 3,12,12,12, 8,12,12,12, 5, 0,12,12, 8 12,12,12,12,12,12,12,12,11,11,11,11,11,11,11, 9 4, 4, 4, 4,12,12,12, 8,12,12,12, 6, 6, 6, 6, A 4, 4, 0, 0, 0, 8, 8, 8, 8, 0, 0, 1, 0, 6, 6, B 4, 4, 0, 0, 0, 8, 8, 8, 8, 0, 0, 1, 0, 6, 6, C 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, D 6, 6, 0, 0, 0, 8, 8, 8, 8, 8, 0, 1, 0, 4, 4, E 6, 6, 0, 0, 0, 8, 8, 8, 8, 8, 0, 1, 0, 4, 4, F 6, 6, 6, 6,12,12,12, 8,12,12,12, 4, 4, 4, 4 / C DATA KSQRT/12,12,12,12,12,12,12,11,12, 0, 0, 8, 0, 0,12/ DATA KEXP / 6, 6, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0, 4, 4/ DATA KLN /12,12,12,12,12,12,12,12,12, 0, 0,11, 0, 0,12/ DATA KSIN /12,12, 0, 0, 0, 0, 5,11, 6, 0, 0, 0, 0,12,12/ DATA KCOS /12,12, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0,12,12/ DATA KTAN /12,12, 0, 0, 0, 0, 5,11, 6, 0, 0, 0, 0,12,12/ DATA KASIN/12,12,12, 9, 0, 0, 5,11, 6, 0, 0,10,12,12,12/ DATA KACOS/12,12,12,13, 0,10,10,10,10,10, 0,11,12,12,12/ DATA KATAN/ 9, 9, 0,14, 0, 0, 5,11, 6, 0, 0,15, 0,10,10/ DATA KSINH/ 3, 3, 0, 0, 0, 1, 5,11, 6, 1, 0, 0, 0, 4, 4/ DATA KCOSH/ 4, 4, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0, 4, 4/ DATA KTANH/ 7, 7, 0, 0, 0, 1, 5,11, 6, 1, 0, 0, 0, 8, 8/ DATA KLG10/12,12,12,12,12,12,12,12,12, 0, 0,11, 0, 0,12/ C KRESLT = 12 KFLAG = -4 IF (MA(1).EQ.MUNKNO) RETURN IF (NARGS.EQ.2) THEN IF (MB(1).EQ.MUNKNO) RETURN ENDIF IF (MBLOGS.NE.MBASE) CALL FMCONS KFLAG = 0 NAMEST(NCALL) = KROUTN C C Check the validity of parameters if this is a user call. C IF (NCALL.GT.1 .AND. KDEBUG.EQ.0) GO TO 170 C C Check NDIG. C IF (NDIG.LT.2 .OR. NDIG.GT.NDIGMX) THEN KFLAG = -1 CALL FMWARN NDS = NDIG IF (NDIG.LT.2) NDIG = 2 IF (NDIG.GT.NDIGMX) NDIG = NDIGMX WRITE (KW,110) NDS,NDIG 110 FORMAT(' NDIG was',I10,'. It has been changed to',I10,'.') RETURN ENDIF C C Check MBASE. C IF (MBASE.LT.2 .OR. MBASE.GT.MXBASE) THEN KFLAG = -2 CALL FMWARN MBS = MBASE IF (MBASE.LT.2) MBASE = 2 IF (MBASE.GT.MXBASE) MBASE = MXBASE WRITE (KW,120) INT(MBS),INT(MBASE) 120 FORMAT(' MBASE was',I10,'. It has been changed to',I10,'.') CALL FMCONS RETURN ENDIF C C Check exponent range. C IF (MA(1).GT.MXEXP+1 .OR. MA(1).LT.-MXEXP) THEN IF (ABS(MA(1)).NE.MEXPOV .OR. ABS(MA(2)).NE.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.EQ.2) THEN IF (MB(1).GT.MXEXP+1 .OR. MB(1).LT.-MXEXP) THEN IF (ABS(MB(1)).NE.MEXPOV .OR. ABS(MB(2)).NE.1) THEN CALL FMIM(0,MB) KFLAG = -3 CALL FMWARN MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) RETURN ENDIF ENDIF ENDIF C C Check for properly normalized digits in the C input arguments. C IF (ABS(MA(1)-INT(MA(1))).NE.0) KFLAG = 1 IF (MA(2).LE.(-MBASE) .OR. MA(2).GE.MBASE .OR. * ABS(MA(2)-INT(MA(2))).NE.0) KFLAG = 2 IF (KDEBUG.EQ.0) GO TO 140 DO 130 J = 3, NDIG+1 IF (MA(J).LT.0 .OR. MA(J).GE.MBASE .OR. * ABS(MA(J)-INT(MA(J))).NE.0) THEN KFLAG = J GO TO 140 ENDIF 130 CONTINUE 140 IF (KFLAG.NE.0) THEN J = KFLAG MBS = MA(J) CALL FMIM(0,MA) KFLAG = -4 KWRNSV = KWARN IF (KWARN.GE.2) KWARN = 1 CALL FMWARN KWARN = KWRNSV IF (KWARN.GE.1) THEN WRITE (KW,*) ' First invalid array element: MA(', * J,') = ',MBS ENDIF MA(1) = MUNKNO MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) IF (KWARN.GE.2) THEN STOP ENDIF RETURN ENDIF IF (NARGS.EQ.2) THEN IF (ABS(MB(1)-INT(MB(1))).NE.0) KFLAG = 1 IF (MB(2).LE.(-MBASE) .OR. MB(2).GE.MBASE .OR. * ABS(MB(2)-INT(MB(2))).NE.0) KFLAG = 2 IF (KDEBUG.EQ.0) GO TO 160 DO 150 J = 3, NDIG+1 IF (MB(J).LT.0 .OR. MB(J).GE.MBASE .OR. * ABS(MB(J)-INT(MB(J))).NE.0) THEN KFLAG = J GO TO 160 ENDIF 150 CONTINUE 160 IF (KFLAG.NE.0) THEN J = KFLAG MBS = MB(J) CALL FMIM(0,MB) KFLAG = -4 KWRNSV = KWARN IF (KWARN.GE.2) KWARN = 1 CALL FMWARN KWARN = KWRNSV IF (KWARN.GE.1) THEN WRITE (KW,*) ' First invalid array element: MB(', * J,') = ',MBS ENDIF MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) IF (KWARN.GE.2) THEN STOP ENDIF RETURN ENDIF ENDIF C C Check for special cases. C 170 CALL FMCAT(MA,NCATMA) NCATMB = 0 IF (NARGS.EQ.2) CALL FMCAT(MB,NCATMB) C IF (KROUTN.EQ.'FMADD ') THEN KRESLT = KADD(NCATMB,NCATMA) GO TO 180 ENDIF C IF (KROUTN.EQ.'FMSUB ') THEN IF (NCATMB.LT.16) NCATMB = 16 - NCATMB KRESLT = KADD(NCATMB,NCATMA) GO TO 180 ENDIF C IF (KROUTN.EQ.'FMMPY ') THEN KRESLT = KMPY(NCATMB,NCATMA) GO TO 180 ENDIF C IF (KROUTN.EQ.'FMDIV ') THEN KRESLT = KDIV(NCATMB,NCATMA) GO TO 180 ENDIF C IF (KROUTN.EQ.'FMPWR ') THEN KRESLT = KPWR(NCATMB,NCATMA) GO TO 180 ENDIF C IF (KROUTN.EQ.'FMSQRT') THEN KRESLT = KSQRT(NCATMA) GO TO 180 ENDIF C IF (KROUTN.EQ.'FMEXP ') THEN KRESLT = KEXP(NCATMA) GO TO 180 ENDIF C IF (KROUTN.EQ.'FMLN ') THEN KRESLT = KLN(NCATMA) GO TO 180 ENDIF C IF (KROUTN.EQ.'FMSIN ') THEN KRESLT = KSIN(NCATMA) GO TO 180 ENDIF C IF (KROUTN.EQ.'FMCOS ') THEN KRESLT = KCOS(NCATMA) GO TO 180 ENDIF C IF (KROUTN.EQ.'FMTAN ') THEN KRESLT = KTAN(NCATMA) GO TO 180 ENDIF C IF (KROUTN.EQ.'FMASIN') THEN KRESLT = KASIN(NCATMA) IF ((NCATMA.EQ.7.OR.NCATMA.EQ.9) .AND. KRAD.EQ.0) KRESLT = 12 GO TO 180 ENDIF C IF (KROUTN.EQ.'FMACOS') THEN KRESLT = KACOS(NCATMA) GO TO 180 ENDIF C IF (KROUTN.EQ.'FMATAN') THEN KRESLT = KATAN(NCATMA) IF ((NCATMA.EQ.7.OR.NCATMA.EQ.9) .AND. KRAD.EQ.0) KRESLT = 12 GO TO 180 ENDIF C IF (KROUTN.EQ.'FMSINH') THEN KRESLT = KSINH(NCATMA) GO TO 180 ENDIF C IF (KROUTN.EQ.'FMCOSH') THEN KRESLT = KCOSH(NCATMA) GO TO 180 ENDIF C IF (KROUTN.EQ.'FMTANH') THEN KRESLT = KTANH(NCATMA) GO TO 180 ENDIF C IF (KROUTN.EQ.'FMLG10') THEN KRESLT = KLG10(NCATMA) GO TO 180 ENDIF C KRESLT = 0 RETURN C 180 IF (KRESLT.EQ.12) THEN KFLAG = -4 CALL FMWARN ENDIF IF (KRESLT.EQ.3 .OR. KRESLT.EQ.4) THEN IF (NCATMA.EQ.1 .OR. NCATMA.EQ.7 .OR. NCATMA.EQ.9 .OR. * NCATMA.EQ.15 .OR. NCATMB.EQ.1 .OR. NCATMB.EQ.7 .OR. * NCATMB.EQ.9 .OR. NCATMB.EQ.15) THEN KFLAG = -5 ELSE KFLAG = -5 CALL FMWARN ENDIF ENDIF IF (KRESLT.EQ.5 .OR. KRESLT.EQ.6) THEN IF (NCATMA.EQ.1 .OR. NCATMA.EQ.7 .OR. NCATMA.EQ.9 .OR. * NCATMA.EQ.15 .OR. NCATMB.EQ.1 .OR. NCATMB.EQ.7 .OR. * NCATMB.EQ.9 .OR. NCATMB.EQ.15) THEN KFLAG = -6 ELSE KFLAG = -6 CALL FMWARN ENDIF ENDIF RETURN END SUBROUTINE FMASIN(MA,MB) C C MB = ARCSIN(MA) C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMASIN: M01 - M06 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCA,MACMAX,MXSAVE INTEGER K,KASAVE,KOVUN,KRESLT,NDSAVE C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (ABS(MA(1)).GT.MEXPAB .OR. MA(1).GT.0 .OR. MA(2).EQ.0) THEN CALL FMENTR('FMASIN',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMASIN' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MA,1) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF C MACCA = MA(0) CALL FMEQ2(MA,MB,NDSAVE,NDIG,0) MB(0) = NINT(NDIG*ALOGM2) C C Use ASIN(X) = ATAN(X/SQRT(1-X*X)) C 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) C CALL FMATAN(MB,MB) C C Round the result and return. C 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(MA,MB) C C MB = ARCTAN(MA) C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION X,XM DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) INTEGER NSTACK(19) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMATAN: M01 - M06 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MA1,MA2,MACCA,MACMAX,MXSAVE INTEGER J,K,KASAVE,KOVUN,KRESLT,KRSAVE,KST,KWRNSV,NDSAV1,NDSAVE, * NDSV C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (ABS(MA(1)).GT.MEXPAB .OR. MA(2).EQ.0) THEN CALL FMENTR('FMATAN',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMATAN' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MA,1) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF C MACCA = MA(0) CALL FMEQ2(MA,M05,NDSAVE,NDIG,0) M05(0) = NINT(NDIG*ALOGM2) C C If MA.GE.1 work with 1/MA. C MA1 = MA(1) MA2 = MA(2) M05(2) = ABS(M05(2)) IF (MA1.GE.1) THEN CALL FMI2M(1,MB) CALL FMDIV(MB,M05,M05) ENDIF C KRSAVE = KRAD KRAD = 1 KWRNSV = KWARN C X = M05(1) XM = MXBASE C C In case pi has not been computed at the current precision C and will be needed here, get it to full precision first C to avoid repeated calls at increasing precision during C Newton iteration. C IF (MA1.GE.1 .OR. KRSAVE.EQ.0) THEN IF (MBSPI.NE.MBASE .OR. NDIGPI.LT.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 C C If the argument is small, use the Taylor series, C otherwise use Newton iteration. C IF (X*DLOGMB.LT.-5.0D0*LOG(XM)) THEN KWARN = 0 CALL FMEQ(M05,MB) IF (MB(1).LE.-NDIG) GO TO 130 CALL FMSQR(M05,M06) J = 3 NDSAV1 = NDIG C 110 CALL FMMPY(M05,M06,M05) IF (M05(1).NE.MUNKNO) M05(2) = -M05(2) CALL FMDIVI(M05,J,M03) NDIG = NDSAV1 CALL FMADD(MB,M03,MB) IF (KFLAG.NE.0) THEN KFLAG = 0 GO TO 130 ENDIF NDIG = NDSAV1 - INT((MB(1)-M03(1))) IF (NDIG.LT.2) NDIG = 2 J = J + 2 GO TO 110 ELSE C CALL FMM2DP(M05,X) X = ATAN(X) CALL FMDPM(X,MB) CALL FMDIG(NSTACK,KST) C C Newton iteration. C DO 120 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) 120 CONTINUE MB(0) = NINT(NDIG*ALOGM2) ENDIF C C If MA.GE.1 use pi/2 - ATAN(1/MA) C 130 IF (MA1.GE.1) THEN CALL FMDIVI(MPISAV,2,M06) CALL FMSUB(M06,MB,MB) ENDIF C C Convert to degrees if necessary, round and return. C KRAD = KRSAVE IF (KRAD.EQ.0) THEN CALL FMMPYI(MB,180,MB) CALL FMDIV(MB,MPISAV,MB) ENDIF IF (MB(1).NE.MUNKNO .AND. MA2.LT.0) MB(2) = -MB(2) C IF (KFLAG.EQ.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 FMATN2(MA,MB,MC) C C MC = ATAN2(MA,MB) C C MC is returned as the angle between -pi and pi (or -180 and 180 if C degree mode is selected) for which TAN(MC) = MA/MB. MC is an angle C for the point (MB,MA) in polar coordinates. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMATN2: M01 - M06 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCA,MACCB,MACMAX,MXEXP1,MXSAVE INTEGER JQUAD,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MB(1)).GT.MEXPAB) THEN CALL FMENTR('FMATN2',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMATN2' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MB,2) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MB,MC,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF C KWRNSV = KWARN KWARN = 0 C 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) C C Check for special cases. C IF (MA(1).EQ.MUNKNO .OR. MB(1).EQ.MUNKNO .OR. * (MA(2).EQ.0 .AND. MB(2).EQ.0)) THEN CALL FMIM(0,MC) MC(1) = MUNKNO MC(2) = 1 MC(0) = NINT(NDIG*ALOGM2) KFLAG = -4 GO TO 110 ENDIF C IF (MB(2).EQ.0 .AND. MA(2).GT.0) THEN IF (KRAD.EQ.0) THEN CALL FMI2M(90,MC) ELSE CALL FMPI(MC) CALL FMDIVI(MC,2,MC) ENDIF GO TO 110 ENDIF C IF (MB(2).EQ.0 .AND. MA(2).LT.0) THEN IF (KRAD.EQ.0) THEN CALL FMI2M(-90,MC) ELSE CALL FMPI(MC) CALL FMDIVI(MC,-2,MC) ENDIF GO TO 110 ENDIF C MXEXP1 = INT(MXEXP2/2.01D0) IF (MA(1).EQ.MEXPOV .AND. MB(1).LT.MXEXP1-NDIG-2) THEN IF (KRAD.EQ.0) THEN CALL FMI2M(90,MC) ELSE CALL FMPI(MC) CALL FMDIVI(MC,2,MC) ENDIF IF (M01(2).LT.0) MC(2) = -MC(2) GO TO 110 ENDIF C IF (MA(1).EQ.MEXPUN .AND. (-MB(1)).LT.MXEXP1-NDIG-2 .AND. * MB(2).LT.0) THEN IF (KRAD.EQ.0) THEN CALL FMI2M(180,MC) ELSE CALL FMPI(MC) ENDIF IF (M01(2).LT.0) MC(2) = -MC(2) GO TO 110 ENDIF C IF (MB(1).EQ.MEXPOV .AND. MA(1).LT.MXEXP1-NDIG-2 .AND. * MB(2).LT.0) THEN IF (KRAD.EQ.0) THEN CALL FMI2M(180,MC) ELSE CALL FMPI(MC) ENDIF IF (M01(2).LT.0) MC(2) = -MC(2) GO TO 110 ENDIF C IF (MB(1).EQ.MEXPUN .AND. MA(2).EQ.0) THEN IF (MB(2).LT.0) THEN IF (KRAD.EQ.0) THEN CALL FMI2M(180,MC) ELSE CALL FMPI(MC) ENDIF ELSE CALL FMI2M(0,MC) ENDIF GO TO 110 ENDIF C IF (MB(1).EQ.MEXPUN .AND. (-MA(1)).LT.MXEXP1-NDIG-2) THEN IF (KRAD.EQ.0) THEN CALL FMI2M(90,MC) ELSE CALL FMPI(MC) CALL FMDIVI(MC,2,MC) ENDIF IF (M01(2).LT.0) MC(2) = -MC(2) GO TO 110 ENDIF C C Determine the quadrant for the result, then use FMATAN. C IF (MA(2).GE.0 .AND. MB(2).GT.0) JQUAD = 1 IF (MA(2).GE.0 .AND. MB(2).LT.0) JQUAD = 2 IF (MA(2).LT.0 .AND. MB(2).LT.0) JQUAD = 3 IF (MA(2).LT.0 .AND. MB(2).GT.0) JQUAD = 4 C CALL FMDIV(M01,M02,MC) MC(2) = ABS(MC(2)) CALL FMATAN(MC,MC) C IF (JQUAD.EQ.2 .OR. JQUAD.EQ.3) THEN IF (KRAD.EQ.0) THEN CALL FMI2M(180,M05) CALL FMSUB(M05,MC,MC) ELSE CALL FMPI(M05) CALL FMSUB(M05,MC,MC) ENDIF ENDIF C IF ((JQUAD.EQ.3 .OR. JQUAD.EQ.4) .AND. MC(1).NE.MUNKNO) * MC(2) = -MC(2) C C Round the result and return. C 110 IF (KFLAG.EQ.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 FMBIG(MA) C C MA = The biggest representable FM number using the current base C and precision. C The smallest positive number is then 1.0/MA. C Because of rounding, 1.0/(1.0/MA) will then overflow. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER J,N1 C NCALL = NCALL + 1 NAMEST(NCALL) = 'FMBIG ' C IF (MBLOGS.NE.MBASE) CALL FMCONS KFLAG = 0 N1 = NDIG + 1 DO 110 J = 2, N1 MA(J) = MBASE - 1 110 CONTINUE MA(1) = MXEXP + 1 MA(0) = NINT(NDIG*ALOGM2) C IF (NTRACE.NE.0) CALL FMNTR(1,MA,MA,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMCAT(MA,NCAT) C C NCAT is returned as the category of MA. This is used by the various C arithmetic routines to handle special cases such as: C 'number greater than 1' + 'underflowed result' is the first argument, C 'overflowed result' / 'overflowed result' is 'unknown'. C C NCAT range C C 1. -OV OV stands for overflowed results. C 2. (-OV , -OVTH) ( MA(1) .GE. MAXEXP+2 ) C 3. (-OVTH , -1) C 4. -1 OVTH stands for a representable C 5. (-1 , -UNTH) number near the overflow C 6. (-UNTH , -UN) threshold. C 7. -UN ( MA(1) .GE. MAXEXP-NDIG+1 ) C 8. 0 C 9. +UN UN stands for underflowed results. C 10. (+UN , +UNTH) ( MA(1) .LE. -MAXEXP-1 ) C 11. (+UNTH , +1) C 12. +1 UNTH stands for a representable C 13. (+1 , +OVTH) number near the underflow C 14. (+OVTH , +OV) threshold. C 15. +OV ( MA(1) .LE. -MAXEXP+NDIG-1 ) C 16. UNKNOWN C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) INTEGER NCAT C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C DOUBLE PRECISION MA2,MXEXP1 INTEGER J,NLAST C C Check for special symbols. C NCAT = 16 IF (MA(1).EQ.MUNKNO) RETURN C IF (MA(1).EQ.MEXPOV) THEN NCAT = 15 IF (MA(2).LT.0) NCAT = 1 RETURN ENDIF C IF (MA(1).EQ.MEXPUN) THEN NCAT = 9 IF (MA(2).LT.0) NCAT = 7 RETURN ENDIF C IF (MA(2).EQ.0) THEN NCAT = 8 RETURN ENDIF C C Check for +1 or -1. C MA2 = ABS(MA(2)) IF (MA(1).EQ.1 .AND. MA2.EQ.1) THEN NLAST = NDIG + 1 IF (NLAST.GE.3) THEN DO 110 J = 3, NLAST IF (MA(J).NE.0) GO TO 120 110 CONTINUE ENDIF NCAT = 12 IF (MA(2).LT.0) NCAT = 4 RETURN ENDIF C 120 MXEXP1 = INT(MXEXP2/2.01D0) IF (MA(1).GE.MXEXP1-NDIG+1) THEN NCAT = 14 IF (MA(2).LT.0) NCAT = 2 RETURN ENDIF C IF (MA(1).GE.1) THEN NCAT = 13 IF (MA(2).LT.0) NCAT = 3 RETURN ENDIF C IF (MA(1).GE.-MXEXP1+NDIG) THEN NCAT = 11 IF (MA(2).LT.0) NCAT = 5 RETURN ENDIF C IF (MA(1).GE.-MXEXP2) THEN NCAT = 10 IF (MA(2).LT.0) NCAT = 6 RETURN ENDIF C RETURN END SUBROUTINE FMCHSH(MA,MB,MC) C C MB = COSH(MA), MC = SINH(MA) C C If both the hyperbolic sine and cosine are needed, this routine C is faster than calling both FMCOSH and FMSINH. C C MB and MC must be distinct arrays. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during FMCHSH: M01 - M04 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MA2,MACCA,MACMAX,MXSAVE INTEGER K,KASAVE,KOVUN,KRESLT,KWRNSV,NCSAVE,NDSAVE C IF (MBLOGS.NE.MBASE) CALL FMCONS MACCA = MA(0) MA2 = MA(2) IF (ABS(MA(1)).GT.MEXPAB) THEN NCSAVE = NCALL CALL FMENTR('FMCHSH',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (MA(1).EQ.MUNKNO) KOVUN = 2 NCALL = NCSAVE + 1 CALL FMEQ(MA,M04) 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.NE.0) CALL FMNTR(2,MA,MA,1) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.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 C CALL FMEQ2(MA,M04,NDSAVE,NDIG,0) M04(0) = NINT(NDIG*ALOGM2) M04(2) = ABS(M04(2)) C K = 1 IF (M04(1).EQ.0 .AND. M04(2).NE.0) THEN IF (MBASE/M04(2).GE.100) K = 2 ENDIF IF (M04(1).GE.0 .AND. M04(2).NE.0 .AND. K.EQ.1) THEN CALL FMCOSH(M04,MB) IF (MB(1).GT.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 C C Round and return. C 110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315) MC(0) = MIN(MC(0),MACCA,MACMAX) IF (MA2.LT.0 .AND. MC(1).NE.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.EQ.2) THEN KWRNSV = KWARN KWARN = 0 ENDIF CALL FMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) IF (KOVUN.EQ.2) THEN KWARN = KWRNSV ENDIF IF (NTRACE.NE.0) THEN IF (ABS(NTRACE).GE.1 .AND. NCALL+1.LE.LVLTRC) THEN IF (NTRACE.LT.0) THEN CALL FMNTRJ(MC,NDIG) ELSE CALL FMPRNT(MC) ENDIF ENDIF ENDIF RETURN END FUNCTION FMCOMP(MA,LREL,MB) C C Logical comparison of FM numbers MA and MB. C C LREL is a CHARACTER *2 description of the comparison to be done: C LREL = 'EQ' returns FMCOMP = .TRUE. if MA.EQ.MB C = 'NE', 'GE', 'GT', 'LE', 'LT' also work like a logical IF. C C For comparisons involving 'UNKNOWN' or two identical special symbols C such as +OVERFLOW,'EQ',+OVERFLOW, FMCOMP is returned FALSE and a C KFLAG = -4 error condition is returned. C C Some compilers object to functions with side effects such as C changing KFLAG or other common variables. Blocks of code that C modify common are identified by: C C DELETE START C ... C C DELETE STOP C These may be removed or commented out to produce a function without C side effects. This disables trace printing in FMCOMP, and error C codes are not returned in KFLAG. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C LOGICAL FMCOMP CHARACTER *2 JREL,LREL DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER J,JCOMP,NLAST C C DELETE START NCALL = NCALL + 1 NAMEST(NCALL) = 'FMCOMP' C IF (NCALL.LE.LVLTRC .AND. ABS(NTRACE).GE.2) THEN WRITE (KW,110) 110 FORMAT(' Input to FMCOMP') C IF (NTRACE.GT.0) THEN CALL FMPRNT(MA) WRITE (KW,120) LREL 120 FORMAT(7X,'.',A2,'.') CALL FMPRNT(MB) ELSE CALL FMNTRJ(MA,NDIG) WRITE (KW,120) LREL CALL FMNTRJ(MB,NDIG) ENDIF ENDIF C DELETE STOP C C JCOMP will be 1 if MA.GT.MB C 2 if MA.EQ.MB C 3 if MA.LT.MB C C Check for special cases. C JREL = LREL IF (LREL.NE.'EQ' .AND. LREL.NE.'NE' .AND. LREL.NE.'LT' .AND. * LREL.NE.'GT' .AND. LREL.NE.'LE' .AND. LREL.NE.'GE') THEN IF (LREL.EQ.'eq') THEN JREL = 'EQ' ELSE IF (LREL.EQ.'ne') THEN JREL = 'NE' ELSE IF (LREL.EQ.'lt') THEN JREL = 'LT' ELSE IF (LREL.EQ.'gt') THEN JREL = 'GT' ELSE IF (LREL.EQ.'le') THEN JREL = 'LE' ELSE IF (LREL.EQ.'ge') THEN JREL = 'GE' ELSE FMCOMP = .FALSE. C DELETE START KFLAG = -4 IF (NCALL.NE.1 .OR. KWARN.LE.0) GO TO 170 C DELETE STOP IF (KWARN.LE.0) GO TO 170 WRITE (KW,130) LREL 130 FORMAT(/' 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.'/) IF (KWARN.GE.2) THEN STOP ENDIF GO TO 170 ENDIF ENDIF C IF (MA(1).EQ.MUNKNO .OR. MB(1).EQ.MUNKNO) THEN FMCOMP = .FALSE. C DELETE START KFLAG = -4 C DELETE STOP GO TO 170 ENDIF C IF (ABS(MA(1)).EQ.MEXPOV .AND. MA(1).EQ.MB(1) .AND. * MA(2).EQ.MB(2)) THEN FMCOMP = .FALSE. C DELETE START KFLAG = -4 IF (NCALL.NE.1 .OR. KWARN.LE.0) GO TO 170 C DELETE STOP IF (KWARN.LE.0) GO TO 170 WRITE (KW,140) 140 FORMAT(/' 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.GE.2) THEN STOP ENDIF GO TO 170 ENDIF C C Check for zero. C C DELETE START KFLAG = 0 C DELETE STOP IF (MA(2).EQ.0) THEN JCOMP = 2 IF (MB(2).LT.0) JCOMP = 1 IF (MB(2).GT.0) JCOMP = 3 GO TO 160 ENDIF IF (MB(2).EQ.0) THEN JCOMP = 1 IF (MA(2).LT.0) JCOMP = 3 GO TO 160 ENDIF C Check for opposite signs. C IF (MA(2).GT.0 .AND. MB(2).LT.0) THEN JCOMP = 1 GO TO 160 ENDIF IF (MB(2).GT.0 .AND. MA(2).LT.0) THEN JCOMP = 3 GO TO 160 ENDIF C C See which one is larger in absolute value. C IF (MA(1).GT.MB(1)) THEN JCOMP = 1 GO TO 160 ENDIF IF (MB(1).GT.MA(1)) THEN JCOMP = 3 GO TO 160 ENDIF NLAST = NDIG + 1 C DO 150 J = 2, NLAST IF (ABS(MA(J)).GT.ABS(MB(J))) THEN JCOMP = 1 GO TO 160 ENDIF IF (ABS(MB(J)).GT.ABS(MA(J))) THEN JCOMP = 3 GO TO 160 ENDIF 150 CONTINUE C JCOMP = 2 C C Now match the JCOMP value to the requested comparison. C 160 IF (JCOMP.EQ.1 .AND. MA(2).LT.0) THEN JCOMP = 3 ELSE IF (JCOMP.EQ.3 .AND. MB(2).LT.0) THEN JCOMP = 1 ENDIF C FMCOMP = .FALSE. IF (JCOMP.EQ.1 .AND. (JREL.EQ.'GT' .OR. JREL.EQ.'GE' .OR. * JREL.EQ.'NE')) FMCOMP = .TRUE. C IF (JCOMP.EQ.2 .AND. (JREL.EQ.'EQ' .OR. JREL.EQ.'GE' .OR. * JREL.EQ.'LE')) FMCOMP = .TRUE. C IF (JCOMP.EQ.3 .AND. (JREL.EQ.'NE' .OR. JREL.EQ.'LT' .OR. * JREL.EQ.'LE')) FMCOMP = .TRUE. C 170 CONTINUE C DELETE START IF (NTRACE.NE.0) THEN IF (NCALL.LE.LVLTRC .AND. ABS(NTRACE).GE.1) THEN IF (KFLAG.EQ.0) THEN WRITE (KW,180) NCALL,INT(MBASE),NDIG 180 FORMAT(' FMCOMP',15X,'Call level =',I2,5X,'MBASE =', * I10,5X,'NDIG =',I6) ELSE WRITE (KW,190) NCALL,INT(MBASE),NDIG,KFLAG 190 FORMAT(' FMCOMP',6X,'Call level =',I2,4X,'MBASE =', * I10,4X,'NDIG =',I6,4X,'KFLAG =',I3) ENDIF IF (FMCOMP) THEN WRITE (KW,200) 200 FORMAT(7X,'.TRUE.') ELSE WRITE (KW,210) 210 FORMAT(7X,'.FALSE.') ENDIF ENDIF ENDIF NCALL = NCALL - 1 C DELETE STOP RETURN END SUBROUTINE FMCONS C C Set several saved machine precision constants. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2 + 1 , LUNPCK = (6*NDIGMX)/5 + 20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000 + 6 ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C 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) MEXPAB = DINT(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 C RETURN END SUBROUTINE FMCOS(MA,MB) C C MB = COS(MA) C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during FMCOS: M01 - M04 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCA,MACMAX,MXSAVE INTEGER JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,NDSAVE,NDSV C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (ABS(MA(1)).GT.MEXPAB .OR. MA(2).EQ.0) THEN CALL FMENTR('FMCOS ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMCOS ' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MA,1) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF C MACCA = MA(0) CALL FMEQ2(MA,MB,NDSAVE,NDIG,0) MB(0) = NINT(NDIG*ALOGM2) MB(2) = ABS(MB(2)) C C Reduce the argument, convert to radians if the input is C in degrees, and evaluate the function. C CALL FMRDC(MB,MB,JSIN,JCOS,JSWAP) IF (MB(1).EQ.MUNKNO) GO TO 110 IF (KRAD.EQ.0) THEN IF (MBSPI.NE.MBASE .OR. NDIGPI.LT.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).NE.MUNKNO) THEN IF (JSWAP.EQ.0) THEN CALL FMCOS2(MB,MB) ELSE IF (MB(1).LT.0 .OR. NDIG.LE.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 C C Append the sign, round, and return. C IF (MB(1).NE.MUNKNO .AND. JCOS.EQ.-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 FMCOS2(MA,MB) C C Internal subroutine for MB = COS(MA) where 0.LE.MA.LE.1. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMCOS2: M01 - M04 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C DOUBLE PRECISION MJSUMS C COMMON /FMSUMS/ MJSUMS(0:LJSUMS) C C LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent C sums. Increasing this value will begin to improve the C speed of COS when the base is large and precision exceeds C about 1,500 decimal digits. C 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 C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (MA(2).EQ.0) THEN CALL FMI2M(1,MB) RETURN ENDIF NDSAVE = NDIG KWRNSV = KWARN KWARN = 0 C C Use the direct series C COS(X) = 1 - X**2/2! + X**4/4! - ... C C The argument will be divided by 2**K2 before the series C is summed. The series will be added as J2 concurrent C series. The approximately optimal values of K2 and J2 C are now computed to try to minimize the time required. C N2/2 is the approximate number of terms of the series C that will be needed, and L2 guard digits will be carried. C C Since X is small when the series is summed, COS(X) - 1 C is computed. Then a version of the recovery formula can C be used that does not suffer from severe cancellation. C 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) C L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B + * REAL(MA(3))/(B*B)))/ALOG2 - 0.3) K2 = K2 - L IF (L.LT.0) L = 0 IF (K2.LT.0) THEN K2 = 0 J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) + .33) ENDIF IF (J2.LE.1) J2 = 1 C N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) L2 = INT(LOG(REAL(N2)+2.0**K2)/ALOGMB) NDIG = NDIG + L2 IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) DO 110 J = 2, NDSAVE MB(J+1) = 0 110 CONTINUE NDIG = NDSAVE KWARN = KWRNSV RETURN ENDIF NDSAV1 = NDIG C C Divide the argument by 2**K2. C CALL FMEQ2(MA,M02,NDSAVE,NDIG,0) KTWO = 1 MAXVAL = MXBASE/2 IF (K2.GT.0) THEN DO 120 J = 1, K2 KTWO = 2*KTWO IF (KTWO.GT.MAXVAL) THEN CALL FMDIVI(M02,KTWO,M02) KTWO = 1 ENDIF 120 CONTINUE IF (KTWO.GT.1) CALL FMDIVI(M02,KTWO,M02) ENDIF C C Split into J2 concurrent sums and reduce NDIG while C computing each term in the sum as the terms get smaller. C CALL FMSQR(M02,M02) CALL FMEQ(M02,M03) M03(2) = -M03(2) NTERM = 2 DO 130 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) 130 CONTINUE IF (M02(1).LT.-NDIG) GO TO 160 CALL FMIPWR(M02,J2,MB) C 140 CALL FMMPY(M03,MB,M03) LARGE = INT(INTMAX/NTERM) DO 150 J = 1, J2 NBOT = NTERM*(NTERM-1) IF (NTERM.GT.LARGE .OR. NBOT.GT.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.NE.0) GO TO 160 NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1)) IF (NDIG.LT.2) NDIG = 2 M03(2) = -M03(2) NTERM = NTERM + 2 150 CONTINUE GO TO 140 C C Next put the J2 separate sums back together. C 160 KFLAG = 0 KPT = (J2-1)*(NDIG+2) CALL FMEQ(MJSUMS(KPT),MB) IF (J2.GE.2) THEN DO 170 J = 2, J2 CALL FMMPY(M02,MB,MB) KPT = (J2-J)*(NDIG+2) CALL FMADD(MB,MJSUMS(KPT),MB) 170 CONTINUE ENDIF C C Reverse the effect of reducing the argument to C compute COS(MA). C NDIG = NDSAV1 IF (K2.GT.0) THEN IF (NDSAVE.LE.20) THEN CALL FMI2M(2,M02) DO 180 J = 1, K2 CALL FMADD(MB,M02,M03) CALL FMMPY(MB,M03,M03) CALL FMADD(M03,M03,MB) 180 CONTINUE ELSE DO 190 J = 1, K2 CALL FMSQR(MB,M03) CALL FMADD(MB,MB,M02) CALL FMADD(M03,M02,M03) CALL FMADD(M03,M03,MB) 190 CONTINUE ENDIF ENDIF CALL FMI2M(1,M03) CALL FMADD(M03,MB,MB) C CALL FMEQ2(MB,MB,NDSAV1,NDSAVE,1) NDIG = NDSAVE KWARN = KWRNSV C RETURN END SUBROUTINE FMCOSH(MA,MB) C C MB = COSH(MA) C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during FMCOSH: M01 - M03 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCA,MACMAX,MXSAVE INTEGER K,KASAVE,KOVUN,KRESLT,NDSAVE,NMETHD C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (ABS(MA(1)).GT.MEXPAB) THEN CALL FMENTR('FMCOSH',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMCOSH' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MA,1) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF C MACCA = MA(0) CALL FMEQ2(MA,MB,NDSAVE,NDIG,0) MB(0) = NINT(NDIG*ALOGM2) MB(2) = ABS(MB(2)) IF (MA(2).EQ.0) THEN CALL FMI2M(1,MB) GO TO 120 ENDIF C C Use a series for small arguments, FMEXP for large ones. C IF (MB(1).EQ.MUNKNO) GO TO 120 IF (MBASE.GT.99) THEN IF (MB(1).LE.0) THEN NMETHD = 1 ELSE IF (MB(1).GE.2) THEN NMETHD = 2 ELSE IF (ABS(MB(2)).LT.10) THEN NMETHD = 1 ELSE NMETHD = 2 ENDIF ELSE IF (MB(1).LE.0) THEN NMETHD = 1 ELSE NMETHD = 2 ENDIF ENDIF C IF (NMETHD.EQ.2) GO TO 110 CALL FMCSH2(MB,MB) GO TO 120 C 110 CALL FMEXP(MB,MB) IF (MB(1).EQ.MEXPOV) THEN GO TO 120 ELSE IF (MB(1).EQ.MEXPUN) THEN MB(1) = MEXPOV GO TO 120 ENDIF IF (INT(MB(1)).LE.(NDIG+1)/2) THEN CALL FMI2M(1,M01) CALL FMDIV(M01,MB,M01) CALL FMADD(MB,M01,MB) ENDIF CALL FMDIVI(MB,2,MB) C C Round and return. C 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 FMCSH2(MA,MB) C C Internal subroutine for MB = COSH(MA). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMCSH2: M01 - M03 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C DOUBLE PRECISION MJSUMS C COMMON /FMSUMS/ MJSUMS(0:LJSUMS) C C LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent C sums. Increasing this value will begin to improve the C speed of COSH when the base is large and precision exceeds C about 1,500 decimal digits. C 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 C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (MA(2).EQ.0) THEN CALL FMI2M(1,MB) RETURN ENDIF NDSAVE = NDIG KWRNSV = KWARN KWARN = 0 C C Use the direct series C COSH(X) = 1 + X**2/2! + X**4/4! - ... C C The argument will be divided by 2**K2 before the series C is summed. The series will be added as J2 concurrent C series. The approximately optimal values of K2 and J2 C are now computed to try to minimize the time required. C N2/2 is the approximate number of terms of the series C that will be needed, and L2 guard digits will be carried. C C Since X is small when the series is summed, COSH(X) - 1 C is computed. Then a version of the recovery formula can C be used that does not suffer from severe cancellation. C 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) C L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B + * REAL(MA(3))/(B*B)))/ALOG2 - 0.3) K2 = K2 - L IF (L.LT.0) L = 0 IF (K2.LT.0) THEN K2 = 0 J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) + .33) ENDIF IF (J2.LE.1) J2 = 1 C N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) L2 = INT(LOG(REAL(N2)+2.0**K2)/ALOGMB) NDIG = NDIG + L2 IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) DO 110 J = 2, NDSAVE MB(J+1) = 0 110 CONTINUE NDIG = NDSAVE KWARN = KWRNSV RETURN ENDIF NDSAV1 = NDIG CALL FMEQ2(MA,M02,NDSAVE,NDIG,0) C C Divide the argument by 2**K2. C KTWO = 1 MAXVAL = MXBASE/2 IF (K2.GT.0) THEN DO 120 J = 1, K2 KTWO = 2*KTWO IF (KTWO.GT.MAXVAL) THEN CALL FMDIVI(M02,KTWO,M02) KTWO = 1 ENDIF 120 CONTINUE IF (KTWO.GT.1) CALL FMDIVI(M02,KTWO,M02) ENDIF C C Split into J2 concurrent sums and reduce NDIG while C computing each term in the sum as the terms get smaller. C CALL FMSQR(M02,M02) CALL FMEQ(M02,M03) NTERM = 2 DO 130 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)) 130 CONTINUE IF (M02(1).LT.-NDIG) GO TO 160 CALL FMIPWR(M02,J2,MB) C 140 CALL FMMPY(M03,MB,M03) LARGE = INT(INTMAX/NTERM) DO 150 J = 1, J2 NBOT = NTERM*(NTERM-1) IF (NTERM.GT.LARGE .OR. NBOT.GT.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.NE.0) GO TO 160 NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1)) IF (NDIG.LT.2) NDIG = 2 NTERM = NTERM + 2 150 CONTINUE GO TO 140 C C Next put the J2 separate sums back together. C 160 KFLAG = 0 KPT = (J2-1)*(NDIG+2) CALL FMEQ(MJSUMS(KPT),MB) IF (J2.GE.2) THEN DO 170 J = 2, J2 CALL FMMPY(M02,MB,MB) KPT = (J2-J)*(NDIG+2) CALL FMADD(MB,MJSUMS(KPT),MB) 170 CONTINUE ENDIF C C Reverse the effect of reducing the argument to C compute COSH(MA). C NDIG = NDSAV1 IF (K2.GT.0) THEN IF (NDSAVE.LE.20) THEN CALL FMI2M(2,M02) DO 180 J = 1, K2 CALL FMADD(MB,M02,M03) CALL FMMPY(MB,M03,M03) CALL FMADD(M03,M03,MB) 180 CONTINUE ELSE DO 190 J = 1, K2 CALL FMSQR(MB,M03) CALL FMADD(MB,MB,M02) CALL FMADD(M03,M02,M03) CALL FMADD(M03,M03,MB) 190 CONTINUE ENDIF ENDIF CALL FMI2M(1,M03) CALL FMADD(M03,MB,MB) C CALL FMEQ2(MB,MB,NDSAV1,NDSAVE,1) NDIG = NDSAVE KWARN = KWRNSV C RETURN END SUBROUTINE FMCSSN(MA,MB,MC) C C MB = COS(MA), MC = SIN(MA) C C If both the sine and cosine are needed, this routine is faster C than calling both FMCOS and FMSIN. C C MB and MC must be distinct arrays. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during FMCSSN: M01 - M05 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MA2,MACCA,MACMAX,MXSAVE INTEGER JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,KWRNSV,NCSAVE, * NDSAVE,NDSV C IF (MBLOGS.NE.MBASE) CALL FMCONS MACCA = MA(0) MA2 = MA(2) IF (ABS(MA(1)).GT.MEXPAB .OR. MA(2).EQ.0) THEN NCSAVE = NCALL CALL FMENTR('FMCSSN',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (MA(1).EQ.MUNKNO) KOVUN = 2 NCALL = NCSAVE + 1 CALL FMEQ(MA,M05) 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.NE.0) CALL FMNTR(2,MA,MA,1) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.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 C IF (MA(2).EQ.0) THEN CALL FMI2M(1,MB) CALL FMI2M(0,MC) GO TO 110 ENDIF C CALL FMEQ2(MA,MB,NDSAVE,NDIG,0) MB(0) = NINT(NDIG*ALOGM2) MB(2) = ABS(MB(2)) C C Reduce the argument, convert to radians if the input is C in degrees, and evaluate the functions. C CALL FMRDC(MB,MB,JSIN,JCOS,JSWAP) IF (MB(1).EQ.MUNKNO) THEN CALL FMEQ(MB,MC) GO TO 110 ENDIF IF (KRAD.EQ.0) THEN IF (MBSPI.NE.MBASE .OR. NDIGPI.LT.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).NE.MUNKNO) THEN IF (JSWAP.EQ.0) THEN IF (MB(1).LT.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).LT.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 C C Round and return. C 110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315) MC(0) = MIN(MC(0),MACCA,MACMAX) IF (MA2.LT.0 .AND. MC(1).NE.MUNKNO) MC(2) = -MC(2) CALL FMEQ2(MC,MC,NDIG,NDSAVE,1) MB(0) = MIN(MB(0),MACCA,MACMAX) IF (KOVUN.EQ.2) THEN KWRNSV = KWARN KWARN = 0 ENDIF CALL FMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) IF (KOVUN.EQ.2) THEN KWARN = KWRNSV ENDIF IF (NTRACE.NE.0) THEN IF (ABS(NTRACE).GE.1 .AND. NCALL+1.LE.LVLTRC) THEN IF (NTRACE.LT.0) THEN CALL FMNTRJ(MC,NDIG) ELSE CALL FMPRNT(MC) ENDIF ENDIF ENDIF RETURN END SUBROUTINE FMDBL(A,B,C) C C C = A + B. All are double precision. This routine tries to C force the compiler to round C to double precision accuracy. C Some compilers allow double precision loops like the ones in C FMSET and FMDM to be done in extended precision, which defeats C the routine's attempt to determine double precision accuracy. C This can lead to doing too few Newton steps and failing to C get sufficient accuracy in several FM routines. C DOUBLE PRECISION A,B,C C = A + B RETURN END SUBROUTINE FMDIG(NSTACK,KST) C C Compute the number of intermediate digits to be used in Newton C iteration. This assumes that a starting approximation that is C accurate to double precision is used, and the root is simple. C C KST is the number of iterations needed for final accuracy NDIG. C NSTACK(J) holds the value of NDIG to be used for the C Jth iteration. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C INTEGER NSTACK(19),KST C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C DOUBLE PRECISION Y INTEGER J,JT,L,ND,NDT,NE C IF (MBLOGS.NE.MBASE) CALL FMCONS C C NE is the maximum number of base MBASE digits that C can be used in the first Newton iteration. C NE = INT(1.9D0*DLOGEB) C C Fill the intermediate digit stack (backwards). C KST = 1 ND = NDIG NSTACK(1) = ND IF (ND.LT.NE .OR. ND.LE.2) RETURN C 110 Y = ND C C The 1.9 accounts for the fact that the number of correct C digits approximately doubles at each iteration. C NDT = INT(Y/1.9D0) IF (2*NDT.LE.ND) NDT = NDT + 1 ND = NDT KST = KST + 1 NSTACK(KST) = ND IF (ND.GT.NE .AND. ND.GT.2) GO TO 110 C C Reverse the stack. C L = KST/2 DO 120 J = 1, L JT = NSTACK(J) NSTACK(J) = NSTACK(KST+1-J) NSTACK(KST+1-J) = JT 120 CONTINUE C RETURN END SUBROUTINE FMDIM(MA,MB,MC) C C MC = DIM(MA,MB) C C Positive difference. MC = MA - MB if MA.GE.MB, C = 0 otherwise. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMDIM: M01 - M02 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCA,MACCB,MACMAX,MXSAVE INTEGER K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE LOGICAL FMCOMP C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MB(1)).GT.MEXPAB) THEN CALL FMENTR('FMDIM ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMDIM ' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MB,2) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 IF (MB(1).EQ.MEXPOV .OR. MB(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MB,MC,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF KWRNSV = KWARN KWARN = 0 MXEXP = MXSAVE C 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) C IF (FMCOMP(M01,'LT',M02)) THEN CALL FMI2M(0,MC) ELSE CALL FMSUB(M01,M02,MC) ENDIF C IF (KFLAG.EQ.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 FMDIV(MA,MB,MC) C C MC = MA / MB C C This routine performs the trace printing for division. C FMDIV2 is used to do the arithmetic. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'FMDIV ' CALL FMNTR(2,MA,MB,2) C CALL FMDIV2(MA,MB,MC) C CALL FMNTR(1,MC,MC,1) ELSE CALL FMDIV2(MA,MB,MC) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMDIV2(MA,MB,MC) C C Internal division routine. MC = MA / MB C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION XB,XBR,XBASE,XMWA DOUBLE PRECISION MA2,MA2P,MACCA,MACCB,MAXMWA,MB1,MB2,MB2P, * MBM1,MCARRY,MD2B,MKT,MLMAX,MLR,MQD INTEGER J,JB,JL,KA,KB,KL,KPTMWA,KRESLT,N1,NG,NGUARD, * NL,NMBWDS,NZDMB C IF (MBLOGS.NE.MBASE) CALL FMCONS MACCA = MA(0) MACCB = MB(0) IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MB(1)).GT.MEXPAB .OR. * KDEBUG.EQ.1) THEN CALL FMARGS('FMDIV ',2,MA,MB,KRESLT) IF (KRESLT.NE.0) THEN NCALL = NCALL + 1 NAMEST(NCALL) = 'FMDIV ' CALL FMRSLT(MA,MB,MC,KRESLT) NCALL = NCALL - 1 RETURN ENDIF ELSE IF (MB(2).EQ.0) THEN CALL FMIM(0,MC) MC(1) = MUNKNO MC(2) = 1 MC(0) = NINT(NDIG*ALOGM2) NAMEST(NCALL) = 'FMDIV ' KFLAG = -4 CALL FMWARN RETURN ENDIF IF (MA(2).EQ.0) THEN CALL FMIM(0,MC) MC(0) = MIN(MACCA,MACCB) RETURN ENDIF ENDIF KFLAG = 0 C C NGUARD is the number of guard digits used. C IF (NCALL.GT.1) THEN NGUARD = NGRD21 IF (NGUARD.GT.NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 - 1 ENDIF MA2P = ABS(MA(2)) MB2P = ABS(MB(2)) N1 = NDIG + 1 NG = NDIG + NGUARD C C Copy MA into the working array. C DO 110 J = 3, N1 MWA(J+1) = MA(J) 110 CONTINUE MWA(1) = MA(1) - MB(1) + 1 MWA(2) = 0 NL = N1 + NGUARD + 3 DO 120 J = NDIG+3, NL MWA(J) = 0 120 CONTINUE C C Save the sign of MA and MB and then work only with C positive numbers. C MA2 = MA(2) MB1 = MB(1) MB2 = MB(2) MA(2) = MA2P MWA(3) = MA(2) MB(1) = 0 MB(2) = MB2P C C NMBWDS is the number of words of MB used to C compute the estimated quotient digit MQD. C NMBWDS = 4 IF (MBASE.LT.100) NMBWDS = 7 C C XB is an approximation of MB used in C estimating the quotient digits. C XBASE = DBLE(MBASE) XB = 0 JL = NMBWDS IF (JL.LE.N1) THEN DO 130 J = 2, JL XB = XB*XBASE + DBLE(MB(J)) 130 CONTINUE ELSE DO 140 J = 2, JL IF (J.LE.N1) THEN XB = XB*XBASE + DBLE(MB(J)) ELSE XB = XB*XBASE ENDIF 140 CONTINUE ENDIF IF (JL+1.LE.N1) XB = XB + DBLE(MB(JL+1))/XBASE XBR = 1.0D0/XB C C MLMAX determines when to normalize all of MWA. C MBM1 = MBASE - 1 MLMAX = MAXINT/MBM1 MKT = INTMAX - MBASE MLMAX = MIN(MLMAX,MKT) C C Count the trailing zero digits of MB. C DO 150 J = N1, 2, -1 IF (MB(J).NE.0) THEN NZDMB = N1 - J GO TO 160 ENDIF 150 CONTINUE C C MAXMWA is an upper bound on the size of values in MWA C divided by MBASE-1. It is used to determine whether C normalization can be postponed. C 160 MAXMWA = 0 C C KPTMWA points to the next digit in the quotient. C KPTMWA = 2 C C This is the start of the division loop. C C XMWA is an approximation of the active part of MWA C used in estimating quotient digits. C 170 KL = KPTMWA + NMBWDS - 1 IF (KL.LE.NL) THEN XMWA = ((DBLE(MWA(KPTMWA))*XBASE * + DBLE(MWA(KPTMWA+1)))*XBASE * + DBLE(MWA(KPTMWA+2)))*XBASE * + DBLE(MWA(KPTMWA+3)) DO 180 J = KPTMWA+4, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) 180 CONTINUE ELSE XMWA = DBLE(MWA(KPTMWA)) DO 190 J = KPTMWA+1, KL IF (J.LE.NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) ELSE XMWA = XMWA*XBASE ENDIF 190 CONTINUE ENDIF C C MQD is the estimated quotient digit. C MQD = DINT (XMWA*XBR) IF (MQD.LT.0) MQD = MQD - 1 C IF (MQD.GT.0) THEN MAXMWA = MAXMWA + MQD ELSE MAXMWA = MAXMWA - MQD ENDIF C C See if MWA must be normalized. C KA = KPTMWA + 1 KB = MIN(KA+NDIG-1-NZDMB,NL) IF (MAXMWA.GE.MLMAX) THEN DO 200 J = KB, KA, -1 IF (MWA(J).LT.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).GE.MBASE) THEN MCARRY = -INT(MWA(J)/MBASE) MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ENDIF 200 CONTINUE XMWA = 0 IF (KL.LE.NL) THEN DO 210 J = KPTMWA, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) 210 CONTINUE ELSE DO 220 J = KPTMWA, KL IF (J.LE.NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) ELSE XMWA = XMWA*XBASE ENDIF 220 CONTINUE ENDIF MQD = DINT (XMWA*XBR) IF (MQD.LT.0) MQD = MQD - 1 IF (MQD.GT.0) THEN MAXMWA = MQD ELSE MAXMWA = -MQD ENDIF ENDIF C C Subtract MQD*MB from MWA. C JB = KA - 2 IF (MQD.NE.0) THEN C C Major (Inner Loop) C DO 230 J = KA, KB MWA(J) = MWA(J) - MQD*MB(J-JB) 230 CONTINUE ENDIF C MWA(KA) = MWA(KA) + MWA(KA-1)*MBASE MWA(KPTMWA) = MQD C KPTMWA = KPTMWA + 1 IF (KPTMWA.LE.NG) GO TO 170 IF (MWA(2).EQ.0 .AND. KPTMWA.LE.NG+1) GO TO 170 C KL = KPTMWA + NMBWDS - 1 IF (KL.LE.NL) THEN XMWA = ((DBLE(MWA(KPTMWA))*XBASE * + DBLE(MWA(KPTMWA+1)))*XBASE * + DBLE(MWA(KPTMWA+2)))*XBASE * + DBLE(MWA(KPTMWA+3)) DO 240 J = KPTMWA+4, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) 240 CONTINUE ELSE XMWA = DBLE(MWA(KPTMWA)) DO 250 J = KPTMWA+1, KL IF (J.LE.NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) ELSE XMWA = XMWA*XBASE ENDIF 250 CONTINUE ENDIF MQD = DINT (XMWA*XBR) IF (MQD.LT.0) MQD = MQD - 1 MWA(KPTMWA) = MQD MWA(KPTMWA+1) = 0 MWA(KPTMWA+2) = 0 C C Final normalization. C DO 260 J = KPTMWA, 3, -1 IF (MWA(J).LT.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).GE.MBASE) THEN MCARRY = -INT(MWA(J)/MBASE) MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ENDIF 260 CONTINUE C C Round, affix the sign, and return. C MA(2) = MA2 MB(1) = MB1 MB(2) = MB2 IF (MWA(2).EQ.0) THEN MLR = 2*MWA(NDIG+3) + 1 IF (MLR.GE.MBASE) THEN IF (MLR-1.GT.MBASE .AND. MWA(N1+1).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.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 (MLR.GE.MBASE) THEN IF (MLR-1.GT.MBASE .AND. MWA(N1).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.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) C IF (KFLAG.LT.0) THEN NAMEST(NCALL) = 'FMDIV ' CALL FMWARN ENDIF C IF (MA2*MB2.LT.0) MC(2) = -MC(2) C IF (KACCSW.EQ.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 RETURN END SUBROUTINE FMDIVD(MA,MB,MC,MD,ME) C C Double division routine. MD = MA / MC, ME = MB / MC C C It is usually slightly faster to do two divisions that C have a common denominator with one call. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK), * MD(0:LUNPCK),ME(0:LUNPCK) C DOUBLE PRECISION MWD,MWE C COMMON /FMWA/ MWD(LMWA),MWE(LMWA) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C 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,KA,KB,KL,KOVUN,KPTMW,N1,NG,NGUARD,NL,NMBWDS,NZDMB C NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'FMDIVD' CALL FMNTR(2,MA,MB,2) IF (ABS(NTRACE).GE.2 .AND. NCALL.LE.LVLTRC) THEN IF (NTRACE.LT.0) THEN CALL FMNTRJ(MC,NDIG) ELSE CALL FMPRNT(MC) ENDIF ENDIF ENDIF C IF (MBLOGS.NE.MBASE) CALL FMCONS MACCA = MA(0) MACCB = MB(0) MACCC = MC(0) IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MB(1)).GT.MEXPAB .OR. * ABS(MC(1)).GT.MEXPAB) THEN KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN .OR. * MB(1).EQ.MEXPOV .OR. MB(1).EQ.MEXPUN .OR. * MC(1).EQ.MEXPOV .OR. MC(1).EQ.MEXPUN) KOVUN = 1 IF (MA(1).EQ.MUNKNO .OR. MB(1).EQ.MUNKNO .OR. * MC(1).EQ.MUNKNO) KOVUN = 2 NCALL = NCALL + 1 CALL FMDIV2(MA,MC,MWD) KB = KFLAG CALL FMDIV2(MB,MC,ME) NCALL = NCALL - 1 IF (((KFLAG.LT.0 .OR. KB.LT.0) .AND. KOVUN.EQ.0) .OR. * ((KFLAG.EQ.-4 .OR. KB.EQ.-4) .AND. KOVUN.EQ.1)) THEN IF (KFLAG.EQ.-4 .OR. KB.EQ.-4) THEN KFLAG = -4 ELSE IF (KFLAG.EQ.-5 .OR. KB.EQ.-5) THEN KFLAG = -5 ELSE KFLAG = MIN(KFLAG,KB) ENDIF NAMEST(NCALL) = 'FMDIVD' CALL FMWARN ENDIF CALL FMEQ(MWD,MD) GO TO 270 ENDIF IF (MC(2).EQ.0) THEN CALL FMIM(0,MD) MD(1) = MUNKNO MD(2) = 1 MD(0) = NINT(NDIG*ALOGM2) CALL FMIM(0,ME) ME(1) = MUNKNO ME(2) = 1 ME(0) = NINT(NDIG*ALOGM2) NAMEST(NCALL) = 'FMDIVD' KFLAG = -4 CALL FMWARN GO TO 270 ENDIF IF (MA(2).EQ.0 .OR. MB(2).EQ.0) THEN CALL FMDIV2(MA,MC,MWD) CALL FMDIV2(MB,MC,ME) CALL FMEQ(MWD,MD) GO TO 270 ENDIF KFLAG = 0 C C NGUARD is the number of guard digits used. C IF (NCALL.GT.1) THEN NGUARD = NGRD21 IF (NGUARD.GT.NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 - 1 ENDIF MA2P = ABS(MA(2)) MB2P = ABS(MB(2)) MC2P = ABS(MC(2)) IF ((MC2P.GE.MA2P .OR. MC2P.GE.MB2P) .AND. NGUARD.LT.2) NGUARD = 2 N1 = NDIG + 1 NG = NDIG + NGUARD C C Copy MA and MB into the working arrays. C DO 110 J = 3, N1 MWA(J+1) = MA(J) MWD(J+1) = MB(J) 110 CONTINUE 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 120 J = NDIG+3, NL MWA(J) = 0 MWD(J) = 0 120 CONTINUE C C Save the signs and then work only with C positive numbers. C 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 C C NMBWDS is the number of words used to compute C the estimated quotient digits. C NMBWDS = 4 IF (MBASE.LT.100) NMBWDS = 7 C C XB is an approximation of MC used in selecting C estimated quotients. C XBASE = DBLE(MBASE) XB = 0 JL = NMBWDS IF (JL.LE.N1) THEN DO 130 J = 2, JL XB = XB*XBASE + DBLE(MC(J)) 130 CONTINUE ELSE DO 140 J = 2, JL IF (J.LE.N1) THEN XB = XB*XBASE + DBLE(MC(J)) ELSE XB = XB*XBASE ENDIF 140 CONTINUE ENDIF IF (JL+1.LE.N1) XB = XB + DBLE(MC(JL+1))/XBASE XBR = 1.0D0/XB C C MLMAX determines when to normalize all of MWA. C MBM1 = MBASE - 1 MLMAX = MAXINT/MBM1 MKT = INTMAX - MBASE MLMAX = MIN(MLMAX,MKT) C C Count the trailing zero digits of MC. C DO 150 J = N1, 2, -1 IF (MC(J).NE.0) THEN NZDMB = N1 - J GO TO 160 ENDIF 150 CONTINUE C C MAXMWA is an upper bound on the size of values in MWA C divided by MBASE-1. It is used to determine whether C normalization can be postponed. C 160 MAXMWA = 0 C C KPTMW points to the next digit in the quotient. C KPTMW = 2 C C This is the start of the division loop. C C XMWA is an approximation of the active part of MWA C used in selecting estimated quotients. C 170 KL = KPTMW + NMBWDS - 1 IF (KL.LE.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 180 J = KPTMW+4, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) XMWD = XMWD*XBASE + DBLE(MWD(J)) 180 CONTINUE ELSE XMWA = DBLE(MWA(KPTMW)) XMWD = DBLE(MWD(KPTMW)) DO 190 J = KPTMW+1, KL IF (J.LE.NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) XMWD = XMWD*XBASE + DBLE(MWD(J)) ELSE XMWA = XMWA*XBASE XMWD = XMWD*XBASE ENDIF 190 CONTINUE ENDIF C C MQDMWA and MQDMWD are the estimated quotient digits. C MQDMWA = DINT (XMWA*XBR) IF (MQDMWA.LT.0) MQDMWA = MQDMWA - 1 MQDMWD = DINT (XMWD*XBR) IF (MQDMWD.LT.0) MQDMWD = MQDMWD - 1 C MAXMWA = MAXMWA + MAX(ABS(MQDMWA),ABS(MQDMWD)) C C See if MWA and MWD must be normalized. C KA = KPTMW + 1 KB = MIN(KA+NDIG-1-NZDMB,NL) IF (MAXMWA.GE.MLMAX) THEN DO 200 J = KB, KA, -1 IF (MWA(J).LT.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).GE.MBASE) THEN MCARRY = -INT(MWA(J)/MBASE) MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ENDIF IF (MWD(J).LT.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).GE.MBASE) THEN MCARRY = -INT(MWD(J)/MBASE) MWD(J) = MWD(J) + MCARRY*MBASE MWD(J-1) = MWD(J-1) - MCARRY ENDIF 200 CONTINUE XMWA = 0 XMWD = 0 IF (KL.LE.NL) THEN DO 210 J = KPTMW, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) XMWD = XMWD*XBASE + DBLE(MWD(J)) 210 CONTINUE ELSE DO 220 J = KPTMW, KL IF (J.LE.NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) XMWD = XMWD*XBASE + DBLE(MWD(J)) ELSE XMWA = XMWA*XBASE XMWD = XMWD*XBASE ENDIF 220 CONTINUE ENDIF MQDMWA = DINT (XMWA*XBR) IF (MQDMWA.LT.0) MQDMWA = MQDMWA - 1 MQDMWD = DINT (XMWD*XBR) IF (MQDMWD.LT.0) MQDMWD = MQDMWD - 1 MAXMWA = MAX(ABS(MQDMWA),ABS(MQDMWD)) ENDIF C C Subtract MQDMWA*MC from MWA and MQDMWD*MC from MWD. C JB = KA - 2 C C Major (Inner Loop) C DO 230 J = KA, KB MTEMP = MC(J-JB) MWA(J) = MWA(J) - MQDMWA*MTEMP MWD(J) = MWD(J) - MQDMWD*MTEMP 230 CONTINUE C MWA(KA) = MWA(KA) + MWA(KA-1)*MBASE MWD(KA) = MWD(KA) + MWD(KA-1)*MBASE MWA(KPTMW) = MQDMWA MWD(KPTMW) = MQDMWD C KPTMW = KPTMW + 1 IF (KPTMW.LE.NG) GO TO 170 C KL = KPTMW + NMBWDS - 1 IF (KL.LE.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 240 J = KPTMW+4, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) XMWD = XMWD*XBASE + DBLE(MWD(J)) 240 CONTINUE ELSE XMWA = DBLE(MWA(KPTMW)) XMWD = DBLE(MWD(KPTMW)) DO 250 J = KPTMW+1, KL IF (J.LE.NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) XMWD = XMWD*XBASE + DBLE(MWD(J)) ELSE XMWA = XMWA*XBASE XMWD = XMWD*XBASE ENDIF 250 CONTINUE ENDIF MQDMWA = DINT (XMWA*XBR) IF (MQDMWA.LT.0) MQDMWA = MQDMWA - 1 MQDMWD = DINT (XMWD*XBR) IF (MQDMWD.LT.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 C C Final normalization. C DO 260 J = KPTMW-1, 3, -1 IF (MWA(J).LT.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).GE.MBASE) THEN MCARRY = -INT(MWA(J)/MBASE) MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ENDIF IF (MWD(J).LT.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).GE.MBASE) THEN MCARRY = -INT(MWD(J)/MBASE) MWD(J) = MWD(J) + MCARRY*MBASE MWD(J-1) = MWD(J-1) - MCARRY ENDIF 260 CONTINUE C C Round, affix the sign, and return. C MA(2) = MA2 MB(2) = MB2 MC(1) = MC1 MC(2) = MC2 IF (MWA(2).EQ.0) THEN MLR = 2*MWA(NDIG+3) + 1 IF (MLR.GE.MBASE) THEN IF (MLR-1.GT.MBASE .AND. MWA(N1+1).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.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 (MLR.GE.MBASE) THEN IF (MLR-1.GT.MBASE .AND. MWA(N1).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.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) C IF (MWD(2).EQ.0) THEN MLR = 2*MWD(NDIG+3) + 1 IF (MLR.GE.MBASE) THEN IF (MLR-1.GT.MBASE .AND. MWD(N1+1).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.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 (MLR.GE.MBASE) THEN IF (MLR-1.GT.MBASE .AND. MWD(N1).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.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) C IF (KFLAG.LT.0) THEN NAMEST(NCALL) = 'FMDIVD' CALL FMWARN ENDIF C IF (MA2*MC2.LT.0) MD(2) = -MD(2) IF (MB2*MC2.LT.0) ME(2) = -ME(2) C IF (KACCSW.EQ.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 C 270 IF (NTRACE.NE.0) THEN CALL FMNTR(1,MD,MD,1) IF (ABS(NTRACE).GE.1 .AND. NCALL.LE.LVLTRC) THEN IF (NTRACE.LT.0) THEN CALL FMNTRJ(ME,NDIG) ELSE CALL FMPRNT(ME) ENDIF ENDIF ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMDIVI(MA,IVAL,MB) C C MB = MA / IVAL C C Divide FM number MA by one word integer IVAL. C C This routine is faster than FMDIV when the divisor is less than C MXBASE (the square root of the largest integer). C When IVAL is not less than MXBASE, FMDIV2 is used. In this case, C if IVAL is known to be a product of two integers less than C MXBASE, it is usually faster to make two calls to FMDIVI with C half-word factors than one call with their product. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) INTEGER IVAL C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMDIVI: M01 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCA,MD2B C KFLAG = 0 MACCA = MA(0) NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'FMDIVI' CALL FMNTR(2,MA,MA,1) CALL FMNTRI(2,IVAL,0) CALL FMDIVN(MA,IVAL,MB) IF (KACCSW.EQ.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) ELSE CALL FMDIVN(MA,IVAL,MB) IF (KACCSW.EQ.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 FMDIVN(MA,IVAL,MB) C C Internal divide by integer routine. MB = MA / IVAL C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) INTEGER IVAL C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMDIVN: M01 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MA1,MA2,MKT,MLR,MODINT,MVALP INTEGER J,KA,KB,KL,KPT,KPTWA,N1,NGUARD,NMVAL,NV2 C C Check for special cases. C IF (MBLOGS.NE.MBASE) CALL FMCONS N1 = NDIG + 1 IF (MA(1).EQ.MUNKNO .OR. IVAL.EQ.0) THEN MA1 = MA(1) CALL FMIM(0,MB) MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -4 IF (MA1.NE.MUNKNO) THEN NAMEST(NCALL) = 'FMDIVI' CALL FMWARN ENDIF RETURN ENDIF C IF (MA(2).EQ.0) THEN CALL FMEQ(MA,MB) RETURN ENDIF C IF (ABS(MA(1)).LT.MEXPOV .AND. ABS(IVAL).GT.1) GO TO 120 C IF (ABS(IVAL).EQ.1) THEN DO 110 J = 0, N1 MB(J) = MA(J) 110 CONTINUE MB(2) = MA(2)*IVAL IF (MA(1).EQ.MEXPOV) KFLAG = -5 IF (MA(1).EQ.MEXPUN) KFLAG = -6 RETURN ENDIF C IF (MA(1).EQ.MEXPUN) THEN MA2 = MA(2) CALL FMIM(0,MB) MB(1) = MEXPUN MB(2) = 1 IF ((MA2.LT.0 .AND. IVAL.GT.0) .OR. * (MA2.GT.0 .AND. IVAL.LT.0)) MB(2) = -1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -6 RETURN ENDIF C IF (MA(1).EQ.MEXPOV) THEN CALL FMIM(0,MB) MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) NAMEST(NCALL) = 'FMDIVI' KFLAG = -4 CALL FMWARN RETURN ENDIF C C NGUARD is the number of guard digits used. C 120 IF (NCALL.GT.1) THEN NGUARD = NGRD21 ELSE NGUARD = NGRD52 ENDIF C C If ABS(IVAL).GE.MXBASE use FMDIV. C MVALP = ABS(IVAL) NMVAL = INT(MVALP) NV2 = NMVAL - 1 IF (ABS(IVAL).GT.MXBASE .OR. NMVAL.NE.ABS(IVAL) .OR. * NV2.NE.ABS(IVAL)-1) THEN CALL FMIM(IVAL,M01) CALL FMDIV2(MA,M01,MB) RETURN ENDIF C C Work with positive numbers. C MA2 = MA(2) MA(2) = ABS(MA(2)) C C Find the first significant digit of the quotient. C MKT = MA(2) IF (MKT.GE.MVALP) THEN KPT = 2 GO TO 150 ENDIF DO 130 J = 3, N1 MKT = MKT*MBASE + MA(J) IF (MKT.GE.MVALP) THEN KPT = J GO TO 150 ENDIF 130 CONTINUE KPT = N1 C 140 KPT = KPT + 1 MKT = MKT*MBASE IF (MKT.LT.MVALP) GO TO 140 C C Do the rest of the division. C 150 KA = KPT + 1 MWA(1) = MA(1) + 2 - KPT MWA(2) = INT (MKT/MVALP) MODINT = MKT - MWA(2)*MVALP KPTWA = 2 IF (KA.LE.N1) THEN KL = 3 - KA C C (Inner Loop) C DO 160 J = KA, N1 MKT = MODINT*MBASE + MA(J) MWA(KL+J) = INT (MKT/MVALP) MODINT = MKT - MWA(KL+J)*MVALP 160 CONTINUE KPTWA = KL + N1 ENDIF C KA = KPTWA + 1 KB = N1 + NGUARD DO 170 J = KA, KB MKT = MODINT*MBASE MWA(J) = INT (MKT/MVALP) MODINT = MKT - MWA(J)*MVALP 170 CONTINUE C C Round the result, put the sign on MB and return. C MA(2) = MA2 MLR = 2*MWA(NDIG+2) + 1 IF (MLR.GE.MBASE) THEN IF (MLR-1.GT.MBASE .AND. MWA(N1).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.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) C IF (KFLAG.LT.0) THEN NAMEST(NCALL) = 'FMDIVI' CALL FMWARN ENDIF C IF ((MA2.LT.0 .AND. IVAL.GT.0) .OR. (MA2.GT.0 .AND. IVAL.LT.0)) * MB(2) = -MB(2) C RETURN END SUBROUTINE FMDM(X,MA) C C Internal routine for converting double precision to multiple C precision. Called by FMDPM. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION X DOUBLE PRECISION MA(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C DOUBLE PRECISION ONE,XBASE,Y,YT DOUBLE PRECISION MK,MN INTEGER J,K,N1,NE C IF (MBLOGS.NE.MBASE) CALL FMCONS KFLAG = 0 N1 = NDIG + 1 C ONE = 1.0D0 XBASE = MBASE K = 0 C C NE-1 is the number of words at the current precision and C base roughly equal to machine precision. C NE = INT(DLOGEB) + 3 Y = X IF (X.LT.0.0) Y = -X C IF (X.EQ.0.0) THEN DO 110 J = 1, N1 MA(J) = 0 110 CONTINUE GO TO 240 ENDIF C C Get the exponent. C IF (Y.GT.ONE) THEN IF (Y/XBASE.LT.Y) THEN 120 K = K + 1 Y = Y/XBASE IF (Y.GT.ONE) GO TO 120 IF (Y.LT.ONE) THEN MA(1) = K GO TO 180 ENDIF GO TO 160 ELSE DO 130 J = 1, NDIG+1 MA(J) = 0 130 CONTINUE MA(1) = MUNKNO MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) KFLAG = -4 CALL FMWARN RETURN ENDIF ENDIF C IF (Y.LT.ONE) THEN IF (Y*XBASE.GT.Y) THEN 140 K = K - 1 Y = Y*XBASE IF (Y.LT.ONE) GO TO 140 IF (Y.GT.ONE) THEN K = K + 1 Y = Y/XBASE MA(1) = K GO TO 180 ENDIF ELSE DO 150 J = 1, NDIG+1 MA(J) = 0 150 CONTINUE MA(1) = MUNKNO MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) KFLAG = -4 CALL FMWARN RETURN ENDIF ENDIF C 160 MA(1) = K + 1 MA(2) = 1 DO 170 J = 3, N1 MA(J) = 0 170 CONTINUE GO TO 240 C C Build the rest of the number. C 180 DO 190 J = 2, NE Y = Y*XBASE MK = DINT (Y) YT = -MK CALL FMDBL(Y,YT,Y) MA(J) = MK IF (J.GE.N1) GO TO 210 190 CONTINUE K = NE + 1 DO 200 J = K, N1 MA(J) = 0 200 CONTINUE C C Normalize. C 210 IF (ABS(MA(2)).GE.MBASE) THEN K = N1 + 1 DO 220 J = 3, N1 K = K - 1 MA(K) = MA(K-1) 220 CONTINUE MN = DINT(MA(2)/MBASE) MA(3) = MA(2) - MN*MBASE MA(2) = MN MA(1) = MA(1) + 1 GO TO 240 ENDIF C IF (MA(2).EQ.0) THEN DO 230 J = 2, NDIG MA(J) = MA(J+1) 230 CONTINUE MA(1) = MA(1) - 1 MA(N1) = 0 ENDIF C 240 IF (X.LT.0.0) MA(2) = -MA(2) MA(0) = MIN(NINT((NE-1)*ALOGM2),NINT(NDIG*ALOGM2)) RETURN END SUBROUTINE FMDM2(X,MA) C C Internal routine for converting double precision to multiple C precision. Called by FMDP2M. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION X DOUBLE PRECISION MA(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMDM2: M01 - M04 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C DOUBLE PRECISION Y,TWO20 INTEGER J,JEXP,K,KEXP,KRESLT,N1,NDSAVE C C Increase the working precision. C NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD21,1) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MA,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MA,MA,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF C IF (MBLOGS.NE.MBASE) CALL FMCONS KFLAG = 0 N1 = NDIG + 1 C IF (X.EQ.0.0D0) THEN DO 110 J = 1, N1 MA(J) = 0 110 CONTINUE GO TO 160 ENDIF C Y = ABS(X) TWO20 = 1048576.0D0 C C If this power of two is not representable at the current C base and precision, use a smaller one. C IF (INT(NDIG*ALOGM2).LT.20) THEN K = INT(NDIG*ALOGM2) TWO20 = 1.0D0 DO 120 J = 1, K TWO20 = TWO20*2.0D0 120 CONTINUE ENDIF C KEXP = 0 IF (Y.GT.TWO20) THEN 130 Y = Y/TWO20 KEXP = KEXP + 1 IF (Y.GT.TWO20) GO TO 130 ELSE IF (Y.LT.1.0D0) THEN 140 Y = Y*TWO20 KEXP = KEXP - 1 IF (Y.LT.1.0D0) GO TO 140 ENDIF C K = INT(TWO20) CALL FMI2M(K,M04) K = INT(Y) CALL FMI2M(K,M02) Y = (Y-DBLE(K))*TWO20 JEXP = 0 C 150 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.LE.1000 .AND. Y.NE.0.0D0) GO TO 150 C K = KEXP - JEXP CALL FMIPWR(M04,K,M03) CALL FMMPY(M02,M03,MA) C 160 IF (X.LT.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 FMDP2M(X,MA) C C MA = X C C Convert a double precision floating point number to FM format. C C This version tries to convert the double precision machine C number to FM with accuracy of nearly full FM precision. C If conversion to FM with approximately double precision accuracy C is good enough, FMDPM is faster and uses less scratch space. C C This routine assumes the machine's base for double precision is C a power of two. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION X DOUBLE PRECISION MA(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C C Scratch array usage during FMDP2M: M01 - M04 C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C NCALL = NCALL + 1 NAMEST(NCALL) = 'FMDP2M' IF (NTRACE.NE.0) CALL FMNTRR(2,X,1) C CALL FMDM2(X,MA) C IF (NTRACE.NE.0) CALL FMNTR(1,MA,MA,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMDPM(X,MA) C C MA = X C C Convert a double precision floating point number to FM format. C C In general, the relative accuracy of the FM number returned is only C the relative accuracy of a machine precision number. This may be C true even if X can be represented exactly in the machine floating C point number system. C C This version is faster than FMDP2M, but often less accurate. C No scratch arrays are used. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION X DOUBLE PRECISION MA(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION Y,YT INTEGER K C NCALL = NCALL + 1 NAMEST(NCALL) = 'FMDPM ' IF (NTRACE.NE.0) CALL FMNTRR(2,X,1) C C Check to see if X is exactly a small integer. If so, C converting as an integer is better. C Also see if X is exactly a small integer divided by C a small power of two. C Y = 1048576.0D0 IF (ABS(X).LT.Y) THEN K = INT(X) Y = K IF (Y.EQ.X) THEN CALL FMIM(K,MA) GO TO 110 ENDIF ENDIF IF (ABS(X).LT.1.0D0) THEN Y = 4096.0D0*X K = INT(Y) YT = K IF (Y.EQ.YT) THEN CALL FMIM(K,MA) CALL FMDIVI(MA,4096,MA) GO TO 110 ENDIF ENDIF C CALL FMDM(X,MA) C 110 IF (NTRACE.NE.0) CALL FMNTR(1,MA,MA,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMENTR(NROUTN,MA,MB,NARGS,MC,KRESLT,NDSAVE,MXSAVE, * KASAVE,KOVUN) C C Do the argument checking and increasing of precision and overflow C threshold upon entry to an FM routine. C C NROUTN - routine name of calling routine C MA - first input argument C MB - second input argument (optional) C NARGS - number of input arguments C MC - result argument C KRESLT - returned nonzero if the input arguments give the result C immediately (e.g., MA*0 or OVERFLOW*MB) C NDSAVE - saves the value of NDIG after NDIG is increased C MXSAVE - saves the value of MXEXP C KASAVE - saves the value of KACCSW C KOVUN - returned nonzero if an input argument is (+ or -) overflow C or underflow. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C CHARACTER *6 NROUTN DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK),MXSAVE INTEGER NARGS,KRESLT,NDSAVE,KASAVE,KOVUN C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCAB INTEGER K C NCALL = NCALL + 1 NAMEST(NCALL) = NROUTN IF (NTRACE.NE.0) CALL FMNTR(2,MA,MB,NARGS) CALL FMARGS(NROUTN,NARGS,MA,MB,KRESLT) C IF (MBLOGS.NE.MBASE) CALL FMCONS KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 IF (NARGS.EQ.2) THEN IF (MB(1).EQ.MEXPOV .OR. MB(1).EQ.MEXPUN) KOVUN = 1 ENDIF C C Increase the working precision. C NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN KRESLT = 12 NDIG = NDSAVE ENDIF ENDIF C IF (KRESLT.NE.0) THEN MACCAB = MA(0) IF (NARGS.EQ.2) MACCAB = MIN(MACCAB,MB(0)) IF (KRESLT.EQ.9 .OR. KRESLT.EQ.10 .OR. KRESLT.GE.13) THEN IF (KRAD.EQ.1) THEN CALL FMPI(MC) ELSE CALL FMI2M(180,MC) ENDIF IF (KRESLT.LE.10) CALL FMDIVI(MC,2,MC) IF (KRESLT.GE.14) CALL FMDIVI(MC,4,MC) CALL FMEQ2(MC,MC,NDIG,NDSAVE,1) NDIG = NDSAVE IF (KRESLT.EQ.9 .OR. KRESLT.EQ.14) MC(2) = -MC(2) MC(0) = MACCAB IF (NTRACE.NE.0) CALL FMNTR(1,MC,MC,1) KASAVE = KACCSW MXSAVE = MXEXP NCALL = NCALL - 1 RETURN ENDIF C NDIG = NDSAVE CALL FMRSLT(MA,MB,MC,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MC,MC,1) KASAVE = KACCSW MXSAVE = MXEXP NCALL = NCALL - 1 RETURN ENDIF C KASAVE = KACCSW KACCSW = 0 C C Extend the overflow/underflow threshold. C MXSAVE = MXEXP MXEXP = MXEXP2 RETURN END SUBROUTINE FMEQ(MA,MB) C C MB = MA C C This is the standard form of equality, where MA and MB both C have precision NDIG. Use FMEQU for assignments that also C change precision. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER J C DO 110 J = 0, NDIG+1 MB(J) = MA(J) 110 CONTINUE C C Check for overflow or underflow. C IF (ABS(MB(1)).GT.MXEXP) THEN IF (MB(1).NE.MUNKNO .OR. MB(2).NE.1) THEN NCALL = NCALL + 1 CALL FMTRAP(MB) NCALL = NCALL - 1 ENDIF IF (MB(1).EQ.MUNKNO) KFLAG = -4 ENDIF C RETURN END SUBROUTINE FMEQ2(MA,MB,NDA,NDB,KSAME) C C Set MB (having NDB digits) equal to MA (having NDA digits). C C If MA and MB are the same array, setting KSAME = 1 before calling C FMEQ2 gives faster performance. C C If MB has less precision than MA the result is rounded to NDB digits. C C If MB has more precision the result has zero digits padded on the C right. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) INTEGER NDA,NDB,KSAME C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION M2,MACCA,MB2,MKT INTEGER J,JT,K,KB,L,N1,NDG C IF (MBLOGS.NE.MBASE) CALL FMCONS MACCA = MA(0) C C Check for precision in range. C IF (NDA.LT.1 .OR. NDA.GT.NDG2MX .OR. NDB.LT.1 .OR. * NDB.GT.NDG2MX) THEN NCALL = NCALL + 1 NAMEST(NCALL) = 'FMEQU ' KFLAG = -1 CALL FMWARN WRITE (KW,110) NDA,NDB 110 FORMAT(/' The two precisions in FMEQU were NDA =',I10, * ' NDB =',I10/) DO 120 J = 1, NDIG+1 MB(J) = 0 120 CONTINUE MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) NCALL = NCALL - 1 RETURN ENDIF C C Check for special symbols. C KFLAG = 0 IF (ABS(MA(1)).GE.MEXPOV) THEN DO 130 J = 2, NDB MB(J+1) = 0 130 CONTINUE MB(1) = MA(1) MB(2) = MA(2) GO TO 260 ENDIF C IF (NDB.EQ.NDA) GO TO 210 C IF (NDB.GT.NDA) GO TO 230 C C Round to NDB digits. C NDG = NDB N1 = NDB + 1 IF (KSAME.NE.1) THEN DO 140 J = 1, N1 MB(J) = MA(J) 140 CONTINUE ENDIF IF (NDG.LT.1 .OR. (KROUND.EQ.0 .AND. NCALL.LE.1)) GO TO 260 C L = NDB + 2 IF (2*(MA(L)+1).LT.MBASE) GO TO 260 M2 = 2 IF (INT(MBASE-DINT(MBASE/M2)*M2).EQ.0) THEN IF (2*MA(L).LT.MBASE) GO TO 260 IF (2*MA(L).EQ.MBASE) THEN IF (L.LE.NDA) THEN DO 150 J = L, NDA IF (MA(J+1).GT.0) GO TO 170 150 CONTINUE ENDIF C C Round to even. C IF (INT(MB(N1)-DINT(MB(N1)/M2)*M2).EQ.0) GO TO 260 ENDIF ELSE IF (2*MA(L)+1.EQ.MBASE) THEN IF (L.LE.NDA) THEN DO 160 J = L, NDA IF (2*(MA(J+1)+1).LT.MBASE) GO TO 260 IF (2*MA(J+1).GT.MBASE) GO TO 170 160 CONTINUE GO TO 260 ENDIF ENDIF ENDIF C 170 MB(NDG+1) = MB(NDG+1) + 1 MB(NDG+2) = 0 C C Check whether there was a carry in the rounded digit. C MB2 = MB(2) MB(2) = ABS(MB(2)) KB = NDG + 1 IF (KB.GE.3) THEN K = KB + 1 DO 180 J = 3, KB K = K - 1 IF (MB(K).LT.MBASE) GO TO 200 MKT = DINT(MB(K)/MBASE) MB(K-1) = MB(K-1) + MKT MB(K) = MB(K) - MKT*MBASE 180 CONTINUE ENDIF C C If there is a carry in the first digit then the exponent C must be adjusted and the number shifted right. C IF (MB(2).LT.MBASE) GO TO 200 IF (KB.GE.4) THEN K = KB + 1 DO 190 J = 4, KB K = K - 1 MB(K) = MB(K-1) 190 CONTINUE ENDIF C MKT = DINT(MB(2)/MBASE) IF (KB.GE.3) MB(3) = MB(2) - MKT*MBASE MB(2) = MKT MB(1) = MB(1) + 1 C 200 IF (MB2.LT.0) MB(2) = -MB(2) GO TO 260 C C MA and MB have the same precision. C 210 IF (KSAME.NE.1) THEN DO 220 J = 1, NDA+1 MB(J) = MA(J) 220 CONTINUE ENDIF GO TO 260 C C Extend to NDB digits by padding with zeros. C 230 IF (KSAME.NE.1) THEN DO 240 J = 1, NDA+1 MB(J) = MA(J) 240 CONTINUE ENDIF DO 250 J = NDA+2, NDB+1 MB(J) = 0 250 CONTINUE C C Check for overflow or underflow. C 260 IF (ABS(MB(1)).GT.MXEXP) THEN IF (MB(1).NE.MUNKNO .OR. MB(2).NE.1) THEN NCALL = NCALL + 1 CALL FMTRAP(MB) NCALL = NCALL - 1 ENDIF IF (MB(1).EQ.MUNKNO) KFLAG = -4 ENDIF C IF (KACCSW.EQ.1) THEN JT = NINT(LOG(REAL(ABS(MB(2))+1))/0.69315) IF (NDB.GT.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 FMEQU(MA,MB,NDA,NDB) C C Set MB (having NDB digits) equal to MA (having NDA digits). C C If MB has less precision than MA, the result is rounded to C NDB digits. C C If MB has more precision, the result has its precision extended C by padding with zero digits on the right. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) INTEGER NDA,NDB C CALL FMEQ2(MA,MB,NDA,NDB,0) C RETURN END SUBROUTINE FMEXIT(MT,MC,NDSAVE,MXSAVE,KASAVE,KOVUN) C C Upon exit from an FM routine the result MT (having precision NDIG) C is rounded and returned in MC (having precision NDSAVE). C The values of NDIG, MXEXP, and KACCSW are restored. C KOVUN is nonzero if one of the routine's input arguments was overflow C or underflow. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MT(0:LUNPCK),MC(0:LUNPCK),MXSAVE INTEGER NDSAVE,KASAVE,KOVUN C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C INTEGER KFSAVE,KWRNSV C KWRNSV = KWARN KWARN = 0 MXEXP = MXSAVE KFSAVE = KFLAG CALL FMEQ2(MT,MC,NDIG,NDSAVE,0) IF (KFLAG.NE.-5 .AND. KFLAG.NE.-6) KFLAG = KFSAVE NDIG = NDSAVE KWARN = KWRNSV IF (KFLAG.EQ.1) KFLAG = 0 IF ((MC(1).EQ.MUNKNO .AND. KFLAG.NE.-9) * .OR. (MC(1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MC(1).EQ.MEXPOV .AND. KOVUN.EQ.0)) CALL FMWARN IF (NTRACE.NE.0) CALL FMNTR(1,MC,MC,1) NCALL = NCALL - 1 KACCSW = KASAVE RETURN END SUBROUTINE FMEXP(MA,MB) C C MB = EXP(MA) C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) CHARACTER *155 STRING C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during FMEXP: M01 - M03 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION M1,MA1,MA2,MACCA,MACMAX,MXSAVE INTEGER IEXTRA,J,K,KASAVE,KOVUN,KRESLT,KT,KWRNSV,NDMB, * NDSAVE,NDSV,NMETHD REAL XMA,XOV C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (ABS(MA(1)).GT.MEXPAB .OR. MA(2).EQ.0) THEN CALL FMENTR('FMEXP ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMEXP ' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MA,1) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF C MA1 = MA(1) MA2 = MA(2) C MACCA = MA(0) CALL FMEQ2(MA,MB,NDSAVE,NDIG,0) MB(0) = NINT(NDIG*ALOGM2) C C Check for obvious underflow or overflow. C XOV is LN(LN(slightly above overflow)) C XMA is LN(LN(EXP(MA))) approximately. C XOV = LOG(1.01*REAL(MXEXP)) + LOG(ALOGMB) M1 = 1 XMA = LOG(REAL(MAX(ABS(MA2),M1))) - ALOGMB + * REAL(MA1)*ALOGMB C 110 IF (XMA.GE.XOV) THEN CALL FMIM(0,MB) IF (MA2.GT.0) THEN KFLAG = -5 MB(1) = MEXPOV MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) ELSE KFLAG = -6 MB(1) = MEXPUN MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) ENDIF NDIG = NDSAVE MXEXP = MXSAVE KACCSW = KASAVE CALL FMWARN IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF C C Split MA into integer and fraction parts. C Work with a positive argument. C M02 = integer part of ABS(MA) C MB = fraction part of ABS(MA) C MB(2) = ABS(MB(2)) CALL FMINT(MB,M02) CALL FMSUB(MB,M02,MB) C C If the integer part is not zero, use FMIPWR to compute C E**(M02). If M02 is too large to represent as a one word C integer, the definition of MXEXP insures that E**(M02) C overflows or underflows. C KWRNSV = KWARN KWARN = 0 CALL FMM2I(M02,KT) KWARN = KWRNSV IF (KFLAG.NE.0) THEN XMA = XOV GO TO 110 ENDIF IF (KT.GT.0) THEN C C Compute IEXTRA, the number of extra digits required C to get EXP(KT) correct to the current precision. C IEXTRA = INT(LOG(REAL(KT))/ALOGMB + 0.5) IF (IEXTRA.GT.0 .AND. NDIG+IEXTRA.LE.NDG2MX) THEN CALL FMEQ2(MB,MB,NDIG,NDIG+IEXTRA,1) ENDIF NDIG = NDIG + IEXTRA IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) DO 120 J = 2, NDSAVE MB(J+1) = 0 120 CONTINUE NDIG = NDIG - IEXTRA CALL FMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN ENDIF C C Check whether the current precision of e is large C enough. C IF (MBSE.NE.MBASE .OR. NDIG.GT.NDIGE) THEN NDMB = INT(150.0*2.302585/ALOGMB) IF (NDMB.GE.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)).GT.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)).GT.10) NDIGE = 0 NDIG = NDSV ENDIF ENDIF C ENDIF C C Now do the fraction part of MA and combine the results. C KWRNSV = KWARN KWARN = 0 NMETHD = 1 IF (NDIG.GT.50) NMETHD = 2 IF (MB(2).NE.0 .AND. KT.GT.0 .AND. NMETHD.EQ.1) THEN CALL FMEXP2(MB,MB) CALL FMIPWR(MESAV,KT,M03) CALL FMMPY(MB,M03,MB) ELSE IF (MB(2).NE.0 .AND. KT.EQ.0 .AND. NMETHD.EQ.1) THEN CALL FMEXP2(MB,MB) ELSE IF (MB(2).NE.0 .AND. KT.GT.0 .AND. NMETHD.EQ.2) THEN NDSV = NDIG NDIG = MIN(NDIG+NGRD21,NDG2MX) CALL FMEQ2(MB,MB,NDSV,NDIG,1) IF (MB(1).GE.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).NE.0 .AND. KT.EQ.0 .AND. NMETHD.EQ.2) THEN NDSV = NDIG NDIG = MIN(NDIG+NGRD21,NDG2MX) CALL FMEQ2(MB,MB,NDSV,NDIG,1) IF (MB(1).GE.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).EQ.0 .AND. KT.GT.0) THEN CALL FMIPWR(MESAV,KT,MB) ELSE CALL FMI2M(1,MB) ENDIF C C Invert if MA was negative. C IF (MA2.LT.0) THEN CALL FMI2M(1,M02) CALL FMDIV(M02,MB,MB) ENDIF KWARN = KWRNSV C C Round the result and return. C 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 FMEXP2(MA,MB) C C MB = EXP(MA) C C Internal exponential routine (called with 0.LT.MA.LE.1). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMEXP2: M01 - M03 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C DOUBLE PRECISION MJSUMS C COMMON /FMSUMS/ MJSUMS(0:LJSUMS) C C LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent C sums. Increasing this value will begin to improve the C speed of EXP when the base is large and precision exceeds C about 1,500 decimal digits. C 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 C IF (MBLOGS.NE.MBASE) CALL FMCONS NDSAVE = NDIG IF (MA(1).EQ.1) THEN C C Here the special case EXP(1.0) is computed. C Use the direct series e = 1/0! + 1/1! + 1/2! + ... C Do as much of the work as possible using small integers C to minimize the number of FM calls. C Reduce NDIG while computing each term in the C sum as the terms get smaller. C T = NDIG XN = T*ALOGMB/LOG(T) K = INT(LOG(XN)/ALOGMB) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) DO 110 J = 2, NDSAVE MB(J+1) = 0 110 CONTINUE NDIG = NDSAVE RETURN ENDIF NDSAV1 = NDIG C CALL FMI2M(2,MB) CALL FMI2M(1,M02) J = 2 NBIG = INT(MXBASE) C 120 NTOP = 1 NBOT = J 130 IF (NBOT.GT.NBIG/(J+1)) GO TO 140 J = J + 1 NTOP = J*NTOP + 1 NBOT = J*NBOT GO TO 130 C 140 CALL FMDIVI(M02,NBOT,M02) IF (NTOP.GT.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.LT.2) NDIG = 2 IF (KFLAG.NE.1) THEN J = J + 1 GO TO 120 ENDIF NDIG = NDSAVE CALL FMI2M(-1,M02) CALL FMADD(MB,M02,M03) KFLAG = 0 RETURN ENDIF C C Here is the general case. Compute EXP(MA) where C 0 .LT. MA .LT. 1. C C Use the direct series C EXP(X) = 1 + X + X**2/2! + X**3/3! + ... C C The argument will be halved K2 times before the series C is summed. The series will be added as J2 concurrent C series. The approximately optimal values of K2 and J2 C are now computed to try to minimize the time required. C N2 is the approximate number of terms of the series that C will be needed, and L2 guard digits will be carried. C 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) C L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B + * REAL(MA(3))/(B*B)))/ALOG2 - 0.3) K2 = K2 - L IF (L.LT.0) L = 0 IF (K2.LT.0) THEN K2 = 0 J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) + .33) ENDIF IF (J2.LE.1) J2 = 1 C N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) L2 = INT(LOG(REAL(N2)+2.0**K2)/ALOGMB) NDIG = NDIG + L2 IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) DO 150 J = 2, NDSAVE MB(J+1) = 0 150 CONTINUE NDIG = NDSAVE RETURN ENDIF NDSAV1 = NDIG C C Halve the argument K2 times. C CALL FMEQ2(MA,M02,NDSAVE,NDIG,0) KTWO = 1 MAXVAL = MXBASE/2 IF (K2.GT.0) THEN DO 160 J = 1, K2 KTWO = 2*KTWO IF (KTWO.GT.MAXVAL) THEN CALL FMDIVI(M02,KTWO,M02) KTWO = 1 ENDIF 160 CONTINUE IF (KTWO.GT.1) CALL FMDIVI(M02,KTWO,M02) ENDIF C C Sum the series X + X**2/2! + X**3/3! + .... C Split into J2 concurrent sums and reduce NDIG while C computing each term in the sum as the terms get smaller. C CALL FMEQ(M02,MB) NTERM = 1 DO 170 J = 1, J2 CALL FMDIVI(MB,NTERM,MB) NTERM = NTERM + 1 KPT = (J-1)*(NDIG+2) CALL FMEQ(MB,MJSUMS(KPT)) 170 CONTINUE IF (M02(1).LT.-NDIG) GO TO 200 CALL FMIPWR(M02,J2,M03) C 180 CALL FMMPY(MB,M03,MB) DO 190 J = 1, J2 CALL FMDIVI(MB,NTERM,MB) KPT = (J-1)*(NDSAV1+2) NDIG = NDSAV1 CALL FMADD(MJSUMS(KPT),MB,MJSUMS(KPT)) IF (KFLAG.NE.0) GO TO 200 NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-MB(1)) IF (NDIG.LT.2) NDIG = 2 NTERM = NTERM + 1 190 CONTINUE GO TO 180 C C Put the J2 separate sums back together. C 200 KFLAG = 0 KPT = (J2-1)*(NDIG+2) CALL FMEQ(MJSUMS(KPT),M03) IF (J2.GE.2) THEN DO 210 J = 2, J2 CALL FMMPY(M02,M03,M03) KPT = (J2-J)*(NDIG+2) CALL FMADD(M03,MJSUMS(KPT),M03) 210 CONTINUE ENDIF C C Reverse the effect of halving the argument to C compute EXP(MA). C NDIG = NDSAV1 IF (K2.GT.0) THEN IF (NDSAVE.LE.20) THEN CALL FMI2M(2,M02) DO 220 J = 1, K2 CALL FMADD(M03,M02,MB) CALL FMMPY(MB,M03,M03) 220 CONTINUE ELSE DO 230 J = 1, K2 CALL FMSQR(M03,MB) CALL FMADD(M03,M03,M02) CALL FMADD(MB,M02,M03) 230 CONTINUE ENDIF ENDIF CALL FMI2M(1,M02) CALL FMADD(M02,M03,MB) C CALL FMEQ2(MB,MB,NDSAV1,NDSAVE,1) NDIG = NDSAVE C RETURN END SUBROUTINE FMFORM(FORM,MA,STRING) C C Convert an FM number (MA) to a character string base 10 (STRING) C using character string FORM format. C C FORM can be one of these types: Iw, Fw.d, Ew.d, 1PEw.d C for positive integers w,d. C C If Iw format is used and MA is not exactly an integer, then the C nearest integer to MA is printed. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C CHARACTER *(*) FORM,STRING DOUBLE PRECISION MA(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMFORM: M01 - M02 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER *20 FORMB INTEGER J,JF1SAV,JF2SAV,JPT,K1,K2,K3,KD,KSAVE,KWD,KWI,LAST, * LB,LENGFM,LENGST,LFIRST,ND,NEXP C NCALL = NCALL + 1 NAMEST(NCALL) = 'FMFORM' C KSAVE = KFLAG JF1SAV = JFORM1 JF2SAV = JFORM2 STRING = ' ' LENGFM = LEN(FORM) LENGST = LEN(STRING) KWI = 75 KWD = 40 C IF (INDEX(FORM,'I').GT.0 .OR. INDEX(FORM,'i').GT.0) THEN K1 = MAX(INDEX(FORM,'I'),INDEX(FORM,'i')) + 1 K2 = LENGFM WRITE (FORMB,110) K2-K1+1 110 FORMAT('(I',I5,')') IF (K2.GE.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.GT.LMBUFF) GO TO 250 CALL FMNINT(MA,M02) IF (M02(2).NE.0) THEN CALL FMOUT(M02,CMBUFF,KWD) ELSE DO 120 J = 1, KWD CMBUFF(J) = ' ' 120 CONTINUE CMBUFF(2) = '0' ENDIF LFIRST = 1 LAST = 1 DO 130 J = 1, KWD IF (CMBUFF(KWD+1-J).NE.' ') LFIRST = KWD+1-J IF (CMBUFF(J).NE.' ') LAST = J 130 CONTINUE JPT = 1 IF (LAST-LFIRST+1.GT.KWI) GO TO 250 IF (LAST.LE.KWI) THEN DO 140 J = LAST, LFIRST, -1 JPT = KWI - LAST + J STRING(JPT:JPT) = CMBUFF(J) 140 CONTINUE DO 150 J = 1, JPT-1 STRING(J:J) = ' ' 150 CONTINUE ELSE DO 160 J = LFIRST, LAST JPT = KWI - LAST + J STRING(JPT:JPT) = CMBUFF(J) 160 CONTINUE ENDIF ELSE IF (INDEX(FORM,'F').GT.0 .OR. INDEX(FORM,'f').GT.0) THEN K1 = MAX(INDEX(FORM,'F'),INDEX(FORM,'f')) + 1 K2 = INDEX(FORM,'.') K3 = LENGFM IF (K2.GT.K1) THEN WRITE (FORMB,110) K2-K1 READ (FORM(K1:K2-1),FORMB) KWI ELSE KWI = 50 ENDIF IF (K3.GT.K2) THEN WRITE (FORMB,110) 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.LT.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 170 J = 1, KWD IF (CMBUFF(KWD+1-J).NE.' ') LFIRST = KWD+1-J IF (CMBUFF(J).NE.' ') LAST = J 170 CONTINUE IF (LAST-LFIRST+1.GT.KWI) THEN C C Not enough room for this F format, or FMOUT converted C it to E format to avoid showing no significant digits. C See if a shortened form will fit in E format. C NEXP = INT(LOG10((ABS(REAL(MA(1)))+1)*LOG10(REAL(MBASE)) * +1)+1) ND = KWI - NEXP - 5 IF (ND.LT.1) THEN GO TO 250 ELSE JFORM1 = 0 JFORM2 = ND CALL FMOUT(MA,CMBUFF,KWI) LFIRST = 1 LAST = 1 DO 180 J = 1, KWI IF (CMBUFF(KWI+1-J).NE.' ') LFIRST = KWI+1-J IF (CMBUFF(J).NE.' ') LAST = J 180 CONTINUE ENDIF ENDIF JPT = 1 IF (LAST.LE.KWI) THEN DO 190 J = LAST, LFIRST, -1 JPT = KWI - LAST + J STRING(JPT:JPT) = CMBUFF(J) 190 CONTINUE DO 200 J = 1, JPT-1 STRING(J:J) = ' ' 200 CONTINUE ELSE DO 210 J = LFIRST, LAST JPT = KWI - LAST + J STRING(JPT:JPT) = CMBUFF(J) 210 CONTINUE ENDIF ELSE IF (INDEX(FORM,'1PE').GT.0 .OR. INDEX(FORM,'1pe').GT.0) THEN K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1 K2 = INDEX(FORM,'.') K3 = LENGFM IF (K2.GT.K1) THEN WRITE (FORMB,110) K2-K1 READ (FORM(K1:K2-1),FORMB) KWI ELSE KWI = 50 ENDIF IF (K3.GT.K2) THEN WRITE (FORMB,110) 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.GT.LMBUFF) GO TO 250 CALL FMOUT(MA,CMBUFF,KWI) DO 220 J = KWI, 1, -1 IF (J.GT.LENGST) THEN IF (CMBUFF(J).NE.' ') GO TO 250 ELSE STRING(J:J) = CMBUFF(J) ENDIF 220 CONTINUE ELSE IF (INDEX(FORM,'E').GT.0 .OR. INDEX(FORM,'e').GT.0) THEN K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1 K2 = INDEX(FORM,'.') K3 = LENGFM IF (K2.GT.K1) THEN WRITE (FORMB,110) K2-K1 READ (FORM(K1:K2-1),FORMB) KWI ELSE KWI = 50 ENDIF IF (K3.GT.K2) THEN WRITE (FORMB,110) 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.GT.LMBUFF) GO TO 250 CALL FMOUT(MA,CMBUFF,KWI) DO 230 J = KWI, 1, -1 IF (J.GT.LENGST) THEN IF (CMBUFF(J).NE.' ') GO TO 250 ELSE STRING(J:J) = CMBUFF(J) ENDIF 230 CONTINUE ELSE GO TO 250 ENDIF C 240 KFLAG = KSAVE JFORM1 = JF1SAV JFORM2 = JF2SAV NCALL = NCALL - 1 RETURN C C Error condition. C 250 KFLAG = -8 DO 260 J = 1, LENGST STRING(J:J) = '*' 260 CONTINUE GO TO 240 END SUBROUTINE FMFPRT(FORM,MA) C C Print an FM number (MA) on unit KW using character C string FORM format. C C FORM can be one of these types: Iw, Fw.d, Ew.d, 1PEw.d C for positive integers w,d. C C If Iw format is used and MA is not exactly an integer, then the C nearest integer to MA is printed. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C CHARACTER *(*) FORM DOUBLE PRECISION MA(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMFPRT: M01 - M02 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER *20 FORM2,FORMB INTEGER J,JF1SAV,JF2SAV,JPT,K,K1,K2,K3,KD,KSAVE,KWD,KWI, * LAST,LB,LENGFM,LFIRST,ND,NEXP C NCALL = NCALL + 1 NAMEST(NCALL) = 'FMFPRT' C KSAVE = KFLAG JF1SAV = JFORM1 JF2SAV = JFORM2 LENGFM = LEN(FORM) KWI = 75 KWD = 40 C IF (INDEX(FORM,'I').GT.0 .OR. INDEX(FORM,'i').GT.0) THEN K1 = MAX(INDEX(FORM,'I'),INDEX(FORM,'i')) + 1 K2 = LENGFM WRITE (FORMB,110) K2-K1+1 110 FORMAT('(I',I5,')') IF (K2.GE.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).NE.0) THEN CALL FMOUT(M02,CMBUFF,KWD) ELSE DO 120 J = 1, KWD CMBUFF(J) = ' ' 120 CONTINUE CMBUFF(2) = '0' ENDIF LFIRST = 1 LAST = 1 DO 130 J = 1, KWD IF (CMBUFF(KWD+1-J).NE.' ') LFIRST = KWD+1-J IF (CMBUFF(J).NE.' ') LAST = J 130 CONTINUE JPT = 1 IF (LAST-LFIRST+1.GT.KWI) GO TO 250 IF (LAST.LE.KWI) THEN DO 140 J = LAST, LFIRST, -1 JPT = KWI - LAST + J IF (JPT.NE.J) CMBUFF(JPT) = CMBUFF(J) 140 CONTINUE DO 150 J = 1, JPT-1 CMBUFF(J) = ' ' 150 CONTINUE ELSE DO 160 J = LFIRST, LAST JPT = KWI - LAST + J IF (JPT.NE.J) CMBUFF(JPT) = CMBUFF(J) 160 CONTINUE ENDIF ELSE IF (INDEX(FORM,'F').GT.0 .OR. INDEX(FORM,'f').GT.0) THEN K1 = MAX(INDEX(FORM,'F'),INDEX(FORM,'f')) + 1 K2 = INDEX(FORM(1:LENGFM),'.') K3 = LENGFM IF (K2.GT.K1) THEN WRITE (FORMB,110) K2-K1 READ (FORM(K1:K2-1),FORMB) KWI ELSE KWI = 50 ENDIF IF (K3.GT.K2) THEN WRITE (FORMB,110) 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.LT.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 170 J = 1, KWD IF (CMBUFF(KWD+1-J).NE.' ') LFIRST = KWD+1-J IF (CMBUFF(J).NE.' ') LAST = J 170 CONTINUE IF (LAST-LFIRST+1.GT.KWI) THEN C C Not enough room for this F format, or FMOUT converted C it to E format to avoid showing no significant digits. C See if a shortened form will fit in E format. C NEXP = INT(LOG10((ABS(REAL(MA(1)))+1)*LOG10(REAL(MBASE)) * +1)+1) ND = KWI - NEXP - 5 IF (ND.LT.1) THEN GO TO 250 ELSE JFORM1 = 0 JFORM2 = ND CALL FMOUT(MA,CMBUFF,KWI) LFIRST = 1 LAST = 1 DO 180 J = 1, KWI IF (CMBUFF(KWI+1-J).NE.' ') LFIRST = KWI+1-J IF (CMBUFF(J).NE.' ') LAST = J 180 CONTINUE ENDIF ENDIF JPT = 1 IF (LAST.LE.KWI) THEN DO 190 J = LAST, LFIRST, -1 JPT = KWI - LAST + J IF (JPT.NE.J) CMBUFF(JPT) = CMBUFF(J) 190 CONTINUE DO 200 J = 1, JPT-1 CMBUFF(J) = ' ' 200 CONTINUE ELSE DO 210 J = LFIRST, LAST JPT = KWI - LAST + J IF (JPT.NE.J) CMBUFF(JPT) = CMBUFF(J) 210 CONTINUE ENDIF ELSE IF (INDEX(FORM,'1PE').GT.0 .OR. INDEX(FORM,'1pe').GT.0) THEN K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1 K2 = INDEX(FORM(1:LENGFM),'.') K3 = LENGFM IF (K2.GT.K1) THEN WRITE (FORMB,110) K2-K1 READ (FORM(K1:K2-1),FORMB) KWI ELSE KWI = 50 ENDIF IF (K3.GT.K2) THEN WRITE (FORMB,110) 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').GT.0 .OR. INDEX(FORM,'e').GT.0) THEN K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1 K2 = INDEX(FORM(1:LENGFM),'.') K3 = LENGFM IF (K2.GT.K1) THEN WRITE (FORMB,110) K2-K1 READ (FORM(K1:K2-1),FORMB) KWI ELSE KWI = 50 ENDIF IF (K3.GT.K2) THEN WRITE (FORMB,110) 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 250 ENDIF C 220 LAST = KWI + 1 WRITE (FORM2,230) KSWIDE-7 230 FORMAT(' (6X,',I3,'A1) ') IF (KFLAG.NE.-8) KFLAG = KSAVE JFORM1 = JF1SAV JFORM2 = JF2SAV DO 240 J = KWI, 1, -1 IF (CMBUFF(J).NE.' ' .OR. J.EQ.1) THEN WRITE (KW,FORM2) (CMBUFF(K),K=1,J) NCALL = NCALL - 1 RETURN ENDIF 240 CONTINUE NCALL = NCALL - 1 RETURN C C Error condition. C 250 KFLAG = -8 DO 260 J = 1, KWI CMBUFF(J) = '*' 260 CONTINUE GO TO 220 END SUBROUTINE FMGCDI(N1,N2) C C Find the Greatest Common Divisor of N1 and N2, and return both C having been divided by their GCD. Both must be positive. C INTEGER K1,K2,K3,N1,N2 C K1 = MAX(N1,N2) K2 = MIN(N1,N2) 110 K3 = MOD(K1,K2) IF (K3.EQ.0) THEN N1 = N1/K2 N2 = N2/K2 RETURN ELSE K1 = K2 K2 = K3 GO TO 110 ENDIF END SUBROUTINE FMI2M(IVAL,MA) C C MA = IVAL C C Convert an integer to FM format. C C The conversion is exact if IVAL is less than MBASE**NDIG, C otherwise the result is an approximation. C C This routine performs the trace printing for the conversion. C FMIM is used to do the arithmetic. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) INTEGER IVAL C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'FMI2M ' CALL FMNTRI(2,IVAL,1) C CALL FMIM(IVAL,MA) C CALL FMNTR(1,MA,MA,1) ELSE CALL FMIM(IVAL,MA) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMIM(IVAL,MA) C C MA = IVAL. Internal integer conversion routine. C C The conversion is exact if IVAL is less than MBASE**NDIG. C Otherwise FMDM is used to get an approximation. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) INTEGER IVAL C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C DOUBLE PRECISION X DOUBLE PRECISION MK,ML,MVAL INTEGER J,JM2,KB,KB1,N1,NMVAL,NV2 C IF (MBLOGS.NE.MBASE) CALL FMCONS KFLAG = 0 N1 = NDIG + 1 C MVAL = ABS(IVAL) NMVAL = INT(MVAL) NV2 = NMVAL - 1 IF (ABS(IVAL).GT.MXBASE .OR. NMVAL.NE.ABS(IVAL) .OR. * NV2.NE.ABS(IVAL)-1) THEN CALL FMIMS(IVAL,MA) GO TO 150 ENDIF C C Check for small IVAL. C IF (MVAL.LT.MBASE) THEN DO 110 J = 3, N1 MA(J) = 0 110 CONTINUE MA(2) = IVAL IF (IVAL.EQ.0) THEN MA(1) = 0 ELSE MA(1) = 1 ENDIF GO TO 150 ENDIF C C Compute and store the digits, right to left. C MA(1) = 0 J = NDIG + 1 C 120 MK = DINT(MVAL/MBASE) ML = MVAL - MK*MBASE MA(1) = MA(1) + 1 MA(J) = ML IF (MK.GT.0) THEN MVAL = MK J = J - 1 IF (J.GE.2) GO TO 120 C C Here IVAL cannot be expressed exactly. C X = IVAL CALL FMDM(X,MA) RETURN ENDIF C C Normalize MA. C KB = N1 - J + 2 JM2 = J - 2 DO 130 J = 2, KB MA(J) = MA(J+JM2) 130 CONTINUE KB1 = KB + 1 IF (KB1.LE.N1) THEN DO 140 J = KB1, N1 MA(J) = 0 140 CONTINUE ENDIF C IF (IVAL.LT.0) MA(2) = -MA(2) C 150 MA(0) = NINT(NDIG*ALOGM2) RETURN END SUBROUTINE FMIMS(IVAL,MA) C C MA = IVAL. Internal integer conversion routine. C C This routine is called when M-variable precision is less than C Integer precision. This often happens when single precision C is chosen for M-variables. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) INTEGER IVAL C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C DOUBLE PRECISION X DOUBLE PRECISION ML INTEGER J,JM2,KB,KB1,KBASE,KMK,KVAL,N1 C IF (MBLOGS.NE.MBASE) CALL FMCONS KFLAG = 0 N1 = NDIG + 1 C C Check for small IVAL. C KVAL = ABS(IVAL) KBASE = INT(MBASE) IF (KVAL.LT.KBASE) THEN DO 110 J = 3, N1 MA(J) = 0 110 CONTINUE MA(2) = IVAL IF (IVAL.EQ.0) THEN MA(1) = 0 ELSE MA(1) = 1 ENDIF GO TO 150 ENDIF C C Compute and store the digits, right to left. C MA(1) = 0 J = NDIG + 1 C 120 KMK = (KVAL/KBASE) ML = KVAL - KMK*KBASE MA(1) = MA(1) + 1 MA(J) = ML IF (KMK.GT.0) THEN KVAL = KMK J = J - 1 IF (J.GE.2) GO TO 120 C C Here IVAL cannot be expressed exactly. C X = IVAL CALL FMDM(X,MA) RETURN ENDIF C C Normalize MA. C KB = N1 - J + 2 JM2 = J - 2 DO 130 J = 2, KB MA(J) = MA(J+JM2) 130 CONTINUE KB1 = KB + 1 IF (KB1.LE.N1) THEN DO 140 J = KB1, N1 MA(J) = 0 140 CONTINUE ENDIF C IF (IVAL.LT.0) MA(2) = -MA(2) C 150 MA(0) = NINT(NDIG*ALOGM2) RETURN END SUBROUTINE FMINP(LINE,MA,LA,LB) C C Convert an array of characters to floating point multiple precision C format. C C LINE is an A1 character array of length LB to be converted C to FM format and returned in MA. C LA is a pointer telling the routine where in the array to begin C the conversion. This allows more than one number to be stored C in an array and converted in place. C LB is a pointer to the last character of the field for that number. C C The input number may be in integer or any real format. C C KESWCH = 1 causes input to FMINP with no digits before the exponent C letter to be treated as if there were a leading '1'. C This is sometimes better for interactive input: C 'E7' converts to 10.0**7. C = 0 causes a leading zero to be assumed. This gives C compatibility with Fortran: C 'E7' converts to 0.0. C C In exponential format the 'E' may also be 'D', 'Q', or 'M'. C C So that FMINP will convert any output from FMOUT, LINE is tested C to see if the input is one of the special symbols +OVERFLOW, C -OVERFLOW, +UNDERFLOW, -UNDERFLOW, or UNKNOWN. C For user input the abbreviations OVFL, UNFL, UNKN may be used. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C INTEGER LA,LB,JTRANS(8,4) CHARACTER LINE(LB),KOVFL(4),KUNFL(4),KUNKN(4),LOVFL(4),LUNFL(4), * LUNKN(4) DOUBLE PRECISION MA(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C DOUBLE PRECISION MLV2(0:LUNPCK),MLV3(0:LUNPCK),MLV4(0:LUNPCK), * MLV5(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION M2,MNDSV1 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 C C Simulate a finite-state automaton to scan the input line C and build the number. States of the machine: C C 1. Initial entry to the subroutine C 2. Sign of the number C 3. Scanning digits before a decimal point C 4. Decimal point C 5. Scanning digits after a decimal point C 6. E, D, Q, or M -- precision indicator before the exponent C 7. Sign of the exponent C 8. Scanning exponent C 9. Syntax error C C Character types recognized by the machine: C C 1. Sign (+,-) C 2. Numeral (0,1,...,9) C 3. Decimal point (.) C 4. Precision indicator (E,D,Q,M) C 5. Illegal character for number C C All blanks are ignored. The analysis of the number proceeds as C follows: If the simulated machine is in state JSTATE and a character C of type JTYPE is encountered the new state of the machine is given by C JTRANS(JSTATE,JTYPE). C C In this DATA statement note the array is loaded by columns. C C State 1 2 3 4 5 6 7 8 C Type DATA JTRANS/ 2, 9, 9, 9, 9, 7, 9, 9, N 3, 3, 3, 5, 5, 8, 8, 8, D 4, 4, 4, 9, 9, 9, 9, 9, P 6, 6, 6, 6, 6, 9, 9, 9 / C DATA KOVFL/'O','V','F','L'/, * KUNFL/'U','N','F','L'/, KUNKN/'U','N','K','N'/ DATA LOVFL/'o','v','f','l'/, * LUNFL/'u','n','f','l'/, LUNKN/'u','n','k','n'/ C C To avoid recursion, FMINP calls only internal arithmetic C routines (FMADD2, FMMPY2, ...), so no trace printout is C done during a call to FMINP. C IF (MBLOGS.NE.MBASE) CALL FMCONS NCALL = NCALL + 1 NAMEST(NCALL) = 'FMINP ' C C Raise the call stack again, since the internal C routines don't. C NCALL = NCALL + 1 NAMEST(NCALL) = 'FMINP ' NDSAVE = NDIG KASAVE = KACCSW KACCSW = 0 KRSAVE = KROUND KROUND = 1 KFLAG = 0 C C Check for special symbols. C KMN = 1 KOF = 1 KUF = 1 KUK = 1 DO 110 J = LA, LB KPT = ICHAR(LINE(J)) IF (KPT.GE.LHASH1 .AND. KPT.LE.LHASH2) THEN KTYPE = KHASHT(KPT) IF (KTYPE.EQ.2) GO TO 120 ENDIF IF (LINE(J).EQ.'-') KMN = -1 IF (LINE(J).EQ.KOVFL(KOF) .OR. LINE(J).EQ.LOVFL(KOF)) THEN KOF = KOF + 1 IF (KOF.EQ.5) THEN CALL FMIM(0,MA) MA(1) = MEXPOV MA(2) = KMN MA(0) = NINT(NDIG*ALOGM2) GO TO 250 ENDIF ENDIF IF (LINE(J).EQ.KUNFL(KUF) .OR. LINE(J).EQ.LUNFL(KOF)) THEN KUF = KUF + 1 IF (KUF.EQ.5) THEN CALL FMIM(0,MA) MA(1) = MEXPUN MA(2) = KMN MA(0) = NINT(NDIG*ALOGM2) GO TO 250 ENDIF ENDIF IF (LINE(J).EQ.KUNKN(KUK) .OR. LINE(J).EQ.LUNKN(KOF)) THEN KUK = KUK + 1 IF (KUK.EQ.5) THEN CALL FMIM(0,MA) MA(1) = MUNKNO MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) GO TO 250 ENDIF ENDIF 110 CONTINUE C C Increase the working precision. C 120 IF (NCALL.LE.2) THEN K = NGRD52 NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 NCALL = NCALL - 1 CALL FMWARN NCALL = NCALL + 1 MA(1) = MUNKNO MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) DO 130 J = 2, NDSAVE MA(J+1) = 0 130 CONTINUE GO TO 250 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) C C If MBASE is a power of ten then call FMINP2 for C faster input conversion. C KPOWER = INT(LOG10(DBLE(MBASE)) + 0.5D0) IF (MBASE.EQ.10**KPOWER) THEN CALL FMINP2(MA,LINE,KSTART,KSTOP,JTRANS,KPOWER, * MLV3,MLV4,MLV5) GO TO 240 ENDIF C N2 = 0 KSIGNX = 1 KF1 = 0 KF2 = 0 KEXP = 0 KTENF1 = 1 KTENF2 = 1 KTENEX = 1 K10PWR = 0 C C LARGE is a threshold used in order to do as much of the C conversion as possible in one-word integer arithmetic. C LARGE = INT((INTMAX - 10)/10) C C KDFLAG will be 1 if any digits are found before 'E'. C KDFLAG = 0 C C Scan the number. C DO 210 J = KSTART, KSTOP IF (LINE(J).EQ.' ') GO TO 210 KPT = ICHAR(LINE(J)) IF (KPT.LT.LHASH1 .OR. KPT.GT.LHASH2) THEN WRITE (KW,140) LINE(J),KPT,LHASH1,LHASH2 140 FORMAT(/' 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.'//) KTYPE = 5 KVAL = 0 ELSE KTYPE = KHASHT(KPT) KVAL = KHASHV(KPT) ENDIF C IF (KTYPE.GE.5) GO TO 260 C JSTATE = JTRANS(JSTATE,KTYPE) C GO TO (260,150,160,210,170,180,190,200,260),JSTATE C C State 2. Sign of the number. C 150 KSIGN = KVAL GO TO 210 C C State 3. Digits before a decimal point. C 160 KDFLAG = 1 KF1 = 10*KF1 + KVAL KTENF1 = 10*KTENF1 IF (KTENF1.GT.LARGE) THEN IF (KTENF1.NE.K10PWR .AND. MLV3(2).NE.0) THEN CALL FMIM(KTENF1,MA) K10PWR = KTENF1 ENDIF IF (MLV3(2).EQ.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.NE.0) CALL FMADD2(MLV3,MLV2,MLV3) NDIG = NDSAV1 ENDIF KF1 = 0 KTENF1 = 1 ENDIF GO TO 210 C C State 5. Digits after a decimal point. C 170 KDFLAG = 1 N2 = N2 + 1 KF2 = 10*KF2 + KVAL KTENF2 = 10*KTENF2 IF (KTENF2.GT.LARGE) THEN IF (KTENF2.NE.K10PWR .AND. MLV4(2).NE.0) THEN CALL FMIM(KTENF2,MA) K10PWR = KTENF2 ENDIF IF (MLV4(2).EQ.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.NE.0) CALL FMADD2(MLV4,MLV2,MLV4) NDIG = NDSAV1 ENDIF KF2 = 0 KTENF2 = 1 ENDIF GO TO 210 C C State 6. Precision indicator. C 180 IF (KDFLAG.EQ.0 .AND. KESWCH.EQ.1) CALL FMIM(1,MLV3) GO TO 210 C C State 7. Sign of the exponent. C 190 KSIGNX = KVAL GO TO 210 C C State 8. Digits of the exponent. C 200 KEXP = 10*KEXP + KVAL KTENEX = 10*KTENEX IF (KTENEX.GT.LARGE) THEN IF (KTENEX.NE.K10PWR .AND. MLV5(2).NE.0) THEN CALL FMIM(KTENEX,MA) K10PWR = KTENEX ENDIF IF (MLV5(2).EQ.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.NE.0) CALL FMADD2(MLV5,MLV2,MLV5) NDIG = NDSAV1 ENDIF KEXP = 0 KTENEX = 1 ENDIF C 210 CONTINUE C C Form the number and return. C MA = KSIGN*(MLV3 + MLV4/10.0**N2)*10.0**MLV5 C IF (KTENF1.GT.1) THEN IF (KTENF1.NE.K10PWR .AND. MLV3(2).NE.0) THEN CALL FMIM(KTENF1,MA) K10PWR = KTENF1 ENDIF IF (MLV3(2).EQ.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.NE.0) CALL FMADD2(MLV3,MLV2,MLV3) NDIG = NDSAV1 ENDIF ENDIF IF (KTENF2.GT.1) THEN IF (KTENF2.NE.K10PWR .AND. MLV4(2).NE.0) THEN CALL FMIM(KTENF2,MA) K10PWR = KTENF2 ENDIF IF (MLV4(2).EQ.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.NE.0) CALL FMADD2(MLV4,MLV2,MLV4) NDIG = NDSAV1 ENDIF ENDIF IF (KTENEX.GT.1) THEN IF (KTENEX.NE.K10PWR .AND. MLV5(2).NE.0) THEN CALL FMIM(KTENEX,MA) K10PWR = KTENEX ENDIF IF (MLV5(2).EQ.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.NE.0) CALL FMADD2(MLV5,MLV2,MLV5) NDIG = NDSAV1 ENDIF ENDIF C IF (KSIGNX.EQ.-1) MLV5(2) = -MLV5(2) IF (MLV4(2).NE.0) THEN CALL FMIM(10,MLV2) K = N2 IF (MOD(K,2).EQ.0) THEN CALL FMIM(1,MA) ELSE CALL FMEQ(MLV2,MA) ENDIF C 220 K = K/2 NDIG = INT(MAX(M2,MIN(2*MLV2(1),MNDSV1))) CALL FMMPY2(MLV2,MLV2,MLV2) IF (MOD(K,2).EQ.1) THEN NDIG = INT(MAX(M2,MIN(MLV2(1)+MA(1),MNDSV1))) CALL FMMPY2(MLV2,MA,MA) ENDIF IF (K.GT.1) GO TO 220 NDIG = NDSAV1 CALL FMDIV2(MLV4,MA,MLV4) ENDIF IF (MLV5(2).NE.0) THEN CALL FMIM(10,MLV2) KWRNSV = KWARN KWARN = 0 CALL FMMI(MLV5,KEXP) KWARN = KWRNSV IF (KFLAG.NE.0) GO TO 260 K = ABS(KEXP) IF (MOD(K,2).EQ.0) THEN CALL FMIM(1,MLV5) ELSE CALL FMEQ(MLV2,MLV5) ENDIF C 230 K = K/2 NDIG = INT(MAX(M2,MIN(2*MLV2(1),MNDSV1))) CALL FMMPY2(MLV2,MLV2,MLV2) IF (MOD(K,2).EQ.1) THEN NDIG = INT(MAX(M2,MIN(MLV2(1)+MLV5(1),MNDSV1))) CALL FMMPY2(MLV2,MLV5,MLV5) ENDIF IF (K.GT.1) GO TO 230 NDIG = NDSAV1 IF (KEXP.LT.0) THEN CALL FMIM(1,MLV2) CALL FMDIV2(MLV2,MLV5,MLV5) ENDIF ENDIF CALL FMADD2(MLV3,MLV4,MA) IF (MLV5(2).NE.0) CALL FMMPY2(MA,MLV5,MA) IF (KSIGN.EQ.-1) MA(2) = -MA(2) 240 CALL FMEQ2(MA,MA,NDIG,NDSAVE,1) IF (MA(1).EQ.MUNKNO) GO TO 260 C 250 NDIG = NDSAVE KACCSW = KASAVE KROUND = KRSAVE IF (KFLAG.EQ.1) KFLAG = 0 MA(0) = NINT(NDIG*ALOGM2) NCALL = NCALL - 2 RETURN C C Error in converting the number. C 260 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 250 END SUBROUTINE FMINP2(MA,LINE,KSTART,KSTOP,JTRANS,KPOWER, * MLV3,MLV4,MLV5) C C Internal routine for input conversion for a power of ten MBASE. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C 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) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C INTEGER J,JSTATE,KDFLAG,KEXP,KF1,KF1DIG,KF2,KF2DIG,KF2PT,KNZDIG, * KPT,KSHIFT,KSIGN,KSIGNX,KTYPE,KVAL,LARGE C 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) C C Scan the number. C DO 180 J = KSTART, KSTOP IF (LINE(J).EQ.' ') GO TO 180 KPT = ICHAR(LINE(J)) IF (KPT.LT.LHASH1 .OR. KPT.GT.LHASH2) THEN WRITE (KW,110) LINE(J),KPT,LHASH1,LHASH2 110 FORMAT(/' 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.'//) KTYPE = 5 KVAL = 0 ELSE KTYPE = KHASHT(KPT) KVAL = KHASHV(KPT) ENDIF C IF (KTYPE.GE.5) GO TO 190 C JSTATE = JTRANS(JSTATE,KTYPE) C GO TO (190,120,130,180,140,150,160,170,190),JSTATE C C State 2. Sign of the number. C 120 KSIGN = KVAL GO TO 180 C C State 3. Digits before a decimal point. C 130 KDFLAG = 1 KF1 = 10*KF1 + KVAL IF (KVAL.GT.0 .OR. KNZDIG.NE.0) THEN KNZDIG = 1 KF1DIG = KF1DIG + 1 ENDIF IF (KF1DIG.EQ.KPOWER) THEN MLV3(1) = MLV3(1) + 1 IF (MLV3(1).LT.NDIG) MLV3(INT(MLV3(1))+1) = KF1 KF1 = 0 KF1DIG = 0 ENDIF GO TO 180 C C State 5. Digits after a decimal point. C 140 KDFLAG = 1 IF (KF2PT.GT.NDIG+1) GO TO 180 KF2 = 10*KF2 + KVAL KF2DIG = KF2DIG + 1 IF (KF2DIG.EQ.KPOWER) THEN MLV4(KF2PT) = KF2 IF (KF2.EQ.0 .AND. KF2PT.EQ.2) THEN MLV4(1) = MLV4(1) - 1 ELSE KF2PT = KF2PT + 1 ENDIF KF2 = 0 KF2DIG = 0 ENDIF GO TO 180 C C State 6. Precision indicator. C 150 IF (KDFLAG.EQ.0 .AND. KESWCH.EQ.1) CALL FMIM(1,MLV3) GO TO 180 C C State 7. Sign of the exponent. C 160 KSIGNX = KVAL GO TO 180 C C State 8. Digits of the exponent. C 170 IF (KEXP.GE.LARGE) THEN IF (MLV3(2).EQ.0 .AND. MLV4(2).EQ.0) THEN CALL FMIM(0,MA) RETURN ENDIF CALL FMIM(0,MA) IF (KSIGNX.EQ.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 C KEXP = 10*KEXP + KVAL C 180 CONTINUE C C Form the number and return. C MA = KSIGN*(MLV3 + MLV4)*10.0**(KSIGNX*KEXP) C IF (KF1DIG.NE.0) THEN MLV3(1) = MLV3(1) + 1 KSHIFT = 10**(KPOWER-KF1DIG) IF (MLV3(1).LT.NDIG) MLV3(INT(MLV3(1))+1) = KF1*KSHIFT IF (KSHIFT.GT.1) THEN CALL FMDIVN(MLV3,KSHIFT,MLV3) ENDIF ENDIF C IF (KF2DIG.NE.0) THEN KSHIFT = 10**(KPOWER-KF2DIG) MLV4(KF2PT) = KF2*KSHIFT ENDIF IF (MLV4(2).EQ.0) MLV4(1) = 0 C IF (KEXP.NE.0) THEN IF (KSIGNX.EQ.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.GT.1) THEN MLV5(2) = MBASE/KSHIFT ELSE MLV5(2) = 1 ENDIF ENDIF ENDIF C CALL FMADD2(MLV3,MLV4,MA) IF (KEXP.GT.0) CALL FMMPY2(MA,MLV5,MA) MA(2) = KSIGN*MA(2) C RETURN C C Error in converting the number. C 190 CALL FMIM(0,MA) MA(1) = MUNKNO MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) RETURN END SUBROUTINE FMINT(MA,MB) C C MB = INT(MA) C C The integer part of MA is computed and returned in MB as a multiple C precision floating point number. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCA,MACMAX INTEGER J,KA,KB,KRESLT,N1 C IF (MBLOGS.NE.MBASE) CALL FMCONS MACCA = MA(0) KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMINT ' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MA,1) IF (ABS(MA(1)).GT.MEXPAB) THEN CALL FMARGS('FMINT ',1,MA,MB,KRESLT) IF (KRESLT.NE.0) THEN CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF C N1 = NDIG + 1 C C If MA is less than one in magnitude, return zero. C IF (MA(1).LE.0) THEN DO 110 J = 1, N1 MB(J) = 0 110 CONTINUE GO TO 150 ENDIF C C If the radix point is off the right end of MA then MA is C already an integer. Return MA. C IF (MA(1).GE.NDIG) THEN DO 120 J = 1, N1 MB(J) = MA(J) 120 CONTINUE GO TO 150 ENDIF C C Here MA has both integer and fraction parts. Replace C the digits right of the radix point by zeros. C KA = INT(MA(1)) + 2 KB = KA - 1 DO 130 J = 1, KB MB(J) = MA(J) 130 CONTINUE C DO 140 J = KA, N1 MB(J) = 0 140 CONTINUE C 150 IF (KACCSW.EQ.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.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMIPWR(MA,IVAL,MB) C C MB = MA ** IVAL C C Raise an FM number to an integer power. C The binary multiplication method used requires an average of C 1.5 * LOG2(IVAL) multiplications. MA may be negative. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) INTEGER IVAL C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMIPWR: M01 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MA2,MACCA,MACMAX INTEGER J,JSIGN,K,KWRNSV,NDSAVE REAL XVAL C IF (MBLOGS.NE.MBASE) CALL FMCONS KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMIPWR' IF (NTRACE.NE.0) THEN CALL FMNTR(2,MA,MA,1) CALL FMNTRI(2,IVAL,0) ENDIF C C Check for special cases. C IF (MA(1).EQ.MUNKNO .OR. (IVAL.LE.0 .AND. MA(2).EQ.0)) THEN MA2 = MA(2) CALL FMIM(0,MB) MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -4 IF (IVAL.LE.0 .AND. MA2.EQ.0) CALL FMWARN IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF C IF (IVAL.EQ.0) THEN CALL FMIM(1,MB) IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF C IF (ABS(IVAL).EQ.1) THEN KWRNSV = KWARN KWARN = 0 IF (IVAL.EQ.1) THEN CALL FMEQ(MA,MB) ELSE CALL FMIM(1,M01) CALL FMDIV(M01,MA,MB) ENDIF IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 KWARN = KWRNSV RETURN ENDIF C IF (MA(2).EQ.0) THEN CALL FMEQ(MA,MB) IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF C IF (MA(1).EQ.MEXPOV) THEN JSIGN = 1 IF (MA(2).LT.0) JSIGN = -1 CALL FMIM(0,MB) IF (IVAL.GT.0) THEN MB(1) = MEXPOV MB(2) = JSIGN**MOD(IVAL,2) MB(0) = NINT(NDIG*ALOGM2) KFLAG = -5 ELSE MB(1) = MEXPUN MB(2) = JSIGN**MOD(IVAL,2) MB(0) = NINT(NDIG*ALOGM2) KFLAG = -6 ENDIF IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF C IF (MA(1).EQ.MEXPUN) THEN JSIGN = 1 IF (MA(2).LT.0) JSIGN = -1 CALL FMIM(0,MB) IF (IVAL.GT.0) THEN MB(1) = MEXPUN MB(2) = JSIGN**MOD(IVAL,2) MB(0) = NINT(NDIG*ALOGM2) KFLAG = -6 ELSE MB(1) = MEXPOV MB(2) = JSIGN**MOD(IVAL,2) MB(0) = NINT(NDIG*ALOGM2) KFLAG = -5 ENDIF IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF C C Increase the working precision. C NDSAVE = NDIG IF (NCALL.EQ.1) THEN XVAL = ABS(IVAL) K = INT((5.0*REAL(DLOGTN) + LOG(XVAL))/ALOGMB + 2.0) NDIG = MAX(NDIG+K,2) ELSE XVAL = ABS(IVAL) IF (XVAL.GT.10.0 .OR. REAL(MBASE).LE.999.0) THEN K = INT(LOG(XVAL)/ALOGMB + 1.0) NDIG = NDIG + K ENDIF ENDIF IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) DO 110 J = 2, NDSAVE MB(J+1) = 0 110 CONTINUE NDIG = NDSAVE IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF C C Initialize. C KWRNSV = KWARN KWARN = 0 K = ABS(IVAL) C MACCA = MA(0) CALL FMEQ2(MA,M01,NDSAVE,NDIG,0) M01(0) = NINT(NDIG*ALOGM2) C IF (MOD(K,2).EQ.0) THEN CALL FMI2M(1,MB) ELSE CALL FMEQ(M01,MB) ENDIF C C This is the multiplication loop. C 120 K = K/2 CALL FMSQR(M01,M01) IF (MOD(K,2).EQ.1) CALL FMMPY(M01,MB,MB) IF (K.GT.1) GO TO 120 C C Invert if the exponent is negative. C IF (IVAL.LT.0) THEN CALL FMI2M(1,M01) CALL FMDIV(M01,MB,MB) ENDIF KWARN = KWRNSV C C Round the result and return. C CALL FMEQ2(MB,MB,NDIG,NDSAVE,1) NDIG = NDSAVE IF (KACCSW.EQ.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.LT.0) CALL FMWARN IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMLG10(MA,MB) C C MB = LOG10(MA) C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMLG10: M01 - M05 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCA,MACMAX,MXSAVE INTEGER K,KASAVE,KOVUN,KRESLT,NDSAVE C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (ABS(MA(1)).GT.MEXPAB .OR. MA(2).LE.0) THEN CALL FMENTR('FMLG10',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMLG10' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MA,1) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF C MACCA = MA(0) CALL FMEQ2(MA,MB,NDSAVE,NDIG,0) MB(0) = NINT(NDIG*ALOGM2) C CALL FMLN(MB,MB) IF (MBASE.NE.MBSLI .OR. NDIG.GT.NDIGLI) THEN CALL FMLNI(10,M03) ELSE CALL FMADD(MLN1,MLN3,M03) ENDIF CALL FMDIV(MB,M03,MB) C C Round the result and return. C 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(MA,MB) C C MB = LOG(MA) (Natural logarithm) C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION Y DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) INTEGER NSTACK(19) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during FMLN: M01 - M05 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C 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 C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (ABS(MA(1)).GT.MEXPAB .OR. MA(2).LE.0) THEN CALL FMENTR('FMLN ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMLN ' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MA,1) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF C C If MA is close to 1, use the Taylor series: C LN(1+X) = X - X**2/2 + X**3/3 - ... C This is faster for small X and avoids cancellation error. C C This method is faster for moderate sized NDIG, but is C asymptotically slower by a factor of NDIG**(2/3) than C using Newton and FMEXP. For MBASE=10,000 the Taylor C series is faster for NDIG less than about 150 (and is C used only when MA is between .9999 and 1.0001). C IF (MA(1).EQ.0 .OR. MA(1).EQ.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.GT.0.9999 .AND. X.LE.1.0001) THEN MACCA = MA(0) CALL FMEQ2(MA,M03,NDSAVE,NDIG,0) M03(0) = NINT(NDIG*ALOGM2) C CALL FMI2M(-1,M01) CALL FMADD(M03,M01,M03) C C The sum will be done as two concurrent series. C NDSAV1 = NDIG CALL FMEQ(M03,M04) CALL FMDIVI(M03,2,M05) CALL FMSQR(M03,MB) CALL FMEQ(M03,M02) KBOT = 2 C 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.NE.1) GO TO 110 C NDIG = NDSAV1 CALL FMMPY(M05,M03,M05) CALL FMSUB(M04,M05,MB) GO TO 170 ENDIF C MA1 = MA(1) MACCA = MA(0) CALL FMEQ2(MA,M05,NDSAVE,NDIG,0) M05(0) = NINT(NDIG*ALOGM2) C C Compute IEXTRA, the number of extra digits required. C CALL FMI2M(1,M04) CALL FMSUB(M04,M05,M04) IEXTRA = MAX(0-INT(M04(1)),0) IF (IEXTRA.GT.0 .AND. NDIG+IEXTRA.LE.NDG2MX) THEN CALL FMEQ2(M05,M05,NDIG,NDIG+IEXTRA,1) ENDIF NDIG = NDIG + IEXTRA IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) DO 120 J = 2, NDSAVE MB(J+1) = 0 120 CONTINUE NDIG = NDIG - IEXTRA CALL FMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN ENDIF C C Check to see if the argument is a small integer. C If so use FMLNI. C KM1 = 0 C KWRNSV = KWARN KWARN = 0 CALL FMM2I(M05,IVAL) KWARN = KWRNSV IF (KFLAG.EQ.0 .AND. IVAL.LT.MXBASE) THEN CALL FMLNI(IVAL,MB) GO TO 170 ENDIF C C See if the argument can be scaled to a small integer. C N3 = NDIG + 3 N1 = NDIG + 1 DO 130 J = 2, N1 IF (M05(N3-J).NE.0) THEN LAST = N3 - J - 1 GO TO 140 ENDIF 130 CONTINUE C 140 KSCALE = INT(MA1) - LAST M05(1) = LAST KWRNSV = KWARN KWARN = 0 CALL FMM2I(M05,IVAL) KWARN = KWRNSV IF (KFLAG.EQ.0 .AND. IVAL.LT.MXBASE) THEN CALL FMLNI(IVAL,M04) IF (IVAL.EQ.1) KM1 = 1 K2EXP = 0 GO TO 160 ENDIF C C For the non-integer case, scale the argument to lie C between e/2 and e to speed up the calls to FMEXP. C M05(1) = 1 KSCALE = INT(MA1) - 1 CALL FMM2DP(M05,Y) K2EXP = INT(LOG(2.0*REAL(Y)/2.71828)/0.693147) IF (Y.LT.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 C C Generate the initial approximation. C Y = LOG(Y) CALL FMDPM(Y,M04) CALL FMDIG(NSTACK,KST) C C Newton iteration. C DO 150 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) 150 CONTINUE M04(0) = NINT(NDIG*ALOGM2) C C Compute LN(MBASE**KSCALE). C 160 IF ((MBSLB.NE.MBASE .OR. NDIGLB.LT.NDIG) .AND. KSCALE.NE.0) THEN NDSV = NDIG NDIG = MIN(NDIG+2,NDG2MX) CALL FMLNI(INT(MBASE),MLBSAV) MBSLB = MBASE NDIGLB = NDIG IF (ABS(MLBSAV(1)).GT.10) NDIGLB = 0 NDIG = NDSV ENDIF C IF (KSCALE.NE.0 .AND. KM1.EQ.0) THEN CALL FMMPYI(MLBSAV,KSCALE,MB) CALL FMADD(M04,MB,MB) ELSE IF (KSCALE.NE.0 .AND. KM1.EQ.1) THEN CALL FMMPYI(MLBSAV,KSCALE,MB) ELSE IF (KSCALE.EQ.0 .AND. KM1.EQ.0) THEN CALL FMEQ(M04,MB) ELSE IF (KSCALE.EQ.0 .AND. KM1.EQ.1) THEN CALL FMI2M(0,MB) ENDIF C IF (K2EXP.NE.0) THEN IF (MBASE.NE.MBSLI .OR. NDIG.GT.NDIGLI) THEN CALL FMLNI(2,M04) ENDIF CALL FMMPYI(MLN1,K2EXP,M04) CALL FMADD(MB,M04,MB) ENDIF C C Round the result and return. C 170 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 FMLNI(IVAL,MA) C C MA = LOG(IVAL) C C Compute the natural logarithm of an integer IVAL. C C If IVAL has only powers of 2, 3, 5, and 7 in its factorization then C FMLNI is faster than FMLN. Otherwise, if IVAL.GE.MXBASE (i.e., IVAL C does not fit in 1/2 word) then FMLN is usually faster. C C Use FMLN instead of FMLNI if 10*IVAL would cause integer overflow. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) INTEGER IVAL C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during FMLNI: M01 - M03 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C CHARACTER *155 STRING INTEGER INT2,J,J2,J3,J5,J7,JTEMP2,JTEMP3,JTEMP5,JTEMP7, * K,K2,K3,K5,K7,KASAVE,KDELTA,LAST,ND,NDMB,NDSAVE,NDSV, * NT REAL XVAL C IF (MBLOGS.NE.MBASE) CALL FMCONS KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMLNI ' IF (NTRACE.NE.0) CALL FMNTRI(2,IVAL,1) C C Check for special cases. C IF (IVAL.LE.0) THEN CALL FMIM(0,MA) MA(1) = MUNKNO MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) KFLAG = -4 CALL FMWARN IF (NTRACE.NE.0) CALL FMNTR(1,MA,MA,1) NCALL = NCALL - 1 RETURN ENDIF C IF (IVAL.EQ.1) THEN CALL FMI2M(0,MA) IF (NTRACE.NE.0) CALL FMNTR(1,MA,MA,1) NCALL = NCALL - 1 RETURN ENDIF C C Increase the working precision. C NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = NGRD52 NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN MA(1) = MUNKNO MA(2) = 1 MA(0) = NINT(NDSAVE*ALOGM2) DO 110 J = 2, NDSAVE MA(J+1) = 0 110 CONTINUE NDIG = NDSAVE IF (NTRACE.NE.0) CALL FMNTR(1,MA,MA,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 C C Find integers K2, K3, K5, and K7 such that C NT = 2**K2 * 3**K3 * 5**K5 * 7**K7 C is a good approximation of IVAL. C KDELTA = ABS(IVAL - NT). C INT2 = IVAL IF (IVAL.GT.INTMAX/100) INT2 = IVAL/100 KDELTA = INT2 NT = 0 K2 = 0 K3 = 0 K5 = 0 K7 = 0 C C Start the search loop. C XVAL = INT2 LAST = INT(LOG(DBLE(XVAL))/DLOGTW + 2.0D0) C JTEMP7 = 1 DO 180 J7 = 1, LAST IF (JTEMP7.GT.INT2 .AND. * ABS(JTEMP7-INT2).GT.KDELTA) GO TO 190 C JTEMP5 = JTEMP7 DO 160 J5 = 1, LAST IF (JTEMP5.GT.INT2 .AND. * ABS(JTEMP5-INT2).GT.KDELTA) GO TO 170 C JTEMP3 = JTEMP5 DO 140 J3 = 1, LAST IF (JTEMP3.GT.INT2 .AND. * ABS(JTEMP3-INT2).GT.KDELTA) GO TO 150 C JTEMP2 = JTEMP3 DO 120 J2 = 1, LAST IF (ABS(JTEMP2-INT2).LE.KDELTA) THEN IF (ABS(JTEMP2-INT2).EQ.KDELTA .AND. * JTEMP2.LT.INT2) GO TO 130 KDELTA = ABS(JTEMP2-INT2) NT = JTEMP2 K2 = J2 - 1 K3 = J3 - 1 K5 = J5 - 1 K7 = J7 - 1 IF (KDELTA.EQ.0) GO TO 190 ENDIF IF (JTEMP2.GT.INT2) GO TO 130 C JTEMP2 = 2*JTEMP2 120 CONTINUE C 130 JTEMP3 = 3*JTEMP3 140 CONTINUE C 150 JTEMP5 = 5*JTEMP5 160 CONTINUE C 170 JTEMP7 = 7*JTEMP7 180 CONTINUE C C If IVAL was too close to the integer overflow limit, C restore NT to an approximation of IVAL. C 190 IF (INT2.NE.IVAL) THEN IF (NT.LE.INT2) THEN NT = NT*100 K2 = K2 + 2 K5 = K5 + 2 ELSE IF (NT.LE.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 C C End of the search. Now compute LN(NT) as a linear C combination of LN(2), LN(3), LN(5), and LN(7). C IF (MBASE.NE.MBSLI .OR. NDIG.GT.NDIGLI) THEN NDMB = INT(150.0*2.302585/ALOGMB) IF (NDMB.GE.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)).GT.10 .OR. ABS(MLN2(1)).GT.10 .OR. * ABS(MLN3(1)).GT.10 .OR. ABS(MLN4(1)).GT.10) NDIGLI = 0 ELSE NDSV = NDIG NDIG = MIN(NDIG+2,NDG2MX) MBSLI = MBASE NDIGLI = NDIG C CALL FMLNI2(1,126,MLN1) CALL FMLNI2(1,225,MLN2) CALL FMLNI2(1,2401,MLN3) CALL FMLNI2(1,4375,MLN4) C C Get Ln(2). C 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) C C Get Ln(3). C 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) C C Get Ln(5). C 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) C C Get Ln(7). C 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)).GT.10 .OR. ABS(MLN2(1)).GT.10 .OR. * ABS(MLN3(1)).GT.10 .OR. ABS(MLN4(1)).GT.10) NDIGLI = 0 NDIG = NDSV ENDIF C C If NT.NE.IVAL then the final step is to compute C LN(IVAL/NT) and then use LN(IVAL) = LN(IVAL/NT) + LN(NT). C IF (NT.NE.IVAL) THEN ND = NT - IVAL CALL FMLNI2(ND,NT,MA) ENDIF C 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.NE.IVAL) CALL FMADD(M02,MA,M02) CALL FMADD(M02,M01,MA) C C Round and move the result to MA. C KACCSW = KASAVE CALL FMEQ2(MA,MA,NDIG,NDSAVE,1) NDIG = NDSAVE IF (NTRACE.NE.0) CALL FMNTR(1,MA,MA,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMLNI2(INT1,INT2,MA) C C MA = LN(1 - INT1/INT2) C C Taylor series for computing the logarithm of a rational number C near 1. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C INTEGER INT1,INT2 DOUBLE PRECISION MA(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during FMLNI2: M01 - M02 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER J,NDSAVE C CALL FMI2M(INT1,M02) CALL FMDIVI(M02,INT2,M02) CALL FMEQ(M02,MA) NDSAVE = NDIG J = 1 C 110 J = J + 1 IF (INT1.NE.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.LT.2) NDIG = 2 IF (KFLAG.NE.1) GO TO 110 C NDIG = NDSAVE MA(0) = NINT(NDIG*ALOGM2) MA(2) = -MA(2) RETURN END SUBROUTINE FMM2DP(MA,X) C C X = MA C C Convert an FM number to double precision. C C If KFLAG = -4 is returned for a value of MA that is in the range C of the machine's double precision number system, change the C definition of DPMAX in routine FMSET to reflect the current machine's C range. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) DOUBLE PRECISION X C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER KRESLT C NCALL = NCALL + 1 NAMEST(NCALL) = 'FMM2DP' KRESLT = 0 IF (ABS(MA(1)).GT.MEXPAB) THEN CALL FMARGS('FMM2DP',1,MA,MA,KRESLT) ENDIF IF (NTRACE.NE.0) CALL FMNTR(2,MA,MA,1) IF (KRESLT.NE.0) THEN C C Here no valid result can be returned. Set X to some C value that the user is likely to recognize as wrong. C X = DBLE(RUNKNO) KFLAG = -4 IF (MA(1).NE.MUNKNO) CALL FMWARN IF (NTRACE.NE.0) CALL FMNTRR(1,X,1) NCALL = NCALL - 1 RETURN ENDIF C CALL FMMD(MA,X) C IF (NTRACE.NE.0) CALL FMNTRR(1,X,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMM2I(MA,IVAL) C C IVAL = MA C C Convert an FM number to integer. C C KFLAG = 0 is returned if the conversion is exact. C = -4 is returned if MA is larger than INTMAX in magnitude. C IVAL = IUNKNO is returned as an indication that IVAL C could not be computed without integer overflow. C = 2 is returned if MA is smaller than INTMAX in magnitude C but MA is not an integer. The next integer toward zero C is returned in IVAL. C It is sometimes convenient to call FMM2I to see if an FM number C can be represented as a one-word integer, by checking KFLAG upon C return. To avoid an unwanted error message being printed in the C KFLAG=-4 case, set KWARN=0 before the call to FMM2I and reset it C after the call. C C This routine performs the trace printing for the conversion. C FMMI is used to do the arithmetic. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) INTEGER IVAL C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C NCALL = NCALL + 1 NAMEST(NCALL) = 'FMM2I ' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MA,1) C CALL FMMI(MA,IVAL) C IF (NTRACE.NE.0) CALL FMNTRI(1,IVAL,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMM2SP(MA,X) C C X = MA C C Convert an FM number to single precision. C C MA is converted and the result is returned in X. C C If KFLAG = -4 is returned for a value of MA that is in the range C of the machine's single precision number system, change the C definition of SPMAX in routine FMSET to reflect the current machine's C range. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) REAL X C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION Y INTEGER KRESLT C NCALL = NCALL + 1 NAMEST(NCALL) = 'FMM2SP' KRESLT = 0 IF (ABS(MA(1)).GT.MEXPAB) THEN CALL FMARGS('FMM2SP',1,MA,MA,KRESLT) ENDIF IF (NTRACE.NE.0) CALL FMNTR(2,MA,MA,1) IF (KRESLT.NE.0) THEN C C Here no valid result can be returned. Set X to some C value that the user is likely to recognize as wrong. C X = RUNKNO KFLAG = -4 IF (MA(1).NE.MUNKNO) CALL FMWARN Y = DBLE(X) IF (NTRACE.NE.0) CALL FMNTRR(1,Y,1) NCALL = NCALL - 1 RETURN ENDIF C CALL FMMD(MA,Y) X = REAL(Y) C IF (NTRACE.NE.0) THEN Y = DBLE(X) CALL FMNTRR(1,Y,1) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMMAX(MA,MB,MC) C C MC = MAX(MA,MB) C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER KWRNSV LOGICAL FMCOMP C KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMMAX ' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MB,2) C KWRNSV = KWARN KWARN = 0 IF (MA(1).EQ.MUNKNO .OR. MB(1).EQ.MUNKNO) THEN CALL FMIM(0,MC) MC(1) = MUNKNO MC(2) = 1 MC(0) = NINT(NDIG*ALOGM2) KFLAG = -4 ELSE IF (FMCOMP(MA,'LT',MB)) THEN CALL FMEQ(MB,MC) ELSE CALL FMEQ(MA,MC) ENDIF C KWARN = KWRNSV IF (NTRACE.NE.0) CALL FMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMMD(MA,X) C C X = MA C C Internal routine for conversion to double precision. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) DOUBLE PRECISION X C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION Y,YT,XBASE,RZERO,ONE,PMAX,DLOGDP DOUBLE PRECISION MA1,MA2 INTEGER J,KWRNSV,N1,NCASE C C Check to see if MA is in range for single or double C precision. C IF (MBLOGS.NE.MBASE) CALL FMCONS PMAX = DPMAX IF (NCALL.GT.0) THEN IF (NAMEST(NCALL).EQ.'FMM2SP') PMAX = DBLE(SPMAX) ENDIF DLOGDP = LOG(PMAX) MA1 = MA(1) NCASE = 0 IF (DBLE(MA(1)-1)*DLOGMB.GT.DLOGDP) THEN KFLAG = -4 X = DBLE(RUNKNO) CALL FMWARN RETURN ELSE IF (DBLE(MA(1)+1)*DLOGMB.GT.DLOGDP) THEN MA(1) = MA(1) - 2 NCASE = 1 ELSE IF (DBLE(MA(1)+1)*DLOGMB.LT.-DLOGDP) THEN KFLAG = -10 X = 0.0D0 CALL FMWARN RETURN ELSE IF (DBLE(MA(1)-1)*DLOGMB.LT.-DLOGDP) THEN MA(1) = MA(1) + 2 NCASE = 2 ENDIF C C Try FMMI first so that small integers will be C converted exactly. C KWRNSV = KWARN KWARN = 0 CALL FMMI(MA,J) KWARN = KWRNSV IF (KFLAG.EQ.0) THEN X = J RETURN ENDIF KFLAG = 0 C MA2 = MA(2) MA(2) = ABS(MA2) RZERO = 0.0D0 ONE = 1.0D0 N1 = NDIG + 1 XBASE = MBASE X = RZERO Y = ONE DO 110 J = 2, N1 Y = Y/XBASE YT = MA(J) X = X + Y*YT YT = ONE + Y*XBASE IF (YT.LE.ONE) GO TO 120 110 CONTINUE C 120 X = X*XBASE**MA(1) IF (MA2.LT.0) X = -X MA(2) = MA2 C C Check the result if it is near overflow or underflow. C IF (NCASE.EQ.1) THEN IF (X.LE.PMAX/(XBASE*XBASE)) THEN X = X*XBASE*XBASE ELSE KFLAG = -4 X = DBLE(RUNKNO) CALL FMWARN ENDIF ELSE IF (NCASE.EQ.2) THEN IF (X.GE.(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 FMMI(MA,IVAL) C C IVAL = MA. Internal FM to integer conversion routine. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) INTEGER IVAL C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER J,KA,KB,LARGE,N1 C KFLAG = 0 N1 = NDIG + 1 LARGE = INT(INTMAX/MBASE) IVAL = 0 IF (MA(1).LE.0) THEN IF (MA(2).NE.0) KFLAG = 2 RETURN ENDIF C KB = INT(MA(1)) + 1 IVAL = INT(ABS(MA(2))) IF (KB.GE.3) THEN DO 110 J = 3, KB IF (IVAL.GT.LARGE) THEN KFLAG = -4 IF (MA(1).NE.MUNKNO) CALL FMWARN IVAL = IUNKNO RETURN ENDIF IF (J.LE.N1) THEN IVAL = IVAL*INT(MBASE) IF (IVAL.GT.INTMAX-MA(J)) THEN KFLAG = -4 IF (MA(1).NE.MUNKNO) CALL FMWARN IVAL = IUNKNO RETURN ELSE IVAL = IVAL + INT(MA(J)) ENDIF ELSE IVAL = IVAL*INT(MBASE) ENDIF 110 CONTINUE ENDIF C IF (MA(2).LT.0) IVAL = -IVAL C C Check to see if MA is an integer. C KA = KB + 1 IF (KA.LE.N1) THEN DO 120 J = KA, N1 IF (MA(J).NE.0) THEN KFLAG = 2 RETURN ENDIF 120 CONTINUE ENDIF C RETURN END SUBROUTINE FMMIN(MA,MB,MC) C C MC = MIN(MA,MB) C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER KWRNSV LOGICAL FMCOMP C KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMMIN ' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MB,2) C KWRNSV = KWARN KWARN = 0 IF (MA(1).EQ.MUNKNO .OR. MB(1).EQ.MUNKNO) THEN CALL FMIM(0,MC) MC(1) = MUNKNO MC(2) = 1 MC(0) = NINT(NDIG*ALOGM2) KFLAG = -4 ELSE IF (FMCOMP(MA,'GT',MB)) THEN CALL FMEQ(MB,MC) ELSE CALL FMEQ(MA,MC) ENDIF C KWARN = KWRNSV IF (NTRACE.NE.0) CALL FMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMMOD(MA,MB,MC) C C MC = MA(MOD MB). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMMOD: M01 - M03 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCA,MACCB,MACMAX,MVB,MVC,MVY,MVZ,MXSAVE INTEGER J,K,KASAVE,KB,KE,KN,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV LOGICAL FMCOMP C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MB(1)).GT.MEXPAB) THEN CALL FMENTR('FMMOD ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMMOD ' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MB,2) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 IF (MB(1).EQ.MEXPOV .OR. MB(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MB,MC,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF KWRNSV = KWARN KWARN = 0 MACCA = MA(0) MACCB = MB(0) C IF (MB(1).GT.MA(1) .AND. MB(2).NE.0) THEN CALL FMEQ2(MA,M01,NDSAVE,NDIG,0) M01(0) = NINT(NDIG*ALOGM2) ELSE C C Special cases when MB is a small integer. C CALL FMEQ2(MA,M02,NDSAVE,NDIG,0) M02(0) = NINT(NDIG*ALOGM2) CALL FMEQ2(MB,M03,NDSAVE,NDIG,0) M03(0) = NINT(NDIG*ALOGM2) C CALL FMM2I(M03,KB) IF (KFLAG.EQ.0 .AND. KB.LT.MXBASE) THEN IF (KB.EQ.1 .OR. KB.EQ.-1) THEN IF (M02(1).GE.NDIG) THEN CALL FMI2M(0,M01) GO TO 170 ELSE CALL FMINT(M02,M03) CALL FMSUB(M02,M03,M01) GO TO 170 ENDIF ELSE IF (M02(1).EQ.MEXPOV .OR. KB.EQ.0) THEN KFLAG = -4 KWARN = KWRNSV KACCSW = KASAVE MXEXP = MXSAVE CALL FMWARN MC(1) = MUNKNO MC(2) = 1 MC(0) = NINT(NDIG*ALOGM2) DO 110 J = 2, NDSAVE MC(J+1) = 0 110 CONTINUE NDIG = NDSAVE IF (NTRACE.NE.0) CALL FMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN ELSE IF (M02(1).GT.NDIG.AND.MOD(INT(MBASE),KB).EQ.0) THEN CALL FMI2M(0,M01) GO TO 170 ENDIF IF (M02(1).LT.NDIG) THEN DO 120 J = INT(M02(1))+1, NDIG+1 IF (M02(J).NE.0) GO TO 150 120 CONTINUE ENDIF KE = MIN(INT(M02(1)),NDIG) MVB = KB MVC = MOD(M02(2),MVB) DO 130 J = 3, KE+1 MVC = MOD(MVC*MBASE+M02(J),MVB) 130 CONTINUE IF (MVC.EQ.0) THEN CALL FMI2M(0,M01) GO TO 170 ENDIF KN = INT(M02(1)) - KE MVY = MOD(MBASE,MVB) MVZ = 1 IF (MOD(KN,2).EQ.1) MVZ = MVY C IF (MVY.NE.1) THEN 140 KN = KN/2 MVY = MOD(MVY*MVY,MVB) IF (MOD(KN,2).EQ.1) MVZ = MOD(MVZ*MVY,MVB) IF (KN.GT.1) GO TO 140 ENDIF MVZ = MOD(MVZ*MVC,MVB) KE = INT(MVZ) CALL FMI2M(KE,M01) GO TO 170 ENDIF C C General case. C 150 IF (MA(2).NE.0) THEN NDIG = NDIG + INT(MA(1)-MB(1)) ENDIF IF (NDIG.GT.NDG2MX .OR. MB(2).EQ.0) THEN KFLAG = -9 IF (MA(1).EQ.MEXPOV .OR. MB(1).EQ.MEXPUN .OR. MB(2).EQ.0) * KFLAG = -4 KWARN = KWRNSV KACCSW = KASAVE MXEXP = MXSAVE CALL FMWARN MC(1) = MUNKNO MC(2) = 1 MC(0) = NINT(NDIG*ALOGM2) DO 160 J = 2, NDSAVE MC(J+1) = 0 160 CONTINUE NDIG = NDSAVE IF (NTRACE.NE.0) CALL FMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN ENDIF C CALL FMEQ2(MA,M02,NDSAVE,NDIG,0) M02(0) = NINT(NDIG*ALOGM2) CALL FMEQ2(MB,M03,NDSAVE,NDIG,0) M03(0) = NINT(NDIG*ALOGM2) C 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) C C Due to rounding, M01 may not be between 0 and MB here. C NTRSAV = NTRACE NTRACE = 0 IF (FMCOMP(M01,'GE',M03)) THEN NTRACE = NTRSAV CALL FMSUB(M01,M03,M01) ENDIF NTRACE = NTRSAV IF (M01(2).LT.0) CALL FMADD(M01,M03,M01) IF (MA(2).LT.0 .AND. M01(1).NE.MUNKNO) M01(2) = -M01(2) ENDIF C 170 IF (KFLAG.EQ.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 FMMOVE(MW,MA) C C Move a result from a work area (MW) to MA. C C If the result has MW(2)=0, then it is shifted and the exponent C adjusted when it is moved to MA. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2 + 1 , LUNPCK = (6*NDIGMX)/5 + 20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000 + 6 ) C DOUBLE PRECISION MA(0:LUNPCK),MW(LMWA) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER J,N1,N2 C IF (MW(2).NE.0) THEN N1 = NDIG + 1 C C Major (Inner Loop) C DO 110 J = 1, N1 MA(J) = MW(J) 110 CONTINUE ELSE N2 = NDIG + 2 DO 120 J = 3, N2 MA(J-1) = MW(J) 120 CONTINUE IF (MA(2).NE.0) THEN MA(1) = MW(1) - 1 ELSE MA(1) = 0 ENDIF ENDIF C IF (ABS(MA(1)).GT.MXEXP) CALL FMTRAP(MA) C RETURN END SUBROUTINE FMMPY(MA,MB,MC) C C MC = MA * MB C C When one of the numbers MA, MB is known to have more zero digits C (base MBASE) than the other, it is faster if MB is the one with C more zero digits. C C This routine performs the trace printing for multiplication. C FMMPY2 is used to do the arithmetic. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2 + 1 , LUNPCK = (6*NDIGMX)/5 + 20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000 + 6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'FMMPY ' CALL FMNTR(2,MA,MB,2) C CALL FMMPY2(MA,MB,MC) C CALL FMNTR(1,MC,MC,1) ELSE CALL FMMPY2(MA,MB,MC) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMMPY2(MA,MB,MC) C C Internal multiplication routine. MC = MA * MB C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2 + 1 , LUNPCK = (6*NDIGMX)/5 + 20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000 + 6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MA2,MACCA,MACCB,MB2,MD2B,MR INTEGER J,KRESLT,KSHIFT,N1,NGUARD,NZMA,NZMB C IF (MBLOGS.NE.MBASE) CALL FMCONS MACCA = MA(0) MACCB = MB(0) IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MB(1)).GT.MEXPAB .OR. * KDEBUG.EQ.1) THEN CALL FMARGS('FMMPY ',2,MA,MB,KRESLT) IF (KRESLT.NE.0) THEN NCALL = NCALL + 1 NAMEST(NCALL) = 'FMMPY ' CALL FMRSLT(MA,MB,MC,KRESLT) NCALL = NCALL - 1 RETURN ENDIF ELSE IF (MA(2).EQ.0 .OR. MB(2).EQ.0) THEN CALL FMIM(0,MC) MC(0) = MIN(MACCA,MACCB) RETURN ENDIF KFLAG = 0 C C Save the sign of MA and MB and then work only with C positive numbers. C MA2 = MA(2) MB2 = MB(2) MA(2) = ABS(MA(2)) MB(2) = ABS(MB(2)) C C NGUARD is the number of guard digits used. C IF (NCALL.GT.1) THEN NGUARD = NGRD22 IF (NGUARD.GT.NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 IF (NGUARD.GT.NDIG) NGUARD = NDIG ENDIF IF (MA(2)*MB(2).LT.MBASE .AND. NGUARD.LT.3) NGUARD = 3 C N1 = NDIG + 1 C C If there is a good chance of finding several zero digits, C see which number has more zero digits. C IF (NDIG.GE.6*MBASE) THEN NZMA = 0 NZMB = 0 DO 110 J = 2, N1 IF (MA(J).EQ.0) NZMA = NZMA + 1 IF (MB(J).EQ.0) NZMB = NZMB + 1 110 CONTINUE C C It is faster if the second argument is the one with C more zero digits. C IF (NZMA.GT.NZMB) THEN CALL FMMPY3(MB,MA,NGUARD,KSHIFT) ELSE CALL FMMPY3(MA,MB,NGUARD,KSHIFT) ENDIF ELSE CALL FMMPY3(MA,MB,NGUARD,KSHIFT) ENDIF C C The multiplication is complete. Round the result, C move it to MC, and append the correct sign. C MA(2) = MA2 MB(2) = MB2 MR = 2*MWA(NDIG+2+KSHIFT) + 1 IF (MR.GE.MBASE) THEN IF (MR-1.GT.MBASE .AND. MWA(N1+KSHIFT).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.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) C IF (KFLAG.LT.0) THEN NAMEST(NCALL) = 'FMMPY ' CALL FMWARN ENDIF C IF (MA2*MB2.LT.0) MC(2) = -MC(2) C IF (KACCSW.EQ.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 RETURN END SUBROUTINE FMMPY3(MA,MB,NGUARD,KSHIFT) C C Internal multiplication of MA*MB. The result is returned in MWA. C Both MA and MB are positive. C C NGUARD is the number of guard digits that will be used. C KSHIFT = 1 is returned if a left shift is pending (i.e., MWA(2)=0). C The shift will be done in FMMOVE. KSHIFT = 0 is returned C if no shift is pending. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2 + 1 , LUNPCK = (6*NDIGMX)/5 + 20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000 + 6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) INTEGER NGUARD,KSHIFT C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C DOUBLE PRECISION MAXMWA,MBJ,MBKJ,MBM1,MBNORM,MK,MKT,MMAX,MT INTEGER J,JM1,K,KB,KI,KJ,KL,KNZ,KWA,L,N1 C N1 = NDIG + 1 MWA(1) = MA(1) + MB(1) L = N1 + NGUARD MWA(L+1) = 0 C C The multiplication loop begins here. C C MBNORM is the minimum number of digits that can be C multiplied before normalization is required. C MAXMWA is an upper bound on the size of values in MWA C divided by (MBASE-1). It is used to determine C whether to normalize before the next digit is C multiplied. C MBM1 = MBASE - 1 MBNORM = DINT(MAXINT/(MBM1*MBM1)) MMAX = INTMAX - MBASE MMAX = MIN(DINT(MAXINT/MBM1 - MBM1),MMAX) IF (MBNORM.GT.1) THEN MBJ = MB(2) C C Count the trailing zeros in MA. C IF (MA(N1).NE.0) THEN KNZ = N1 ELSE DO 110 J = NDIG, 2, -1 IF (MA(J).NE.0) THEN KNZ = J GO TO 120 ENDIF 110 CONTINUE ENDIF C 120 MWA(2) = 0 DO 130 K = NDIG+2, L MWA(K) = 0 130 CONTINUE C C (Inner Loop) C DO 140 K = 2, N1 MWA(K+1) = MA(K)*MBJ 140 CONTINUE MAXMWA = MBJ DO 170 J = 3, N1 MBJ = MB(J) IF (MBJ.NE.0) THEN MAXMWA = MAXMWA + MBJ JM1 = J - 1 KL = MIN(KNZ,L-JM1) C C Major (Inner Loop) C DO 150 K = J+1, J+KL-1 MWA(K) = MWA(K) + MA(K-JM1)*MBJ 150 CONTINUE ENDIF C IF (MAXMWA.GT.MMAX) THEN MAXMWA = 0 C C Here normalization is only required for the C range of digits currently changing in MWA. C DO 160 KB = JM1+KL, JM1+2, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE 160 CONTINUE ENDIF 170 CONTINUE C C Perform the final normalization. (Inner Loop) C DO 180 KB = L, 3, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE 180 CONTINUE C ELSE C C If normalization must be done for each digit, combine C the two loops and normalize as the digits are multiplied. C DO 190 J = 2, L MWA(J) = 0 190 CONTINUE KJ = NDIG + 2 DO 210 J = 2, N1 KJ = KJ - 1 MBKJ = MB(KJ) IF (MBKJ.EQ.0) GO TO 210 KL = L - KJ + 1 IF (KL.GT.N1) KL = N1 KI = KL + 2 KWA = KL+ KJ + 1 MK = 0 DO 200 K = 2, KL MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MK MK = INT (MT/MBASE) MWA(KWA-K) = MT - MBASE*MK 200 CONTINUE MWA(KWA-KL-1) = MK 210 CONTINUE C ENDIF C C Set KSHIFT = 1 if a shift left is necessary. C IF (MWA(2).EQ.0) THEN KSHIFT = 1 RETURN ELSE KSHIFT = 0 RETURN ENDIF C END SUBROUTINE FMMPYD(MA,MB,MC,MD,ME) C C Double multiplication routine. MD = MA * MB, ME = MA * MC C C It is usually slightly faster to do two multiplications that C have a common factor with one call. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2 + 1 , LUNPCK = (6*NDIGMX)/5 + 20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000 + 6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK), * MD(0:LUNPCK),ME(0:LUNPCK) C DOUBLE PRECISION MWD,MWE C COMMON /FMWA/ MWD(LMWA),MWE(LMWA) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C 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,K,KB,KI,KJ,KL,KNZ,KOVUN,KSHIFT,KWA,L,N1,NGUARD C NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'FMMPYD' CALL FMNTR(2,MA,MB,2) IF (ABS(NTRACE).GE.2 .AND. NCALL.LE.LVLTRC) THEN IF (NTRACE.LT.0) THEN CALL FMNTRJ(MC,NDIG) ELSE CALL FMPRNT(MC) ENDIF ENDIF ENDIF C IF (MBLOGS.NE.MBASE) CALL FMCONS MACCA = MA(0) MACCB = MB(0) MACCC = MC(0) IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MB(1)).GT.MEXPAB .OR. * ABS(MC(1)).GT.MEXPAB) THEN KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN .OR. * MB(1).EQ.MEXPOV .OR. MB(1).EQ.MEXPUN .OR. * MC(1).EQ.MEXPOV .OR. MC(1).EQ.MEXPUN) KOVUN = 1 IF (MA(1).EQ.MUNKNO .OR. MB(1).EQ.MUNKNO .OR. * MC(1).EQ.MUNKNO) KOVUN = 2 NCALL = NCALL + 1 CALL FMMPY2(MA,MB,MWD) KB = KFLAG CALL FMMPY2(MA,MC,ME) NCALL = NCALL - 1 IF (((KFLAG.LT.0 .OR. KB.LT.0) .AND. KOVUN.EQ.0) .OR. * ((KFLAG.EQ.-4 .OR. KB.EQ.-4) .AND. KOVUN.EQ.1)) THEN IF (KFLAG.EQ.-4 .OR. KB.EQ.-4) THEN KFLAG = -4 ELSE IF (KFLAG.EQ.-5 .OR. KB.EQ.-5) THEN KFLAG = -5 ELSE KFLAG = MIN(KFLAG,KB) ENDIF NAMEST(NCALL) = 'FMMPYD' CALL FMWARN ENDIF CALL FMEQ(MWD,MD) GO TO 220 ENDIF IF (MA(2).EQ.0) THEN CALL FMIM(0,MD) MD(0) = MIN(MACCA,MACCB) CALL FMIM(0,ME) ME(0) = MIN(MACCA,MACCC) GO TO 220 ENDIF IF (MB(2).EQ.0) THEN CALL FMMPY2(MA,MC,ME) CALL FMIM(0,MD) MD(0) = MIN(MACCA,MACCB) GO TO 220 ENDIF IF (MC(2).EQ.0) THEN CALL FMMPY2(MA,MB,MD) CALL FMIM(0,ME) ME(0) = MIN(MACCA,MACCC) GO TO 220 ENDIF KFLAG = 0 C C NGUARD is the number of guard digits used. C IF (NCALL.GT.1) THEN NGUARD = NGRD22 IF (NGUARD.GT.NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 IF (NGUARD.GT.NDIG) NGUARD = NDIG ENDIF IF ((MA(2)*MB(2).LT.MBASE .OR. MA(2)*MC(2).LT.MBASE) * .AND. NGUARD.LT.3) NGUARD = 3 C C Save the sign of MA, MB, and MC and then C work only with positive numbers. C MA2 = MA(2) MB2 = MB(2) MC2 = MC(2) MA(2) = ABS(MA(2)) MB(2) = ABS(MB(2)) MC(2) = ABS(MC(2)) C 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 C C The multiplication loop begins here. C C MBNORM is the minimum number of digits that can be C multiplied before normalization is required. C MAXMWA is an upper bound on the size of values in MWA C divided by (MBASE-1). It is used to determine C whether to normalize before the next digit is C multiplied. C MBM1 = MBASE - 1 MBNORM = DINT(MAXINT/(MBM1*MBM1)) MMAX = INTMAX - MBASE MMAX = MIN(DINT(MAXINT/MBM1 - MBM1),MMAX) IF (MBNORM.GT.1) THEN MBJ = MB(2) MCJ = MC(2) C C Count the trailing zeros in MA. C IF (MA(N1).NE.0) THEN KNZ = N1 ELSE DO 110 J = NDIG, 2, -1 IF (MA(J).NE.0) THEN KNZ = J GO TO 120 ENDIF 110 CONTINUE ENDIF C 120 MWA(2) = 0 MWD(2) = 0 DO 130 K = NDIG+2, L MWA(K) = 0 MWD(K) = 0 130 CONTINUE C C (Inner Loop) C DO 140 K = 2, N1 MTEMP = MA(K) MWA(K+1) = MTEMP*MBJ MWD(K+1) = MTEMP*MCJ 140 CONTINUE IF (MBJ.GT.MCJ) THEN MAXMWA = MBJ ELSE MAXMWA = MCJ ENDIF DO 170 J = 3, N1 MBJ = MB(J) MCJ = MC(J) IF (MBJ.GT.MCJ) THEN MAXMWA = MAXMWA + MBJ ELSE MAXMWA = MAXMWA + MCJ ENDIF JM1 = J - 1 KL = MIN(KNZ,L-JM1) C C Major (Inner Loop) C DO 150 K = J+1, J+KL-1 MTEMP = MA(K-JM1) MWA(K) = MWA(K) + MTEMP*MBJ MWD(K) = MWD(K) + MTEMP*MCJ 150 CONTINUE C IF (MAXMWA.GT.MMAX) THEN MAXMWA = 0 C C Here normalization is only required for the C range of digits currently changing in MWA. C DO 160 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 160 CONTINUE ENDIF 170 CONTINUE C C Perform the final normalization. (Inner Loop) C DO 180 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 180 CONTINUE C ELSE C C If normalization must be done for each digit, combine C the two loops and normalize as the digits are multiplied. C DO 190 J = 2, L MWA(J) = 0 MWD(J) = 0 190 CONTINUE KJ = NDIG + 2 DO 210 J = 2, N1 KJ = KJ - 1 MBKJ = MB(KJ) MCKJ = MC(KJ) KL = L - KJ + 1 IF (KL.GT.N1) KL = N1 KI = KL + 2 KWA = KL+ KJ + 1 MKB = 0 MKC = 0 DO 200 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 200 CONTINUE MWA(KWA-KL-1) = MKB MWD(KWA-KL-1) = MKC 210 CONTINUE C ENDIF C C Set KSHIFT = 1 if a shift left is necessary. C IF (MWA(2).EQ.0) THEN KSHIFT = 1 ELSE KSHIFT = 0 ENDIF C C The multiplications are complete. C MA(2) = MA2 MB(2) = MB2 MC(2) = MC2 MR = 2*MWA(NDIG+2+KSHIFT) + 1 IF (MR.GE.MBASE) THEN IF (MR-1.GT.MBASE .AND. MWA(N1+KSHIFT).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.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) C IF (MWD(2).EQ.0) THEN KSHIFT = 1 ELSE KSHIFT = 0 ENDIF MR = 2*MWD(NDIG+2+KSHIFT) + 1 IF (MR.GE.MBASE) THEN IF (MR-1.GT.MBASE .AND. MWD(N1+KSHIFT).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.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) C IF (KFLAG.LT.0) THEN NAMEST(NCALL) = 'FMMPYD' CALL FMWARN ENDIF C IF (MA2*MB2.LT.0) MD(2) = -MD(2) IF (MA2*MC2.LT.0) ME(2) = -ME(2) C IF (KACCSW.EQ.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 C 220 IF (NTRACE.NE.0) THEN CALL FMNTR(1,MD,MD,1) IF (ABS(NTRACE).GE.1 .AND. NCALL.LE.LVLTRC) THEN IF (NTRACE.LT.0) THEN CALL FMNTRJ(ME,NDIG) ELSE CALL FMPRNT(ME) ENDIF ENDIF ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMMPYE(MA,MB,MC,MD,ME,MF,MG) C C Triple multiplication routine. C C ME = MA * MB, MF = MA * MC, MG = MA * MD C C It is usually slightly faster to do three multiplications that C have a common factor with one call. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2 + 1 , LUNPCK = (6*NDIGMX)/5 + 20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000 + 6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK), * MD(0:LUNPCK),ME(0:LUNPCK),MF(0:LUNPCK), * MG(0:LUNPCK) C DOUBLE PRECISION MWD,MWE C COMMON /FMWA/ MWD(LMWA),MWE(LMWA) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C 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,K,KB,KI,KJ,KL,KNZ,KOVUN,KSHIFT,KWA,L,N1,NGUARD C NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'FMMPYE' CALL FMNTR(2,MA,MB,2) IF (ABS(NTRACE).GE.2 .AND. NCALL.LE.LVLTRC) THEN IF (NTRACE.LT.0) THEN CALL FMNTRJ(MC,NDIG) CALL FMNTRJ(MD,NDIG) ELSE CALL FMPRNT(MC) CALL FMPRNT(MD) ENDIF ENDIF ENDIF C IF (MBLOGS.NE.MBASE) CALL FMCONS MACCA = MA(0) MACCB = MB(0) MACCC = MC(0) MACCD = MD(0) IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MB(1)).GT.MEXPAB .OR. * ABS(MC(1)).GT.MEXPAB .OR. ABS(MD(1)).GT.MEXPAB) THEN KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN .OR. * MB(1).EQ.MEXPOV .OR. MB(1).EQ.MEXPUN .OR. * MC(1).EQ.MEXPOV .OR. MC(1).EQ.MEXPUN .OR. * MD(1).EQ.MEXPOV .OR. MD(1).EQ.MEXPUN) KOVUN = 1 IF (MA(1).EQ.MUNKNO .OR. MB(1).EQ.MUNKNO .OR. * MC(1).EQ.MUNKNO .OR. MD(1).EQ.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.LT.0 .OR. KB.LT.0 .OR. KJ.LT.0) .AND. KOVUN.EQ.0) * .OR. ((KFLAG.EQ.-4 .OR. KB.EQ.-4 .OR. KJ.EQ.-4) .AND. * KOVUN.EQ.1)) THEN IF (KFLAG.EQ.-4 .OR. KB.EQ.-4 .OR. KJ.EQ.-4) THEN KFLAG = -4 ELSE IF (KFLAG.EQ.-5 .OR. KB.EQ.-5 .OR. KJ.EQ.-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 220 ENDIF IF (MA(2).EQ.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 220 ENDIF IF (MB(2).EQ.0 .OR. MC(2).EQ.0 .OR. MD(2).EQ.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 220 ENDIF KFLAG = 0 C C NGUARD is the number of guard digits used. C IF (NCALL.GT.1) THEN NGUARD = NGRD22 IF (NGUARD.GT.NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 IF (NGUARD.GT.NDIG) NGUARD = NDIG ENDIF IF ((MA(2)*MB(2).LT.MBASE .OR. MA(2)*MC(2).LT.MBASE .OR. * MA(2)*MD(2).LT.MBASE) .AND. NGUARD.LT.3) NGUARD = 3 C C Save the signs and then work only with positive numbers. C 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)) C 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 C C The multiplication loop begins here. C C MBNORM is the minimum number of digits that can be C multiplied before normalization is required. C MAXMWA is an upper bound on the size of values in MWA C divided by (MBASE-1). It is used to determine C whether to normalize before the next digit is C multiplied. C MBM1 = MBASE - 1 MBNORM = DINT(MAXINT/(MBM1*MBM1)) MMAX = INTMAX - MBASE MMAX = MIN(DINT(MAXINT/MBM1 - MBM1),MMAX) IF (MBNORM.GT.1) THEN MBJ = MB(2) MCJ = MC(2) MDJ = MD(2) C C Count the trailing zeros in MA. C IF (MA(N1).NE.0) THEN KNZ = N1 ELSE DO 110 J = NDIG, 2, -1 IF (MA(J).NE.0) THEN KNZ = J GO TO 120 ENDIF 110 CONTINUE ENDIF C 120 MWA(2) = 0 MWD(2) = 0 MWE(2) = 0 DO 130 K = NDIG+2, L MWA(K) = 0 MWD(K) = 0 MWE(K) = 0 130 CONTINUE C C (Inner Loop) C DO 140 K = 2, N1 MTEMP = MA(K) MWA(K+1) = MTEMP*MBJ MWD(K+1) = MTEMP*MCJ MWE(K+1) = MTEMP*MDJ 140 CONTINUE MAXMWA = MBJ IF (MCJ.GT.MAXMWA) MAXMWA = MCJ IF (MDJ.GT.MAXMWA) MAXMWA = MDJ DO 170 J = 3, N1 MBJ = MB(J) MCJ = MC(J) MDJ = MD(J) MAXJ = MBJ IF (MCJ.GT.MAXJ) MAXJ = MCJ IF (MDJ.GT.MAXJ) MAXJ = MDJ MAXMWA = MAXMWA + MAXJ JM1 = J - 1 KL = MIN(KNZ,L-JM1) C C Major (Inner Loop) C DO 150 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 150 CONTINUE C IF (MAXMWA.GT.MMAX) THEN MAXMWA = 0 C C Here normalization is only required for the C range of digits currently changing in MWA. C DO 160 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 160 CONTINUE ENDIF 170 CONTINUE C C Perform the final normalization. (Inner Loop) C DO 180 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 180 CONTINUE C ELSE C C If normalization must be done for each digit, combine C the two loops and normalize as the digits are multiplied. C DO 190 J = 2, L MWA(J) = 0 MWD(J) = 0 MWE(J) = 0 190 CONTINUE KJ = NDIG + 2 DO 210 J = 2, N1 KJ = KJ - 1 MBKJ = MB(KJ) MCKJ = MC(KJ) MDKJ = MD(KJ) KL = L - KJ + 1 IF (KL.GT.N1) KL = N1 KI = KL + 2 KWA = KL+ KJ + 1 MKB = 0 MKC = 0 MKD = 0 DO 200 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 200 CONTINUE MWA(KWA-KL-1) = MKB MWD(KWA-KL-1) = MKC MWE(KWA-KL-1) = MKD 210 CONTINUE C ENDIF C C Set KSHIFT = 1 if a shift left is necessary. C IF (MWA(2).EQ.0) THEN KSHIFT = 1 ELSE KSHIFT = 0 ENDIF C C The multiplications are complete. C MA(2) = MA2 MB(2) = MB2 MC(2) = MC2 MD(2) = MD2 MR = 2*MWA(NDIG+2+KSHIFT) + 1 IF (MR.GE.MBASE) THEN IF (MR-1.GT.MBASE .AND. MWA(N1+KSHIFT).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.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) C IF (MWD(2).EQ.0) THEN KSHIFT = 1 ELSE KSHIFT = 0 ENDIF MR = 2*MWD(NDIG+2+KSHIFT) + 1 IF (MR.GE.MBASE) THEN IF (MR-1.GT.MBASE .AND. MWD(N1+KSHIFT).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.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) C IF (MWE(2).EQ.0) THEN KSHIFT = 1 ELSE KSHIFT = 0 ENDIF MR = 2*MWE(NDIG+2+KSHIFT) + 1 IF (MR.GE.MBASE) THEN IF (MR-1.GT.MBASE .AND. MWE(N1+KSHIFT).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.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) C IF (KFLAG.LT.0) THEN NAMEST(NCALL) = 'FMMPYE' CALL FMWARN ENDIF C IF (MA2*MB2.LT.0) ME(2) = -ME(2) IF (MA2*MC2.LT.0) MF(2) = -MF(2) IF (MA2*MD2.LT.0) MG(2) = -MG(2) C IF (KACCSW.EQ.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 C 220 IF (NTRACE.NE.0) THEN CALL FMNTR(1,ME,ME,1) IF (ABS(NTRACE).GE.1 .AND. NCALL.LE.LVLTRC) THEN IF (NTRACE.LT.0) THEN CALL FMNTRJ(MF,NDIG) CALL FMNTRJ(MG,NDIG) ELSE CALL FMPRNT(MF) CALL FMPRNT(MG) ENDIF ENDIF ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMMPYI(MA,IVAL,MB) C C MB = MA * IVAL C C Multiply FM number MA by one word integer IVAL. C C This routine is faster than FMMPY when IVAL*MBASE is a C one word integer. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) INTEGER IVAL C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMMPYI: M01 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MA2,MACCA,MCARRY,MD2B,MKT,MLR,MVAL INTEGER J,KA,KB,KC,KSHIFT,N1,NGUARD,NMVAL,NV2 C IF (MBLOGS.NE.MBASE) CALL FMCONS MACCA = MA(0) NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'FMMPYI' CALL FMNTR(2,MA,MA,1) CALL FMNTRI(2,IVAL,0) ENDIF KFLAG = 0 N1 = NDIG + 1 C C Check for special cases. C IF (MA(2).EQ.0) THEN CALL FMEQ(MA,MB) IF (NTRACE.NE.0) THEN CALL FMNTR(1,MB,MB,1) ENDIF NCALL = NCALL - 1 RETURN ENDIF C IF (ABS(MA(1)).LT.MEXPOV .AND. ABS(IVAL).GT.1) GO TO 120 C IF (MA(1).EQ.MUNKNO) THEN CALL FMIM(0,MB) MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -4 IF (NTRACE.NE.0) THEN CALL FMNTR(1,MB,MB,1) ENDIF NCALL = NCALL - 1 RETURN ENDIF C IF (IVAL.EQ.0) THEN CALL FMIM(0,MB) IF (NTRACE.NE.0) THEN CALL FMNTR(1,MB,MB,1) ENDIF NCALL = NCALL - 1 RETURN ENDIF C IF (ABS(IVAL).EQ.1) THEN DO 110 J = 0, N1 MB(J) = MA(J) 110 CONTINUE IF (MA(1).EQ.MEXPOV) KFLAG = -5 IF (MA(1).EQ.MEXPUN) KFLAG = -6 MB(2) = MA(2)*IVAL IF (NTRACE.NE.0) THEN CALL FMNTR(1,MB,MB,1) ENDIF NCALL = NCALL - 1 RETURN ENDIF C IF (MA(1).EQ.MEXPOV) THEN MA2 = MA(2) CALL FMIM(0,MB) KFLAG = -5 MB(1) = MEXPOV MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) IF ((MA2.LT.0 .AND. IVAL.GT.0) .OR. * (MA2.GT.0 .AND. IVAL.LT.0)) MB(2) = -1 IF (NTRACE.NE.0) THEN CALL FMNTR(1,MB,MB,1) ENDIF NCALL = NCALL - 1 RETURN ENDIF C IF (MA(1).EQ.MEXPUN) THEN CALL FMIM(0,MB) MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) NAMEST(NCALL) = 'FMMPYI' KFLAG = -4 CALL FMWARN IF (NTRACE.NE.0) THEN CALL FMNTR(1,MB,MB,1) ENDIF NCALL = NCALL - 1 RETURN ENDIF C C Work with positive numbers. C 120 MA2 = MA(2) MA(2) = ABS(MA(2)) MVAL = ABS(IVAL) NMVAL = INT(MVAL) NV2 = NMVAL - 1 C C To leave room for the normalization, shift the product C to the right KSHIFT places in MWA. C KSHIFT = INT((LOG(DBLE(MA(2)+1)*DBLE(MVAL)))/DLOGMB) C C If IVAL is too big use FMMPY. C IF (KSHIFT.GT.NDIG .OR. MVAL.GT.MAXINT/MBASE .OR. * NMVAL.NE.ABS(IVAL) .OR. NV2.NE.ABS(IVAL)-1) THEN CALL FMIM(IVAL,M01) MA(2) = MA2 CALL FMMPY2(MA,M01,MB) IF (NTRACE.NE.0) THEN CALL FMNTR(1,MB,MB,1) ENDIF NCALL = NCALL - 1 RETURN ENDIF C MWA(1) = MA(1) + KSHIFT KA = 2 + KSHIFT KB = N1 + KSHIFT KC = NDIG + 5 DO 130 J = KB, KC MWA(J) = 0 130 CONTINUE C MCARRY = 0 C C This is the main multiplication loop. C DO 140 J = KB, KA, -1 MKT = MA(J-KSHIFT)*MVAL + MCARRY MCARRY = INT (MKT/MBASE) MWA(J) = MKT - MCARRY*MBASE 140 CONTINUE C C Resolve the final carry. C DO 150 J = KA-1, 2, -1 MKT = INT (MCARRY/MBASE) MWA(J) = MCARRY - MKT*MBASE MCARRY = MKT 150 CONTINUE C C Now the first significant digit in the product is in C MWA(2) or MWA(3). Round the result and move it to MB. C MA(2) = MA2 IF (MWA(2).EQ.0) THEN MLR = 2*MWA(NDIG+3) + 1 IF (MLR.GE.MBASE) THEN IF (MLR-1.GT.MBASE .AND. MWA(N1+1).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.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 (MLR.GE.MBASE) THEN IF (MLR-1.GT.MBASE .AND. MWA(N1).LT.MBASE-1) THEN IF (KROUND.NE.0 .OR. NCALL.GT.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) C IF (KFLAG.LT.0) THEN NAMEST(NCALL) = 'FMMPYI' CALL FMWARN ENDIF C C Put the sign on the result. C IF ((IVAL.GT.0 .AND. MA2.LT.0) .OR. (IVAL.LT.0 .AND.MA2.GT.0)) * MB(2) = -MB(2) C IF (KACCSW.EQ.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 C IF (NTRACE.NE.0) THEN CALL FMNTR(1,MB,MB,1) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMMSET(MAXINT,ML,MLD2,MLM1) C C Internal routine to keep some compilers from doing a loop at C the highest precision available and then rounding to the C declared precision. For example, it is used in FMSET while C trying to find the threshold beyond which integers cannot C be represented exactly using (M) precision. C DOUBLE PRECISION MAXINT,ML,MLD2,MLM1 C ML = 2*MAXINT + 1 MLD2 = DINT(ML/2) MLM1 = ML - 1 C RETURN END SUBROUTINE FMNINT(MA,MB) C C MB = NINT(MA) -- MB is returned as the nearest integer to MA. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during FMNINT: M01 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MA2,MXSAVE INTEGER K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (ABS(MA(1)).GT.MEXPAB) THEN CALL FMENTR('FMNINT',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMNINT' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MA,1) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF C KWRNSV = KWARN KWARN = 0 CALL FMEQ2(MA,MB,NDSAVE,NDIG,0) IF (NDSAVE.GT.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.LT.0) MB(2) = -MB(2) ENDIF KWARN = KWRNSV C C Round the result and return. C CALL FMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMNTR(NTR,MA,MB,NARG) C C Print FM numbers in base 10 format using FMOUT for conversion. C This is used for trace output from the FM routines. C C NTR = 1 if a result of an FM call is to be printed. C = 2 to print input argument(s) to an FM call. C C MA - the FM number to be printed. C C MB - an optional second FM number to be printed. C C NARG - the number of arguments. NARG = 1 if only MA is to be C printed, and NARG = 2 if both MA and MB are to be printed. C C C NTRACE and LVLTRC (in COMMON /FMUSER/) control trace printout. C C NTRACE = 0 No printout except warnings and errors. C C NTRACE = 1 The result of each call to one of the routines C is printed in base 10, using FMOUT. C C NTRACE = -1 The result of each call to one of the routines C is printed in internal base MBASE format. C C NTRACE = 2 The input arguments and result of each call to one C of the routines is printed in base 10, using FMOUT. C C NTRACE = -2 The input arguments and result of each call to one C of the routines is printed in base MBASE format. C C LVLTRC defines the call level to which the trace is done. LVLTRC = 1 C means only FM routines called directly by the user are traced, C LVLTRC = K prints traces for FM routines with call levels up C to and including level K. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) INTEGER NTR,NARG C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C CHARACTER *6 NAME C IF (NTRACE.EQ.0) RETURN IF (NCALL.GT.LVLTRC) RETURN IF (NTR.EQ.2 .AND. ABS(NTRACE).EQ.1) RETURN C IF (NTR.EQ.2) THEN NAME = NAMEST(NCALL) WRITE (KW,110) NAME 110 FORMAT(' Input to ',A6) ELSE NAME = NAMEST(NCALL) IF (KFLAG.EQ.0) THEN WRITE (KW,120) NAME,NCALL,INT(MBASE),NDIG 120 FORMAT(' ',A6,15X,'Call level =',I2,5X,'MBASE =', * I10,5X,'NDIG =',I6) ELSE WRITE (KW,130) NAME,NCALL,INT(MBASE),NDIG,KFLAG 130 FORMAT(' ',A6,6X,'Call level =',I2,4X,'MBASE =', * I10,4X,'NDIG =',I6,4X,'KFLAG =',I3) ENDIF ENDIF C C Check for base MBASE internal format trace. C IF (NTRACE.LT.0) THEN CALL FMNTRJ(MA,NDIG) IF (NARG.EQ.2) CALL FMNTRJ(MB,NDIG) ENDIF C C Check for base 10 trace using FMOUT. C IF (NTRACE.GT.0) THEN CALL FMPRNT(MA) C IF (NARG.EQ.2) THEN CALL FMPRNT(MB) ENDIF ENDIF C RETURN END SUBROUTINE FMNTRI(NTR,N,KNAM) C C Internal routine for trace output of integer variables. C C NTR = 1 for output values C 2 for input values C C N Integer to be printed. C C KNAM is positive if the routine name is to be printed. C C IMPLICIT NONE C INTEGER NTR,N,KNAM C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C CHARACTER *6 NAME C IF (NTRACE.EQ.0) RETURN IF (NCALL.GT.LVLTRC) RETURN IF (NTR.EQ.2 .AND. ABS(NTRACE).EQ.1) RETURN C IF (NTR.EQ.2 .AND. KNAM.GT.0) THEN NAME = NAMEST(NCALL) WRITE (KW,110) NAME 110 FORMAT(' Input to ',A6) ENDIF IF (NTR.EQ.1 .AND. KNAM.GT.0) THEN NAME = NAMEST(NCALL) IF (KFLAG.EQ.0) THEN WRITE (KW,120) NAME,NCALL,INT(MBASE),NDIG 120 FORMAT(' ',A6,15X,'Call level =',I2,5X,'MBASE =', * I10,5X,'NDIG =',I6) ELSE WRITE (KW,130) NAME,NCALL,INT(MBASE),NDIG,KFLAG 130 FORMAT(' ',A6,6X,'Call level =',I2,4X,'MBASE =', * I10,4X,'NDIG =',I6,4X,'KFLAG =',I3) ENDIF ENDIF C WRITE (KW,140) N 140 FORMAT(1X,I18) C RETURN END SUBROUTINE FMNTRJ(MA,ND) C C Print trace output in internal base MBASE format. The number to C be printed is in MA. C C ND is the number of base MBASE digits to be printed. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) INTEGER ND C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER *50 FORM INTEGER J,L,N,N1 C N1 = ND + 1 C L = INT(LOG10(DBLE(MBASE-1))) + 2 N = (KSWIDE-23)/L IF (N.GT.10) N = 5*(N/5) IF (ND.LE.N) THEN WRITE (FORM,110) L+2, N-1, L 110 FORMAT(' (1X,I19,I',I2,',',I3,'I',I2,') ') ELSE WRITE (FORM,120) L+2, N-1, L, N, L 120 FORMAT(' (1X,I19,I',I2,',',I3,'I',I2, * '/(22X,',I3,'I',I2,')) ') ENDIF WRITE (KW,FORM) (INT(MA(J)),J=1,N1) C RETURN END SUBROUTINE FMNTRR(NTR,X,KNAM) C C Internal routine for trace output of real variables. C C NTR - 1 for output values C 2 for input values C C X - Double precision value to be printed if NX.EQ.1 C C KNAM - Positive if the routine name is to be printed. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C INTEGER NTR,KNAM DOUBLE PRECISION X C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C CHARACTER *6 NAME C IF (NTRACE.EQ.0) RETURN IF (NCALL.GT.LVLTRC) RETURN IF (NTR.EQ.2 .AND. ABS(NTRACE).EQ.1) RETURN C IF (NTR.EQ.2 .AND. KNAM.GT.0) THEN NAME = NAMEST(NCALL) WRITE (KW,110) NAME 110 FORMAT(' Input to ',A6) ENDIF IF (NTR.EQ.1 .AND. KNAM.GT.0) THEN NAME = NAMEST(NCALL) IF (KFLAG.EQ.0) THEN WRITE (KW,120) NAME,NCALL,INT(MBASE),NDIG 120 FORMAT(' ',A6,15X,'Call level =',I2,5X,'MBASE =', * I10,5X,'NDIG =',I6) ELSE WRITE (KW,130) NAME,NCALL,INT(MBASE),NDIG,KFLAG 130 FORMAT(' ',A6,6X,'Call level =',I2,4X,'MBASE =', * I10,4X,'NDIG =',I6,4X,'KFLAG =',I3) ENDIF ENDIF C WRITE (KW,140) X 140 FORMAT(1X,D30.20) C RETURN END SUBROUTINE FMOUT(MA,LINE,LB) C C Convert a floating multiple precision number to a character array C for output. C C MA is an FM number to be converted to an A1 character C array in base 10 format C LINE is the CHARACTER*1 array in which the result is returned. C LB is the length of LINE. C C JFORM1 and JFORM2 (in COMMON) determine the format of LINE. C C JFORM1 = 0 normal setting ( .314159M+6 ) C = 1 1PE format ( 3.14159M+5 ) C = 2 F format ( 314159.000 ) C C JFORM2 = number of significant digits to display (if JFORM1 = 0, 1) C = number of digits after the decimal point (if JFORM1 = 2) C C If JFORM2.EQ.0 and JFORM1.NE.2 then a default number of C digits is chosen. The default is roughly the full precision C of MA. C C If JFORM2.EQ.0 and JFORM1.EQ.2 then the number is returned in C integer format with no decimal point. Rounding is done as C with other settings, so the value displayed is the nearest C integer to MA. C C If JFORM1.EQ.2 and MA is too large or too small to display in the C requested format, it is converted using JFORM1=0, JFORM2=0. C C LINE should be dimensioned at least LOG10(MBASE)*NDIG + 15 on a C 32-bit machine to allow for up to 10 digit exponents. Replace C 15 by 20 if 48-bit integers are used, 25 for 64-bit integers, .... C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) INTEGER LB CHARACTER LINE(LB) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C CHARACTER NUMB(10),KCHAR,NUNKNO(12),NEXPOV(12),NEXPUN(12) 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 C DATA NUMB /'0','1','2','3','4','5','6','7','8','9'/ DATA NUNKNO/' ',' ',' ','U','N','K','N','O','W','N',' ',' '/ DATA NEXPOV/' ',' ',' ','O','V','E','R','F','L','O','W',' '/ DATA NEXPUN/' ',' ',' ','U','N','D','E','R','F','L','O','W'/ C C To avoid recursion, FMOUT calls only internal arithmetic C routines (FMADD2, FMMPY2, ...), so no trace printout is C done during a call to FMOUT. C KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMOUT ' C C Raise the call stack again, since the internal C routines don't. C NCALL = NCALL + 1 NAMEST(NCALL) = 'FMOUT ' DO 110 J = 1, LB LINE(J) = ' ' 110 CONTINUE C C Check for special cases. C IF (MA(1).EQ.MUNKNO) THEN DO 120 J = 1, 12 LINE(J) = NUNKNO(J) 120 CONTINUE NCALL = NCALL - 2 RETURN ENDIF IF (MA(1).EQ.MEXPOV) THEN DO 130 J = 1, 12 LINE(J) = NEXPOV(J) 130 CONTINUE LINE(2) = '+' IF (MA(2).LT.0) LINE(2) = '-' NCALL = NCALL - 2 RETURN ENDIF IF (MA(1).EQ.MEXPUN) THEN DO 140 J = 1, 12 LINE(J) = NEXPUN(J) 140 CONTINUE LINE(2) = '+' IF (MA(2).LT.0) LINE(2) = '-' NCALL = NCALL - 2 RETURN ENDIF IF (MA(2).EQ.0 .AND. JFORM1.EQ.2 .AND. JFORM2.EQ.0) THEN LINE(2) = '0' NCALL = NCALL - 2 RETURN ENDIF C KASAVE = KACCSW KACCSW = 0 KRSAVE = KROUND KROUND = 1 JF1SAV = JFORM1 JF2SAV = JFORM2 MBSAVE = MBASE NDSAVE = NDIG MXSAVE = MXEXP C C ND is the number of base 10 digits required. C 150 ND = JFORM2 IF (JFORM1.EQ.2 .AND. MA(1).GT.0) ND = JFORM2 + * INT(REAL(MA(1))*LOG10(REAL(MBASE))) + 1 IF (ND.LE.1) THEN K = INT(REAL(NDIG)*LOG10(REAL(MBASE))) ND = MAX(K,JFORM2) ENDIF IF (JFORM2.LE.0 .AND. JFORM1.LE.1) ND = * INT(1.1 + REAL(NDIG-1)*LOG10(REAL(MBASE))) IF (ND.LT.2) ND = 2 C IF (LB.LT.ND+6) THEN IF (JFORM1.EQ.2) THEN JFORM1 = 0 JFORM2 = 0 GO TO 150 ENDIF GO TO 370 ENDIF C C Convert to the base that is the largest power of 10 C less than MXBASE and build the output number. C NPOWER = INT(LOG10(REAL(MXBASE)/4)) MXEXP = MXEXP2 MBASE = 10**NPOWER IF (MBLOGS.NE.MBASE) CALL FMCONS NDIG = ND/NPOWER + 3 IF (NDIG.LT.2) NDIG = 2 IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 NCALL = NCALL - 1 CALL FMWARN NCALL = NCALL + 1 GO TO 370 ENDIF C IF (MA(2).EQ.0) THEN CALL FMIM(0,MS) GO TO 210 ENDIF C C Check to see if MA is already in a base that is a C power of ten. If so, the conversion can be skipped. C K = NPOWER DO 160 J = 1, K MBASE = 10**J IF (MBASE.EQ.MBSAVE) THEN IF (MBLOGS.NE.MBASE) CALL FMCONS NPOWER = J NDIG = ND/NPOWER + 2 IF (NDIG.LT.2) NDIG = 2 IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 NCALL = NCALL - 1 CALL FMWARN NCALL = NCALL + 1 GO TO 370 ENDIF CALL FMEQ2(MA,MS,NDSAVE,NDIG,0) MS(2) = ABS(MS(2)) GO TO 210 ENDIF 160 CONTINUE C IF (MBLOGS.NE.MBASE) CALL FMCONS CALL FMIM(INT(MBSAVE),MD) NDS2 = NDSAVE + 1 CALL FMIM(1,MT) KMT = 1 C C Convert the fraction part of MA to the new base. C KPT = NDS2 + 1 DO 170 J = 3, NDS2 KPT = KPT - 1 IF (MA(KPT).NE.0) GO TO 180 170 CONTINUE C 180 KEXPSH = KPT - 1 KDIGIT = INT(ABS(MA(2))) CALL FMIM(KDIGIT,MS) NDIGMS = NDIG C DO 190 J = 3, KPT KDIGIT = INT(MA(J)) IF (MBSAVE.EQ.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 C IF (KDIGIT.GT.0) THEN IF (KMT.NE.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 190 CONTINUE C C Convert the exponent. C NDIG = NDIGMS CALL FMIM(1,MT) K = ABS(INT(MA(1))-KEXPSH) IF (MOD(K,2).EQ.1) THEN CALL FMEQ(MD,MT) ELSE CALL FMIM(1,MT) ENDIF C 200 K = K/2 M2 = 2 MNDGMS = NDIGMS NDIG = INT(MIN(MNDGMS,MAX(M2,MD(1)*M2))) IF (K.GT.0) CALL FMMPY2(MD,MD,MD) IF (MOD(K,2).EQ.1) THEN NDIG = INT(MIN(MNDGMS,MAX(M2,MT(1)+MD(1)))) CALL FMMPY2(MT,MD,MT) ENDIF IF (K.GT.1) GO TO 200 C NDIG = NDIGMS IF (MA(1)-KEXPSH.LT.0) THEN CALL FMDIV2(MS,MT,MS) ELSE CALL FMMPY2(MS,MT,MS) ENDIF C C Now MS is the value of MA converted to a C power of ten base. C C Convert it to a character string base 10 for output. C C MEXP10 is the base 10 exponent. C KMS2SD is the number of base 10 significant digits C in MS(2). C 210 MS1 = MS(1) 220 MEXP10 = NPOWER*MS(1) KMS2SD = NPOWER K = INT(MBASE) DO 230 J = 1, NPOWER K = K/10 IF (MS(2).LT.K .AND. MS(2).NE.0) THEN MEXP10 = MEXP10 - 1 KMS2SD = KMS2SD - 1 ENDIF 230 CONTINUE C C For printing using JFORM1 = 1, reduce the exponent to C account for the fact that the decimal point and first C significant digit will later be swapped. C IF (JFORM1.EQ.1 .AND. MS(2).NE.0) MEXP10 = MEXP10 - 1 C C Find the position in the unpacked number for rounding. C NWORD is the word in which rounding is done, or zero if C no rounding is necessary. C NWORD is set to -1 if JFORM1 is 2 (F format) but no C significant digits would be printed. This case C defaults to JFORM1 = 0. C NVAL gives the position within that word where rounding C occurs. C NSD1 is the maximum number of base 10 S.D.'s in NWORD C digits of base 10**NPOWER. C NSD2 is the number of base 10 S.D.'s needed to get ND C base 10 digits after the decimal. C NSD2 = ND IF (JFORM1.EQ.2) THEN MSD2 = JFORM2 + MEXP10 IF (MSD2.GT.ND) THEN NSD2 = ND ELSE NSD2 = INT(MSD2) ENDIF NWORD = (NSD2-KMS2SD-1+NPOWER)/NPOWER + 2 IF (NWORD.LT.2) NWORD = -1 IF (NWORD.GT.NDIG) NWORD = 0 IF (NWORD.GE.2 .AND. NSD2.LE.0) NWORD = -1 ELSE NWORD = (ND-KMS2SD-1+NPOWER)/NPOWER + 2 ENDIF NSD1 = KMS2SD + NPOWER*(NWORD-2) IF (NWORD.LT.2) THEN NVAL = 0 ELSE NVAL = 10**(NSD1-NSD2) ENDIF C C Now do the base 10 rounding. C IF (NWORD.GE.2) THEN X = 0.0 IF (NVAL.GT.1) X = MOD(INT(MS(NWORD)),NVAL) IF (NWORD.LT.NDIG+1) THEN X = REAL(DBLE(X) + DBLE(MS(NWORD+1))/DBLE(MBASE)) ENDIF X = X/NVAL IF (X.LT.0.5) GO TO 240 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).GE.MBASE) THEN NWORD1 = NWORD - 1 NWORD2 = NWORD - 2 IF (NWORD.GT.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).NE.MS1 .OR. MS(2).NE.MS2) GO TO 220 ENDIF C C Build the base 10 character string. C 240 IF (MA(2).LT.0) LINE(1) = '-' LINE(2) = '.' K = 10**KMS2SD L = 2 IF (NWORD.EQ.-1) NSD2 = ND DO 250 J = 1, NSD2 K = K/10 IF (K.EQ.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) 250 CONTINUE C KA = NSD2 + 3 KB = ND + 2 IF (KB.GE.KA) THEN DO 260 J = KA, KB LINE(J) = NUMB(1) 260 CONTINUE ENDIF C LINE(ND+3) = CMCHAR LINE(ND+4) = '+' IF (MEXP10.LT.0) LINE(ND+4) = '-' IF (MA(2).EQ.0) LINE(ND+4) = ' ' C C Build the digits of the base 10 exponent backwards, C then reverse them. C NDE = 1 MEXP = ABS(MEXP10) MT10 = 10 DO 280 J = 1, LB MKT = DINT(MEXP/MT10) KDIGIT = INT(MEXP-MKT*MT10) LINE(ND+4+J) = NUMB(KDIGIT+1) MEXP = MKT IF (MEXP.EQ.0) GO TO 290 C IF (ND+5+J.GT.LB) THEN DO 270 K = 1, LB LINE(K) = '*' 270 CONTINUE GO TO 310 ENDIF C NDE = NDE + 1 280 CONTINUE C 290 NDE2 = NDE/2 IF (NDE2.LT.1) GO TO 310 K1 = ND + 4 K2 = ND + 5 + NDE DO 300 J = 1, NDE2 K1 = K1 + 1 K2 = K2 - 1 KCHAR = LINE(K1) LINE(K1) = LINE(K2) LINE(K2) = KCHAR 300 CONTINUE C C If JFORM1 is 1 put the first digit left of the decimal. C 310 IF (JFORM1.EQ.1) THEN KCHAR = LINE(2) LINE(2) = LINE(3) LINE(3) = KCHAR ENDIF C C If JFORM1 is 2 put the number into fixed format. C IF (JFORM1.EQ.2 .AND. JFORM2.GE.0) THEN IF (MEXP10.LE.-JFORM2 .OR. MEXP10+2.GT.LB) THEN JFORM1 = 0 JFORM2 = 0 MBASE = MBSAVE IF (MBLOGS.NE.MBASE) CALL FMCONS NDIG = NDSAVE MXEXP = MXSAVE DO 320 J = 1, LB LINE(J) = ' ' 320 CONTINUE GO TO 150 ENDIF KA = ND + 3 DO 330 J = KA, LB LINE(J) = NUMB(1) 330 CONTINUE C KEXP = INT(MEXP10) IF (MEXP10.GT.0) THEN DO 340 J = 1, KEXP LINE(J+1) = LINE(J+2) 340 CONTINUE LINE(KEXP+2) = '.' ENDIF C IF (MEXP10.LT.0) THEN KEXP = -INT(MEXP10) KA = 3 + KEXP KB = LB + 1 KC = KB - KEXP DO 350 J = KA, LB KB = KB - 1 KC = KC - 1 LINE(KB) = LINE(KC) LINE(KC) = NUMB(1) 350 CONTINUE ENDIF C JDPT = 0 DO 360 J = 1, LB IF (LINE(J).EQ.'.') JDPT = J IF (JDPT.GT.0 .AND. J.GT.JDPT+JFORM2) LINE(J) = ' ' 360 CONTINUE IF (JFORM2.EQ.0 .AND. JDPT.GT.0) LINE(KEXP+2) = ' ' C ENDIF C C Restore values and return C GO TO 390 C C LINE is not big enough to hold the number C of digits specified. C 370 KFLAG = -8 DO 380 J = 1, LB LINE(J) = '*' 380 CONTINUE NCALL = NCALL - 1 CALL FMWARN NCALL = NCALL + 1 C 390 MBASE = MBSAVE IF (MBLOGS.NE.MBASE) CALL FMCONS NDIG = NDSAVE MXEXP = MXSAVE NCALL = NCALL - 2 KACCSW = KASAVE KROUND = KRSAVE JFORM1 = JF1SAV JFORM2 = JF2SAV RETURN END SUBROUTINE FMPACK(MA,MP) C C MA is packed two base NDIG digits per word and returned in MP. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MP(0:LPACK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER J,KP C KP = 2 MP(0) = MA(0) MP(1) = MA(1) MP(2) = ABS(MA(2))*MBASE + MA(3) IF (MA(2).LT.0) MP(2) = -MP(2) IF (NDIG.GE.4) THEN DO 110 J = 4, NDIG, 2 KP = KP + 1 MP(KP) = MA(J)*MBASE + MA(J+1) 110 CONTINUE ENDIF IF (MOD(NDIG,2).EQ.1) MP(KP+1) = MA(NDIG+1)*MBASE RETURN END SUBROUTINE FMPI(MA) C C MA = pi C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during FMPI: M01 - M04 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C CHARACTER *155 STRING INTEGER J,K,KASAVE,NDMB,NDSAVE,NDSV C IF (MBLOGS.NE.MBASE) CALL FMCONS KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMPI ' IF (ABS(NTRACE).GE.2 .AND. NCALL.LE.LVLTRC) THEN WRITE (KW,110) 110 FORMAT(' Input to FMPI') ENDIF KASAVE = KACCSW KACCSW = 0 C C Increase the working precision. C NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = NGRD52 NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN MA(1) = MUNKNO MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) DO 120 J = 2, NDSAVE MA(J+1) = 0 120 CONTINUE GO TO 130 ENDIF ENDIF C C Check to see if pi has previously been computed C in base MBASE with sufficient precision. C IF (MBSPI.EQ.MBASE .AND. NDIGPI.GE.NDIG) THEN IF (NAMEST(NCALL-1).NE.'NOEQ ') THEN KACCSW = KASAVE CALL FMEQ2(MPISAV,MA,NDIGPI,NDSAVE,0) ENDIF ELSE NDMB = INT(150.0*2.302585/ALOGMB) IF (NDMB.GE.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)).GT.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)).GT.10) NDIGPI = 0 ENDIF IF (NAMEST(NCALL-1).NE.'NOEQ ') THEN KACCSW = KASAVE CALL FMEQ2(MPISAV,MA,NDIG,NDSAVE,0) ENDIF NDIG = NDSV ENDIF C 130 NDIG = NDSAVE KACCSW = KASAVE IF (NTRACE.NE.0) CALL FMNTR(1,MA,MA,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMPI2(MPI) C C Internal routine to compute pi. C The formula used is due to S. Ramanujan: C (4n)!(1103+26390n) C 1/pi = (sqrt(8)/9801) * sum(n=0 to infinity) -------------------- C ((n!)**4)(396**(4n)) C The result is returned in MPI. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MPI(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMPI2: M01 - M04 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C DOUBLE PRECISION X DOUBLE PRECISION MX INTEGER NSTACK(19),J,K,KST,LARGE,N,NDIGRD,NDSAVE C IF (MBLOGS.NE.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.GT.MXEXP2) MX = MXEXP2 C 110 N = N + 1 LARGE = INT(MX)/(4*N + 3) J = 4*N + 1 IF (J.GT.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).GT.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 C J = N + 1 LARGE = INT(MXBASE)/J IF (J.GT.LARGE) THEN CALL FMDIVI(M02,J,M02) CALL FMDIVI(M02,J,M02) CALL FMDIVI(M02,J,M02) ELSE IF (J*J.GT.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 C C Break 4/396**4 into 1/(2178*2178*1296). C J = 2178 LARGE = INT(MXBASE)/J IF (J.GT.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 C NDIGRD = NDIG NDIG = NDSAVE CALL FMADD(M03,M04,M04) NDIG = NDIGRD CALL FMMPY(M02,M04,M01) C NDIG = NDSAVE CALL FMADD(MPI,M01,MPI) NDIG = MAX(2,NDSAVE - INT(MPI(1) - M01(1))) IF (KFLAG.NE.1) GO TO 110 NDIG = NDSAVE C CALL FMI2M(8,M02) X = 8 X = SQRT(X) CALL FMDPM(X,M04) CALL FMDIG(NSTACK,KST) DO 120 J = 1, KST NDIG = NSTACK(J) CALL FMDIV(M02,M04,M01) CALL FMADD(M04,M01,M04) CALL FMDIVI(M04,2,M04) 120 CONTINUE M04(0) = NINT(NDIG*ALOGM2) CALL FMI2M(9801,M03) CALL FMMPY(MPI,M04,MPI) CALL FMDIV(M03,MPI,MPI) C RETURN END SUBROUTINE FMPRNT(MA) C C Print MA in base 10 format. C C FMPRNT can be called directly by the user for easy output C in M format. MA is converted using FMOUT and printed. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER *20 FORM INTEGER J,K,KSAVE,L,LAST,LB,ND,NEXP C NCALL = NCALL + 1 NAMEST(NCALL) = 'FMPRNT' KSAVE = KFLAG ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1 IF (ND.LT.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,110) KSWIDE-7 110 FORMAT(' (6X,',I3,'A1) ') DO 120 J = 1, LB IF (CMBUFF(LAST-J).NE.' ' .OR. J.EQ.LB) THEN L = LAST - J WRITE (KW,FORM) (CMBUFF(K),K=1,L) NCALL = NCALL - 1 RETURN ENDIF 120 CONTINUE NCALL = NCALL - 1 RETURN END SUBROUTINE FMPWR(MA,MB,MC) C C MC = MA ** MB C C If MB can be expressed exactly as a one word integer, then FMIPWR is C used. This is much faster when MB is small, and using FMIPWR allows C MA to be negative. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMPWR: M01 - M06 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCA,MACCB,MACMAX,MXSAVE INTEGER IEXTRA,INTMB,J,K,KASAVE,KFL,KOVUN,KRESLT,KWRNSV,NDSAVE C C Convert MB to an integer before changing NDIG. C KWRNSV = KWARN KWARN = 0 CALL FMMI(MB,INTMB) KWARN = KWRNSV KFL = KFLAG C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MB(1)).GT.MEXPAB .OR. * MA(2).LE.0) THEN CALL FMENTR('FMPWR ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMPWR ' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MB,2) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 IF (MB(1).EQ.MEXPOV .OR. MB(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MB,MC,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF C C If the exponent is large or the base is very large, C raise the precision. C IF (MA(1).NE.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.GT.LOG(ALOGMB*REAL(MXEXP2))) THEN IEXTRA = 0 ENDIF C NDIG = NDIG + IEXTRA IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN MC(1) = MUNKNO MC(2) = 1 MC(0) = NINT(NDIG*ALOGM2) DO 110 J = 2, NDSAVE MC(J+1) = 0 110 CONTINUE NDIG = NDIG - IEXTRA CALL FMEXIT(MC,MC,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN ENDIF C C If the exponent is a small integer, call FMIPWR. C KWRNSV = KWARN KWARN = 0 C MACCA = MA(0) MACCB = NINT(NDIG*ALOGM2) CALL FMEQ2(MA,M06,NDSAVE,NDIG,0) M06(0) = NINT(NDIG*ALOGM2) C IF (KFL.EQ.0) THEN CALL FMIPWR(M06,INTMB,MC) ELSE IF (M06(2).LE.0) THEN CALL FMIM(0,MC) MC(1) = MUNKNO MC(2) = 1 MC(0) = NINT(NDIG*ALOGM2) 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 C C Round the result and return. C 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 FMRDC(MA,MB,JSIN,JCOS,JSWAP) C C Reduce MA using various trigonometric identities to an equivalent C angle MB between 0 and 45 degrees. The reduction is done in radians C if KRAD (in common /FMUSER/) is 1, in degrees if KRAD is 0. C JSIN and JCOS are returned +1 or -1 and JSWAP is returned to indicate C that the sin and cos functions have been interchanged as follows: C C JSWAP = 0 means SIN(MA) = JSIN*SIN(MB) C COS(MA) = JCOS*COS(MB) C C JSWAP = 1 means SIN(MA) = JSIN*COS(MB) C COS(MA) = JCOS*SIN(MB) C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) INTEGER JSIN,JCOS,JSWAP C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during FMRDC: M01 - M04 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION X INTEGER J,KASAVE,NDSAVE,NDSV LOGICAL FMCOMP C IF (MBLOGS.NE.MBASE) CALL FMCONS JSIN = 1 JCOS = 1 JSWAP = 0 NDSAVE = NDIG NDIG = NDIG + MAX(0,INT(MA(1))) C C If the argument is too big, return UNKNOWN. C IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) DO 110 J = 2, NDSAVE MB(J+1) = 0 110 CONTINUE NDIG = NDSAVE RETURN ENDIF MA(0) = MA(0) + NINT(ALOGM2*REAL(MAX(0,INT(MA(1))))) C C If MA is less than 1/MBASE, no reduction is needed. C IF (MA(1).LT.0) THEN NDIG = NDSAVE CALL FMEQ(MA,MB) IF (MB(2).LT.0) THEN MB(2) = -MB(2) JSIN = -1 ENDIF RETURN ENDIF C J = 1 IF (KRAD.EQ.1) THEN 120 IF (MBSPI.NE.MBASE .OR. NDIGPI.LT.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).LT.0) JSIN = -1 M04(2) = ABS(M04(2)) IF (M04(1).EQ.0) THEN CALL FMM2DP(M04,X) IF (X.LE.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 C C If the reduced argument is close to zero, then C cancellation has produced an inaccurate value. C Raise NDIG and do the reduction again. C IF (J.EQ.1 .AND. (M04(1).LT.0 .OR. M04(2).EQ.0)) THEN J = 2 IF (M04(2).EQ.0) THEN NDIG = MIN(2*NDIG,NDG2MX) ELSE NDIG = NDIG - INT(M04(1)) ENDIF IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) DO 130 J = 2, NDSAVE MB(J+1) = 0 130 CONTINUE NDIG = NDSAVE RETURN ENDIF JSIN = 1 JCOS = 1 JSWAP = 0 MA(0) = MA(0) + NINT(ALOGM2*REAL(-M04(1))) GO TO 120 ENDIF C ELSE C CALL FMEQ2(MA,M04,NDSAVE,NDIG,0) IF (MA(2).LT.0) JSIN = -1 M04(2) = ABS(M04(2)) IF (M04(1).EQ.0) THEN CALL FMM2DP(M04,X) IF (X.LE.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 C ENDIF C C Round the result and return. C CALL FMEQ2(M04,MB,NDIG,NDSAVE,0) NDIG = NDSAVE RETURN END SUBROUTINE FMREAD(KREAD,MA) C C Read MA on unit KREAD. Multi-line numbers will have '&' as the C last nonblank character on all but the last line. Only one C number is allowed on the line(s). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK) INTEGER KREAD C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER LINE(80) INTEGER J,LB,NDSAVE C IF (MBLOGS.NE.MBASE) CALL FMCONS NCALL = NCALL + 1 NAMEST(NCALL) = 'FMREAD' NDSAVE = NDIG NDIG = MIN(NDG2MX,MAX(NDIG+NGRD52,2)) LB = 0 C 110 READ (KREAD,120,ERR=140,END=140) LINE 120 FORMAT(80A1) C C Scan the line and look for '&' C DO 130 J = 1, 80 IF (LINE(J).EQ.'&') GO TO 110 IF (LINE(J).NE.' ') THEN LB = LB + 1 IF (LB.GT.LMBUFF) THEN KFLAG = -8 GO TO 150 ENDIF CMBUFF(LB) = LINE(J) ENDIF 130 CONTINUE C CALL FMINP(CMBUFF,M01,1,LB) C CALL FMEQ2(M01,MA,NDIG,NDSAVE,0) NDIG = NDSAVE NCALL = NCALL - 1 RETURN C C If there is an error, return UNKNOWN. C 140 KFLAG = -4 150 CALL FMWARN MA(1) = MUNKNO MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) DO 160 J = 2, NDIG MA(J+1) = 0 160 CONTINUE NCALL = NCALL - 1 RETURN END SUBROUTINE FMRND(MW,ND,NGUARD,KSHIFT) C C Round MW to ND digits (base MBASE). C C MW is non-negative and has ND+NGUARD+KSHIFT digits. C C NGUARD is the number of guard digits carried. C KSHIFT is 1 if a left shift is pending when MW(2)=0. C C Round to position MW(ND+1+KSHIFT) using the guard digits C MW(ND+2+KSHIFT), ..., MW(ND+1+NGUARD+KSHIFT). C C This routine is designed to be called only from within the FM C package. The user should call FMEQU to round numbers. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2 + 1 , LUNPCK = (6*NDIGMX)/5 + 20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000 + 6 ) C DOUBLE PRECISION MW(LMWA) INTEGER ND,NGUARD,KSHIFT C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C DOUBLE PRECISION M2,MFACTR,MKT INTEGER J,K,KB,L C IF (KROUND.EQ.0 .AND. NCALL.LE.1) RETURN L = ND + 2 + KSHIFT IF (2*(MW(L)+1).LT.MBASE) RETURN IF (2*MW(L).GT.MBASE) THEN MW(L-1) = MW(L-1) + 1 MW(L) = 0 IF (MW(L-1).LT.MBASE) RETURN GO TO 140 ENDIF C C If the first guard digit gives a value close to 1/2 then C further guard digits must be examined. C M2 = 2 IF (INT(MBASE-DINT(MBASE/M2)*M2).EQ.0) THEN IF (2*MW(L).LT.MBASE) RETURN IF (2*MW(L).EQ.MBASE) THEN IF (NGUARD.GE.2) THEN IF (MBASE.GE.1000) THEN IF (MBASE.LT.1000000) THEN MFACTR = INT(0.5D0+0.6883D0*MBASE) ELSE MFACTR = INT(0.5D0+0.687783D0*MBASE) ENDIF IF (MW(L+1).EQ.MFACTR) RETURN ENDIF DO 110 J = 2, NGUARD IF (MW(L+J-1).GT.0) GO TO 130 110 CONTINUE ENDIF C C Round to even. C IF (INT(MW(L-1)-DINT(MW(L-1)/M2)*M2).EQ.0) RETURN ENDIF ELSE IF (2*MW(L)+1.EQ.MBASE) THEN IF (NGUARD.GE.2) THEN DO 120 J = 2, NGUARD IF (2*(MW(L+J-1)+1).LT.MBASE) RETURN IF (2*MW(L+J-1).GT.MBASE) GO TO 130 120 CONTINUE RETURN ENDIF ENDIF ENDIF C 130 MW(L-1) = MW(L-1) + 1 MW(L) = 0 C C Check whether there was a carry in the rounded digit. C 140 KB = L - 1 IF (KB.GE.3) THEN K = KB + 1 DO 150 J = 3, KB K = K - 1 IF (MW(K).LT.MBASE) RETURN MKT = DINT(MW(K)/MBASE) MW(K-1) = MW(K-1) + MKT MW(K) = MW(K) - MKT*MBASE 150 CONTINUE ENDIF C C If there is a carry in the first digit then the exponent C must be adjusted and the number shifted right. C IF (MW(2).GE.MBASE) THEN IF (KB.GE.4) THEN K = KB + 1 DO 160 J = 4, KB K = K - 1 MW(K) = MW(K-1) 160 CONTINUE ENDIF C MKT = DINT(MW(2)/MBASE) IF (KB.GE.3) MW(3) = MW(2) - MKT*MBASE MW(2) = MKT MW(1) = MW(1) + 1 ENDIF C RETURN END SUBROUTINE FMRPWR(MA,IVAL,JVAL,MB) C C MB = MA ** (IVAL/JVAL) rational exponentiation. C C This routine is faster than FMPWR when IVAL and JVAL are C small integers. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) INTEGER IVAL,JVAL C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMRPWR: M01 - M03 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C 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 C IF (MBLOGS.NE.MBASE) CALL FMCONS NCALL = NCALL + 1 NAMEST(NCALL) = 'FMRPWR' IF (NTRACE.NE.0) THEN CALL FMNTR(2,MA,MA,1) CALL FMNTRI(2,IVAL,0) CALL FMNTRI(2,JVAL,0) ENDIF KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.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) ELSE XVAL = MAX(ABS(IVAL),ABS(JVAL)) K = INT(LOG(XVAL)/ALOGMB + 1.0) NDIG = NDIG + K ENDIF IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 C MA1 = MA(1) MA2 = MA(2) MACCA = MA(0) CALL FMEQ2(MA,M02,NDSAVE,NDIG,0) M02(0) = NINT(NDIG*ALOGM2) C C Use GCD-reduced positive exponents. C IJSIGN = 1 IVAL2 = ABS(IVAL) JVAL2 = ABS(JVAL) IF (IVAL.GT.0 .AND. JVAL.LT.0) IJSIGN = -1 IF (IVAL.LT.0 .AND. JVAL.GT.0) IJSIGN = -1 IF (IVAL2.GT.0 .AND. JVAL2.GT.0) CALL FMGCDI(IVAL2,JVAL2) C C Check for special cases. C 110 IF (MA1.EQ.MUNKNO .OR. JVAL2.EQ.0 .OR. * (IJSIGN.LE.0 .AND. MA2.EQ.0)) THEN CALL FMIM(0,MB) MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -4 GO TO 130 ENDIF C IF (IVAL2.EQ.0) THEN CALL FMIM(1,MB) GO TO 130 ENDIF C IF (JVAL2.EQ.1) THEN CALL FMIPWR(M02,IJSIGN*IVAL2,MB) GO TO 130 ENDIF C IF (MA2.EQ.0) THEN CALL FMEQ(MA,MB) GO TO 130 ENDIF C IF (MA2.LT.0) THEN IF (MOD(JVAL2,2).EQ.0) THEN JVAL2 = 0 GO TO 110 ENDIF ENDIF C IF (MA1.EQ.MEXPOV) THEN IF (IVAL2.LT.JVAL2) THEN JVAL2 = 0 GO TO 110 ENDIF CALL FMIM(0,MB) IF (IJSIGN.EQ.1 .AND. MA2.GT.0) THEN MB(1) = MEXPOV MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -5 ELSE IF (IJSIGN.EQ.-1 .AND. MA2.GT.0) THEN MB(1) = MEXPUN MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -6 ELSE IF (IJSIGN.EQ.1 .AND. MA2.LT.0) THEN IF (MOD(IVAL2,2).EQ.0) THEN MB(1) = MEXPOV MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -5 ELSE MB(1) = MEXPOV MB(2) = -1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -5 ENDIF ELSE IF (IJSIGN.EQ.-1 .AND. MA2.LT.0) THEN IF (MOD(IVAL2,2).EQ.0) THEN MB(1) = MEXPUN MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -6 ELSE MB(1) = MEXPUN MB(2) = -1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -6 ENDIF ENDIF GO TO 130 ENDIF C IF (MA1.EQ.MEXPUN) THEN IF (IVAL2.LT.JVAL2) THEN JVAL2 = 0 GO TO 110 ENDIF CALL FMIM(0,MB) IF (IJSIGN.EQ.1 .AND. MA2.GT.0) THEN MB(1) = MEXPUN MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -6 ELSE IF (IJSIGN.EQ.-1 .AND. MA2.GT.0) THEN MB(1) = MEXPOV MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -5 ELSE IF (IJSIGN.EQ.1 .AND. MA2.LT.0) THEN IF (MOD(IVAL2,2).EQ.0) THEN MB(1) = MEXPUN MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -6 ELSE MB(1) = MEXPUN MB(2) = -1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -6 ENDIF ELSE IF (IJSIGN.EQ.-1 .AND. MA2.LT.0) THEN IF (MOD(IVAL2,2).EQ.0) THEN MB(1) = MEXPOV MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -5 ELSE MB(1) = MEXPOV MB(2) = -1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -5 ENDIF ENDIF GO TO 130 ENDIF C C Invert MA if MA > 1 and IVAL or JVAL is large. C INVERT = 0 IF (MA(1).GT.0) THEN IF (IVAL.GT.5 .OR. JVAL.GT.5) THEN INVERT = 1 CALL FMI2M(1,M01) CALL FMDIV(M01,M02,M02) ENDIF ENDIF C C Generate the first approximation to ABS(MA)**(1/JVAL2). C 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 C C Initialize. C CALL FMDIG(NSTACK,KST) C C Newton iteration. C DO 120 J = 1, KST NDIG = NSTACK(J) IF (J.LT.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) 120 CONTINUE C IF (MB(1).NE.MUNKNO .AND. MA2.LT.0) MB(2) = -MB(2) CALL FMIPWR(MB,IJSIGN*IVAL2,MB) IF (INVERT.EQ.1) THEN CALL FMI2M(1,M01) CALL FMDIV(M01,MB,MB) ENDIF C C Round the result and return. C 130 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MACCA,MACMAX) KWRNSV = KWARN IF (MA1.EQ.MUNKNO) KWARN = 0 CALL FMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) KWARN = KWRNSV RETURN END SUBROUTINE FMRSLT(MA,MB,MC,KRESLT) C C Handle results that are special cases, such as overflow, C underflow, and unknown. C C MA and MB are the input arguments to an FM subroutine. C C MC is the result that is returned. C C KRESLT is the result code from FMARGS. Result codes handled here: C C 0 - Perform the normal operation C 1 - The result is the first input argument C 2 - The result is the second input argument C 3 - The result is -OVERFLOW C 4 - The result is +OVERFLOW C 5 - The result is -UNDERFLOW C 6 - The result is +UNDERFLOW C 7 - The result is -1.0 C 8 - The result is +1.0 C 11 - The result is 0.0 C 12 - The result is UNKNOWN C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) INTEGER KRESLT C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCAB INTEGER KFSAVE C KFSAVE = KFLAG MACCAB = MIN(MA(0),MB(0)) IF (KRESLT.EQ.1) THEN CALL FMEQ(MA,MC) MC(0) = MACCAB IF (NAMEST(NCALL).EQ.'FMADD ' .OR. * NAMEST(NCALL).EQ.'FMSUB ') THEN KFLAG = 1 ELSE KFLAG = KFSAVE ENDIF RETURN ENDIF C IF (KRESLT.EQ.2) THEN CALL FMEQ(MB,MC) MC(0) = MACCAB IF (NAMEST(NCALL).EQ.'FMADD ') THEN KFLAG = 1 ELSE KFLAG = KFSAVE ENDIF IF (NAMEST(NCALL).EQ.'FMSUB ') THEN MC(2) = -MC(2) KFLAG = KFSAVE ENDIF RETURN ENDIF C IF (KRESLT.EQ.3 .OR. KRESLT.EQ.4) THEN CALL FMIM(0,MC) MC(1) = MEXPOV MC(2) = 1 IF (KRESLT.EQ.3) MC(2) = -1 MC(0) = MACCAB KFLAG = KFSAVE RETURN ENDIF C IF (KRESLT.EQ.5 .OR. KRESLT.EQ.6) THEN CALL FMIM(0,MC) MC(1) = MEXPUN MC(2) = 1 IF (KRESLT.EQ.5) MC(2) = -1 MC(0) = MACCAB KFLAG = KFSAVE RETURN ENDIF C IF (KRESLT.EQ.7) THEN CALL FMIM(-1,MC) MC(0) = MACCAB KFLAG = KFSAVE RETURN ENDIF C IF (KRESLT.EQ.8) THEN CALL FMIM(1,MC) MC(0) = MACCAB KFLAG = KFSAVE RETURN ENDIF C IF (KRESLT.EQ.11) THEN CALL FMIM(0,MC) MC(0) = MACCAB KFLAG = KFSAVE RETURN ENDIF C IF (KRESLT.EQ.12 .OR. KRESLT.LT.0 .OR. KRESLT.GT.15) THEN CALL FMIM(0,MC) MC(1) = MUNKNO MC(2) = 1 MC(0) = MACCAB KFLAG = KFSAVE RETURN ENDIF C RETURN END SUBROUTINE FMSIGN(MA,MB,MC) C C MC = SIGN(MA,MB) C C MC is set to ABS(MA) if MB is positive or zero, C or -ABS(MA) if MB is negative. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK),MC(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER KWRNSV C KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMSIGN' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MB,2) C KWRNSV = KWARN KWARN = 0 IF (MA(1).EQ.MUNKNO .OR. MB(1).EQ.MUNKNO) THEN CALL FMIM(0,MC) MC(1) = MUNKNO MC(2) = 1 MC(0) = NINT(NDIG*ALOGM2) KFLAG = -4 ELSE IF (MB(2).GE.0) THEN CALL FMEQ(MA,MC) MC(2) = ABS(MC(2)) ELSE CALL FMEQ(MA,MC) MC(2) = -ABS(MC(2)) ENDIF C KWARN = KWRNSV IF (NTRACE.NE.0) CALL FMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMSIN(MA,MB) C C MB = SIN(MA) C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during FMSIN: M01 - M04 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MA2,MACCA,MACMAX,MXSAVE INTEGER JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,NDSAVE,NDSV C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (ABS(MA(1)).GT.MEXPAB .OR. MA(2).EQ.0) THEN CALL FMENTR('FMSIN ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMSIN ' IF (NTRACE.NE.0) CALL FMNTR(2,MA,MA,1) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL.EQ.1) THEN K = MAX(NGRD52,2) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE.NE.0) CALL FMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF C MACCA = MA(0) MA2 = MA(2) CALL FMEQ2(MA,MB,NDSAVE,NDIG,0) MB(0) = NINT(NDIG*ALOGM2) MB(2) = ABS(MB(2)) C C Reduce the argument, convert to radians if the input is C in degrees, and evaluate the function. C CALL FMRDC(MB,MB,JSIN,JCOS,JSWAP) IF (MB(1).EQ.MUNKNO) GO TO 110 IF (KRAD.EQ.0) THEN IF (MBSPI.NE.MBASE .OR. NDIGPI.LT.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).NE.MUNKNO) THEN IF (JSWAP.EQ.0) THEN IF (MB(1).LT.0 .OR. NDIG.LE.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 C C Append the sign, round, and return. C IF (JSIN.EQ.-1 .AND. MB(1).NE.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.LT.0 .AND. MB(1).NE.MUNKNO) MB(2) = -MB(2) CALL FMEXIT(MB,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMSIN2(MA,MB) C C Internal subroutine for MB = SIN(MA) where 0.LE.MA.LE.1. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6 ) C DOUBLE PRECISION MA(0:LUNPCK),MB(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during FMSIN2: M01 - M04 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C DOUBLE PRECISION MJSUMS C COMMON /FMSUMS/ MJSUMS(0:LJSUMS) C C LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent C sums. Increasing this value will begin to improve the C speed of SIN when the base is large and precision exceeds C about 1,500 decimal digits. C 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 C IF (MBLOGS.NE.MBASE) CALL FMCONS IF (MA(2).EQ.0) THEN CALL FMEQ(MA,MB) RETURN ENDIF NDSAVE = NDIG KWRNS