C ALGORITHM 814, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 27,NO. 4, December, 2001, P. 377--387. #! /bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #! /bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # Doc/ # Doc/ReadMe # Fortran90/ # Fortran90/Sp/ # Fortran90/Sp/Drivers/ # Fortran90/Sp/Drivers/SAMPLE.CHK # Fortran90/Sp/Drivers/SampleFM.f90 # Fortran90/Sp/Drivers/TestFM.f90 # Fortran90/Sp/Src/ # Fortran90/Sp/Src/FM.f90 # Fortran90/Sp/Src/FMSAVE.f90 # Fortran90/Sp/Src/FMZM90.f90 # This archive created: Thu Mar 7 18:00:52 2002 export PATH; PATH=/bin:$PATH if test ! -d 'Doc' then mkdir 'Doc' fi cd 'Doc' if test -f 'ReadMe' then echo shar: will not over-write existing file "'ReadMe'" else cat << "SHAR_EOF" > 'ReadMe' This is a list of the files for version 1.2 of FMLIB. 1. FMSAVE.f90 Module for FM internal global variables 2. FMZM90.f90 Modules for interfaces and definitions of derived-types 3. FM.f90 Subroutine library for multiple-precision operations 4. TestFM.f90 Test program for most of the FM routines 5. SampleFM.f90 Small sample program using FM 6. SAMPLE.CHK Expected output file SAMPLE.LOG from SampleFM.f90 Here is an example set of compiler/linker commands for building the programs. For lines on which there is no *.f90 file listed, the f90 script skips the compiler and calls the linker. Options: -c compile to object code -- don't make executable -O optimization on -f free Fortran-90 free source form -o output file name f90 FMSAVE.f90 -c -f free -o FMSAVE.o f90 FMZM90.f90 -c -f free -o FMZM90.o f90 FM.f90 -O -c -f free -o FM.o f90 TestFM.f90 -c -f free -o TestFM.o f90 TestFM.o FMSAVE.o FMZM90.o FM.o -o TestFM f90 SampleFM.f90 -c -f free -o SampleFM.o f90 SampleFM.o FMSAVE.o FMZM90.o FM.o -o SampleFM Basically the first three files are compiled as object code libraries, and then a program using FM is compiled and linked to those three libraries. Most compilers also produce files FMVALS.mod, FMZM.mod, etc., containing module information from the first two files. Troubleshooting 1. After downloading the files, if the compiler gives many error messages or it appears to see no code in the file at all, check that the lines in the file have the proper end-of-line characters for your system. For a PC, this means each line should end with both a carriage return character (ascii 13) and a line feed character (ascii 10). If the file appears to be one huge line when viewed in an editor, one of these two characters is probably missing and should be added to each line. To use FM on a Unix system, lines end with , and for a Mac system they end with . On these systems, failing to fix the end-of-line characters might mean the file seems to have twice the expected number of lines, with a blank line between each line of code when viewed in an editor. Many good editors will recognize a foreign end-of-line format and automatically fix each file the first time it is opened. 2. Compiler gives an "out of memory" error message or crashes during compile of FM.f90 or FMZM90.f90. It might be necessary to break the file into smaller pieces or split it into separate files for each routine or module. This could be caused by lack of system memory, lack of virtual memory, or a bug (memory leak) in the compiler. Some compilers have an option (-split) to do this automatically. 3. Most of the routines compile, but a few fail with error messages like "symbol 120 is not the label of a branch target statement". However, looking at the code shows there is a label 120 in that routine. This might happen in the larger routines. Some compilers may require additional options be enabled (e.g., to force 32-bit branches or addresses to be used). Check in the compiler manual and try turning on any options that mention "long branches", "32-bit addresses", etc. 4. All files compile, but the TestFM program reports a few errors when it runs. There are other possibilities, but one thing to check is whether the compiler has any options controlling arithmetic precision of intermediate results. Because the FM numbers are stored as integer values in double precision arrays, any sloppy rounding can cause problems. In one case, a compiler optimized an expression by leaving the result of a division in an 80-bit register and then used that result later in the calculation. Rounding the division back to double precision would have fixed the error, but using the inaccurate extended precision value caused the final result to be off by one when it was returned to an integer value. This compiler had an option (-ap) to force intermediate results to not be left in registers, and that fixed the problem. Another way to check to see if this is the problem is to create a version of FM that uses integer arrays instead of double precision. See the section titled "EFFICIENCY" below to see how to make this change. On most machines, there is little if any speed penalty for using integer arrays as long as the precision is under 100 significant digits (i.e., NDIG < 15 or so with MBASE = 10**7). 5. Several messages like this appear: C:\t\FMZM90.f90(6563) : Info: This variable has not been used. [MA] FUNCTION FMTINY_ZM(MA) This and the other messages of the same type are not errors. The argument for functions like TINY is not used for anything except telling the compiler which routine to call by checking the argument's type. The same is true of the Fortran intrinsic function TINY. If we say TINY(1.0) or TINY(2.0), the input argument is not used, other than to indicate that we want the single precision value of TINY. ================================================================================ ================================================================================ USER'S GUIDE FOR THE FM PACKAGE The various lists of available multiple precision operations and routines have been collected here, along with some general advice on using the package. See the program SampleFM.f90 for some examples of initializing and using the package. INITIALIZATION: The default precision for the multiple-precision numbers is about 50 significant digits. To set precision to a different value, put CALL FMSET(N) in the main program before any multiple precision operations are done, with N replaced by the number of decimal digits of accuracy to be used. ROUTINE NAMES: For each multiple precision operation there are several routines with related names that perform variations of that operation. For example, the addition operation has these forms: Using the Fortran-90 interface module, to perform real (floating-point) multiple precision addition, declare the variables as FM derived types with USE FMZM TYPE ( FM ) A,B,C and then add using C = A + B Normally, using the interface module avoids the need to know the name of the FM routine being called. For some operations, usually those that are not Fortran-90 functions (such as formatting a number), a direct call may be needed. The addition above can be done as CALL FM_ADD(A,B,C) It is rare for a program to bypass the derived types and work directly with the arrays that define the multiple-precision numbers. The only real drawback to using the derived types is a small performance penalty (that varies from one compiler to another). If FM.f90 is used without the interface module, then the multiple precision numbers are declared as arrays DOUBLE PRECISION A(-1:LUNPCK),B(-1:LUNPCK),C(-1:LUNPCK) where LUNPCK is defined in FMSAVE.f90. The numbers are then added by calling the FM routine where the arguments are assumed to be arrays, not TYPE (FM) derived types: CALL FMADD(A,B,C) For each of the routines listed below (like FMADD), there is a version that assumes the arguments have the appropriate derived type. These have the same names, except "_" has been inserted after the first two letters of the name (like FM_ADD). If direct calls are done instead of using the interface module, there is another form for these routine names that is used when the arrays have been declared in a packed format that takes roughly half as much space: DOUBLE PRECISION A(-1:LPACK),B(-1:LPACK),C(-1:LPACK) The routines that work with packed arrays have names where the second letter has been changed from M to P: CALL FPADD(A,B,C) The packed versions are slower. For multiple precision integer (IM) or complex (ZM) operations there are similar Fortran-90 derived types and the various routines: USE FMZM ... TYPE ( IM ) A,B,C TYPE ( ZM ) X,Y,Z ... C = A + B ... Z = X + Y with explicit calls of the form CALL IM_ADD(A,B,C) CALL ZM_ADD(X,Y,Z) Without using the interface module: DOUBLE PRECISION A(-1:LUNPCK),B(-1:LUNPCK),C(-1:LUNPCK) DOUBLE PRECISION X(-1:LUNPKZ),Y(-1:LUNPKZ),Z(-1:LUNPKZ) ... CALL IMADD(A,B,C) ... CALL ZMADD(X,Y,Z) Packed format without the interface module: DOUBLE PRECISION A(-1:LPACK),B(-1:LPACK),C(-1:LPACK) DOUBLE PRECISION X(-1:LPACKZ),Y(-1:LPACKZ),Z(-1:LPACKZ) ... CALL IPADD(A,B,C) ... CALL ZPADD(X,Y,Z) -------------------------------------------------------------------------------- ----------------------- Fortran-90 Interface Notes ------------------------- There are three multiple precision data types: FM (multiple precision real) IM (multiple precision integer) ZM (multiple precision complex) Some of the interface routines assume that the precision chosen in the calling program (using FMSET) represents more significant digits than does the machine's double precision. Most of the functions defined in this module are multiple precision versions of standard Fortran-90 functions. In addition, there are functions for direct conversion, formatting, and some mathematical special functions. TO_FM is a function for converting other types of numbers to type FM. Note that TO_FM(3.12) converts the REAL constant to FM, but it is accurate only to single precision. TO_FM(3.12D0) agrees with 3.12 to double precision accuracy, and TO_FM('3.12') or TO_FM(312)/TO_FM(100) agrees to full FM accuracy. TO_IM converts to type IM, and TO_ZM converts to type ZM. Functions are also supplied for converting the three multiple precision types to the other numeric data types: TO_INT converts to machine precision integer TO_SP converts to single precision TO_DP converts to double precision TO_SPZ converts to single precision complex TO_DPZ converts to double precision complex WARNING: When multiple precision type declarations are inserted in an existing program, take care in converting functions like DBLE(X), where X has been declared as a multiple precision type. If X was single precision in the original program, then replacing the DBLE(X) by TO_DP(X) in the new version could lose accuracy. For this reason, the Fortran type-conversion functions defined in this module assume that results should be multiple precision whenever inputs are. Examples: DBLE(TO_FM('1.23E+123456')) is type FM REAL(TO_FM('1.23E+123456')) is type FM REAL(TO_ZM('3.12+4.56i')) is type FM = TO_FM('3.12') INT(TO_FM('1.23')) is type IM = TO_IM(1) INT(TO_IM('1E+23')) is type IM CMPLX(TO_FM('1.23'),TO_FM('4.56')) is type ZM Programs using this module may sometimes need to call FM, IM, or ZM routines directly. This is normally the case when routines are needed that are not Fortran-90 intrinsics, such as the formatting subroutine FMFORM. In a program using this module, suppose MAFM has been declared with TYPE ( FM ) MAFM. To use the routine FMFORM, which expects the second argument to be an array and not a derived type, the call would have to be CALL FMFORM('F65.60',MAFM%MFM,ST1) so that the array contained in MAFM is passed. As an alternative so the user can refer directly to the FM-, IM-, and ZM-type variables and avoid the cumbersome "%MFM" suffixes, the FM package provides a collection of interface routines to supply any needed argument conversions. For each FM, IM, and ZM routine that is designed to be called by the user, there is also a version that assumes any multiple-precision arguments are derived types instead of arrays. Each interface routine has the same name as the original with an underscore after the first two letters of the routine name. To convert the number to a character string with F65.60 format, use CALL FM_FORM('F65.60',MAFM,ST1) if MAFM is of TYPE ( FM ), or use CALL FMFORM('F65.60',MA,ST1) if MA is declared as an array. All the routines shown below may be used this way. For each of the operations =, == , /= , < , <= , > , >= , +, -, *, /, and **, the interface module defines all mixed mode variations involving one of the three multiple precision derived types and another argument having one of the types: { integer, real, double, complex, complex double, FM, IM, ZM }. So mixed mode expressions such as MAFM = 12 MAFM = MAFM + 1 IF (ABS(MAFM) > 1.0D-23) THEN are handled correctly. Not all the named functions are defined for all three multiple precision derived types, so the list below shows which can be used. The labels "real", "integer", and "complex" refer to types FM, IM, and ZM respectively, "string" means the function accepts character strings (e.g., TO_FM('3.45')), and "other" means the function can accept any of the machine precision data types integer, real, double, complex, or complex double. For functions that accept two or more arguments, like ATAN2 or MAX, all the arguments must be of the same type. AVAILABLE OPERATIONS: = + - * / ** == /= < <= > >= ABS real integer complex ACOS real complex AIMAG complex AINT real complex ANINT real complex ASIN real complex ATAN real complex ATAN2 real BTEST integer CEILING real complex CMPLX real integer CONJ complex COS real complex COSH real complex DBLE real integer complex DIGITS real integer complex DIM real integer DINT real complex DOTPRODUCT real integer complex EPSILON real EXP real complex EXPONENT real FLOOR real integer complex FRACTION real complex HUGE real integer complex INT real integer complex LOG real complex LOG10 real complex MATMUL real integer complex MAX real integer MAXEXPONENT real MIN real integer MINEXPONENT real MOD real integer MODULO real integer NEAREST real NINT real integer complex PRECISION real complex RADIX real integer complex RANGE real integer complex REAL real integer complex RRSPACING real SCALE real complex SETEXPONENT real SIGN real integer SIN real complex SINH real complex SPACING real SQRT real complex TAN real complex TANH real complex TINY real integer complex TO_FM real integer complex string other TO_IM real integer complex string other TO_ZM real integer complex string other TO_INT real integer complex TO_SP real integer complex TO_DP real integer complex TO_SPZ real integer complex TO_DPZ real integer complex Some other functions are defined that do not correspond to machine precision intrinsic functions. These include formatting functions, integer modular functions and GCD, and the Gamma function and its related functions. N below is a machine precision integer, J1, J2, J3 are TYPE (IM), FMT, FMTR, FMTI are character strings, A,B,X are TYPE (FM), and Z is TYPE (ZM). The three formatting functions return a character string containing the formatted number, the three TYPE (IM) functions return a TYPE (IM) result, and the 12 special functions return TYPE (FM) results. Formatting functions: FM_FORMAT(FMT,A) Put A into FMT (real) format IM_FORMAT(FMT,J1) Put J1 into FMT (integer) format ZM_FORMAT(FMTR,FMTI,Z) Put Z into (complex) format, FMTR for the real part and FMTI for the imaginary part Examples: ST = FM_FORMAT('F65.60',A) WRITE (*,*) ' A = ',TRIM(ST) ST = FM_FORMAT('E75.60',B) WRITE (*,*) ' B = ',ST(1:75) ST = IM_FORMAT('I50',J1) WRITE (*,*) ' J1 = ',ST(1:50) ST = ZM_FORMAT('F35.30','F30.25',Z) WRITE (*,*) ' Z = ',ST(1:70) These functions are used for one-line output. The returned character strings are of length 200. Avoid using the formatting function in the write list, as in WRITE (*,*) ' J1 = ',IM_FORMAT('I50',J1)(1:50) since the formatting functions may themselves execute an internal WRITE and that would cause a recursive write reference. For higher precision numbers, the output can be broken onto multiple lines automatically by calling subroutines FM_PRNT, IM_PRNT, ZM_PRNT, or the line breaks can be done by hand after calling one of the subroutines FM_FORM, IM_FORM, ZM_FORM. For ZM_FORMAT the length of the output is 5 more than the sum of the two field widths. Integer functions: GCD(J1,J2) Greatest Common Divisor of J1 and J2. MULTIPLY_MOD(J1,J2,J3) J1 * J2 mod J3 POWER_MOD(J1,J2,J3) J1 ** J2 mod J3 Special functions: BERNOULLI(N) Nth Bernoulli number BETA(A,B) Integral (0 to 1) t**(A-1) * (1-t)**(B-1) dt BINOMIAL(A,B) Binomial Coefficient A! / ( B! (A-B)! ) FACTORIAL(A) A! GAMMA(A) Integral (0 to infinity) t**(A-1) * exp(-t) dt INCOMPLETE_BETA(X,A,B) Integral (0 to X) t**(A-1) * (1-t)**(B-1) dt INCOMPLETE_GAMMA1(A,X) Integral (0 to X) t**(A-1) * exp(-t) dt INCOMPLETE_GAMMA2(A,X) Integral (X to infinity) t**(A-1) * exp(-t) dt LOG_GAMMA(A) Ln( GAMMA(A) ) POLYGAMMA(N,A) Nth derivative of Psi(x), evaluated at A POCHHAMMER(A,N) A*(A+1)*(A+2)*...*(A+N-1) PSI(A) Derivative of Ln(Gamma(x)), evaluated at A -------------------------------------------------------------------------------- ------------------------------ FM.f90 Notes -------------------------------- The routines in this package perform multiple precision arithmetic and functions on three kinds of numbers. FM routines handle floating-point real multiple precision numbers, IM routines handle integer multiple precision numbers, and ZM routines handle floating-point complex multiple precision numbers. 1. INITIALIZING THE PACKAGE The variables that contain values to be shared among the different routines are located in module FMVALS in file FMSAVE.f90. Variables that are described below for controlling various features of the FM package are found in this module. They are initialized to default values assuming 32-bit integers and 64-bit double precision representation of the arrays holding multiple precision numbers. The base and number of digits to be used are initialized to give slightly more than 50 decimal digits. Subroutine FMVARS can be used to get a list of these variables and their values. The intent of module FMVALS is to hide the FM internal variables from the user's program, so that no name conflicts can occur. Subroutine FMSETVAR can be used to change the variables listed below to new values. It is not always safe to try to change these variables directly by putting USE FMVALS into the calling program and then changing them by hand. Some of the saved constants depend upon others, so that changing one variable may cause errors if others depending on that one are not also changed. FMSETVAR automatically updates any others that depend upon the one being changed. Subroutine FMSET also initializes these variables. It tries to compute the best value for each, and it checks several of the values set in FMVALS to see that they are reasonable for a given machine. FMSET can also be called to set or change the current precision level for the multiple precision numbers. Calling FMSET is optional in version 1.2 of the FM package. In previous versions one call was required before any other routine in the package could be used. The routine ZMSET from version 1.1 is no longer needed, and the complex operations are automatically initialized in FMVALS. It has been left in the package for compatibility with version 1.1. 2. REPRESENTATION OF FM NUMBERS MBASE is the base in which the arithmetic is done. MBASE must be bigger than one, and less than or equal to the square root of the largest representable integer. For best efficiency MBASE should be large, but no more than about 1/4 of the square root of the largest representable integer. Input and output conversions are much faster when MBASE is a power of ten. NDIG is the number of base MBASE digits that are carried in the multiple precision numbers. NDIG must be at least two. The upper limit for NDIG is defined in FMVALS and is restricted only by the amount of memory available. Sometimes it is useful to dynamically vary NDIG during the program. Routine FMEQU should be used to round numbers to lower precision or zero-pad them to higher precision when changing NDIG. The default value of MBASE is a large power of ten. FMSET also sets MBASE to a large power of ten. For an application where another base is used, such as simulating a given machine's base two arithmetic, use subroutine FMSETVAR to change MBASE, so that the other internal values depending on MBASE will be changed accordingly. There are two representations for a floating point multiple precision number. The unpacked representation used by the routines while doing the computations is base MBASE and is stored in NDIG+2 words. A packed representation is available to store the numbers in the user's program in compressed form. In this format, the NDIG (base MBASE) digits of the mantissa are packed two per word to conserve storage. Thus the external, packed form of a number requires (NDIG+1)/2+2 words. This version uses double precision arrays to hold the numbers. Version 1.0 of FM used integer arrays, which are faster on some machines. The package can be changed to use integer arrays --- see section 11 on EFFICIENCY below. The unpacked format of a floating multiple precision number is as follows. A number MA is kept in an array with MA(1) containing the exponent, and MA(2) through MA(NDIG+1) each containing one digit of the mantissa, expressed in base MBASE. The array is dimensioned to start at MA(-1), with the sign of the number (+1 or -1) held in MA(-1), and the approximate number of bits of precision stored in MA(0). This precision value is intended to be used by FM functions that need to monitor cancellation error in addition and subtraction. The cancellation monitor code is usually disabled for user calls, and FM functions only check for cancellation when they must. Tracking cancellation causes most routines to run slower, with addition and subtraction being affected the most. The exponent is a power of MBASE and the implied radix point is immediately before the first digit of the mantissa. Every nonzero number is normalized so that the second array element (the first digit of the mantissa) is nonzero. In both representations the sign of the number is carried on the second array element only. Elements 3,4,... are always nonnegative. The exponent is a signed integer and may be as large in magnitude as MXEXP. For MBASE = 10,000 and NDIG = 4, the number -pi would have these representations: Word 1 2 3 4 5 Unpacked: 1 -3 1415 9265 3590 Packed: 1 -31415 92653590 In both formats MA(0) would be 42, indicating that the mantissa has about 42 bits of precision, and MA(-1) = -1 since the number is negative. Because of normalization in a large base, the equivalent number of base 10 significant digits for an FM number may be as small as LOG10(MBASE)*(NDIG-1) + 1. The integer routines use the FM format to represent numbers, without the number of digits (NDIG) being fixed. Integers in IM format are essentially variable precision, using the minimum number of words to represent each value. For programs using both FM and IM numbers, FM routines should not be called with IM numbers, and IM routines should not be called with FM numbers, since the implied value of NDIG used for an IM number may not match the explicit NDIG expected by an FM routine. Use the conversion routines IMFM2I and IMI2FM to change between the FM and IM formats. The format for complex FM numbers (called ZM numbers below) is very similar to that for real FM numbers. Each ZM array holds two FM numbers to represent the real and imaginary parts of a complex number. Each ZM array is twice as long as a corresponding FM array, with the imaginary part starting at the midpoint of the array. As with FM, there are packed and unpacked formats for the numbers. 3. INPUT/OUTPUT ROUTINES All versions of the input routines perform free-format conversion from characters to FM numbers. a. Conversion to or from a character array FMINP converts from a character*1 array to an FM number. FMOUT converts an FM number to base 10 and formats it for output as an array of type character*1. The output is left justified in the array, and the format is defined by two variables in module FMVALS, so that a separate format definition does not have to be provided for each output call. JFORM1 and JFORM2 define a default output format. JFORM1 = 0 E format ( .314159M+6 ) = 1 1PE format ( 3.14159M+5 ) = 2 F format ( 314159.000 ) JFORM2 is the number of significant digits to display (if JFORM1 = 0 or 1). If JFORM2 = 0 then a default number of digits is chosen. The default is roughly the full precision of the number. JFORM2 is the number of digits after the decimal point (if JFORM1 = 2). See the FMOUT documentation for more details. b. Conversion to or from a character string FMST2M converts from a character string to an FM number. FMFORM converts an FM number to a character string according to a format provided in each call. The format description is more like that of a Fortran FORMAT statement, and integer or fixed-point output is right justified. c. Direct read or write FMPRNT uses FMOUT to print one FM number. FMFPRT uses FMFORM to print one FM number. FMWRIT writes FM numbers for later input using FMREAD. FMREAD reads FM numbers written by FMWRIT. The values given to JFORM1 and JFORM2 can be used to define a default output format when FMOUT or FMPRNT are called. The explicit format used in a call to FMFORM or FMFPRT overrides the settings of JFORM1 and JFORM2. KW is the unit number to be used for standard output from the package, including error and warning messages, and trace output. For multiple precision integers, the corresponding routines IMINP, IMOUT, IMST2M, IMFORM, IMPRNT, IMFPRT, IMWRIT, and IMREAD provide similar input and output conversions. For output of IM numbers, JFORM1 and JFORM2 are ignored and integer format (JFORM1=2, JFORM2=0) is used. For ZM numbers, the corresponding routines ZMINP, ZMOUT, ZMST2M, ZMFORM, ZMPRNT, ZMFPRT, ZMWRIT, and ZMREAD provide similar input and output conversions. For the output format of ZM numbers, JFORM1 and JFORM2 determine the default format for the individual parts of a complex number as with FM numbers. JFORMZ determines the combined output format of the real and imaginary parts. JFORMZ = 1 normal setting : 1.23 - 4.56 i = 2 use capital I : 1.23 - 4.56 I = 3 parenthesis format: ( 1.23 , -4.56 ) JPRNTZ controls whether to print real and imaginary parts on one line whenever possible. JPRNTZ = 1 print both parts as a single string : 1.23456789M+321 - 9.87654321M-123 i = 2 print on separate lines without the 'i' : 1.23456789M+321 -9.87654321M-123 For further description of these routines, see sections 9 and 10 below. 4. ARITHMETIC TRACING NTRACE and LVLTRC control trace printout from the package. NTRACE = 0 No output except warnings and errors. (Default) = 1 The result of each call to one of the routines is printed in base 10, using FMOUT. = -1 The result of each call to one of the routines is printed in internal base MBASE format. = 2 The input arguments and result of each call to one of the routines is printed in base 10, using FMOUT. = -2 The input arguments and result of each call to one of the routines is printed in base MBASE format. LVLTRC defines the call level to which the trace is done. LVLTRC = 1 means only FM routines called directly by the user are traced, LVLTRC = 2 also prints traces for FM routines called by other FM routines called directly by the user, etc. Default is 1. In the above description, internal MBASE format means the number is printed as it appears in the array --- an exponent followed by NDIG base MBASE digits. 5. ERROR CONDITIONS KFLAG is a condition value returned by the package after each call to one of the routines. Negative values indicate conditions for which a warning message will be printed unless KWARN = 0. Positive values indicate conditions that may be of interest but are not errors. No warning message is printed if KFLAG is nonnegative. Subroutine FMFLAG is provided to give the user access to the current condition code. For example, to set the user's local variable LFLAG to FM's internal KFLAG value: CALL FMFLAG(LFLAG) KFLAG = 0 Normal operation. = 1 One of the operands in FMADD or FMSUB was insignificant with respect to the other, so that the result was equal to the argument of larger magnitude. = 2 In converting an FM number to a one word integer in FMM2I, the FM number was not exactly an integer. The next integer toward zero was returned. = -1 NDIG was less than 2 or more than NDIGMX. = -2 MBASE was less than 2 or more than MXBASE. = -3 An exponent was out of range. = -4 Invalid input argument(s) to an FM routine. UNKNOWN was returned. = -5 + or - OVERFLOW was generated as a result from an FM routine. = -6 + or - UNDERFLOW was generated as a result from an FM routine. = -7 The input string (array) to FMINP was not legal. = -8 The character array was not large enough in an input or output routine. = -9 Precision could not be raised enough to provide all requested guard digits. Increasing the value of NDIGMX in file FMSAVE.f90 may fix this. UNKNOWN was returned. = -10 An FM input argument was too small in magnitude to convert to the machine's single or double precision in FMM2SP or FMM2DP. Check that the definitions of SPMAX and DPMAX in file FMSAVE.f90 are correct for the current machine. Zero was returned. = -11 Array MBERN is not dimensioned large enough for the requested number of Bernoulli numbers. = -12 Array MJSUMS is not dimensioned large enough for the number of coefficients needed in the reflection formula in FMPGAM. When a negative KFLAG condition is encountered, the value of KWARN determines the action to be taken. KWARN = 0 Execution continues and no message is printed. = 1 A warning message is printed and execution continues. = 2 A warning message is printed and execution stops. The default setting is KWARN = 1. When an overflow or underflow is generated for an operation in which an input argument was already an overflow or underflow, no additional message is printed. When an unknown result is generated and an input argument was already unknown, no additional message is printed. In these cases the negative KFLAG value is still returned. IM routines handle exceptions like OVERFLOW or UNKNOWN in the same way as FM routines. When using IMMPY, the product of two large positive integers will return +OVERFLOW. The routines IMMPYM and IMPMOD can be used to obtain a modular result without overflow. The largest representable IM integer is MBASE**NDIGMX - 1. For example, if MBASE is 10**7 and NDIGMX is set to 256, integers less than 10**1792 can be used. 6. OTHER OPTIONS KRAD = 0 All angles in the trigonometric functions and inverse functions are measured in degrees. = 1 All angles are measured in radians. (Default) KROUND = -1 All results are rounded toward minus infinity. = 0 All results are rounded toward zero (chopped). = 1 All results are rounded to the nearest FM number, or to the value with an even last digit if the result is halfway between two FM numbers. (Default) = 2 All results are rounded toward plus infinity. In all cases, while a function is being computed all intermediate results are rounded to nearest, with only the final result being rounded according to KROUND. KRPERF = 0 A smaller number of guard digits used, to give nearly perfect rounding. This number is chosen so that the last intermediate result should have error less than 0.001 unit in the last place of the final rounded result. (Default) = 1 Causes more guard digits to be used, to get perfect rounding in the mode set by KROUND. This slows execution speed. If a small base is used for the arithmetic, like MBASE = 2, 10, or 16, FM assumes that the arithmetic hardware for some machine is being simulated, so perfect rounding is done without regard for the value of KRPERF. If KROUND = 1, then KRPERF = 1 means returned results are no more than 0.500 units in the last place from the exact mathematical result, versus 0.501 for KRPERF = 0. If KROUND is not 1, then KRPERF = 1 means returned results are no more than 1.000 units in the last place from the exact mathematical result, versus 1.001 for KRPERF = 0. KSWIDE defines the maximum screen width to be used for all unit KW output. Default is 80. KESWCH controls the action taken in FMINP and other input routines for strings like 'E7' that have no digits before the exponent field. This is sometimes a convenient abbreviation when doing interactive keyboard input. KESWCH = 1 causes 'E7' to translate like '1.0E+7'. (Default) KESWCH = 0 causes 'E7' to translate like '0.0E+7' and give 0. CMCHAR defines the exponent letter to be used for FM variable output. Default is 'M', as in 1.2345M+678. Change it to 'E' for output to be read by a non-FM program. KDEBUG = 0 No error checking is done to see if input arguments are valid and parameters like NDIG and MBASE are correct upon entry to each routine. (Default) = 1 Some error checking is done. (Slower speed) See module FMVALS in file FMSAVE.f90 for additional description of these and other variables defining various FM conditions. 7. ARRAY DIMENSIONS The dimensions of the arrays in the FM package are defined using parameters NDIGMX and NBITS. NDIGMX is the maximum value the user may set for NDIG. NBITS is the number of bits used to represent integers for a given machine. See the EFFICIENCY discussion below. The standard version of FM sets NDIGMX = 55, so on a 32-bit machine using MBASE = 10**7 the maximum precision is about 7*54+1 = 379 significant digits. Previous versions of FM set NDIGMX = 256. Two reasons for making this change are: (a) Almost all applications using FM use only 30 to 50 significant digits for checking double or quadruple precision results, and the larger arrays are wasted space. (b) Most FM applications use the derived type interface so that the number of changes to existing code is minimized. Many compilers implement the FM interface by doing copy in / copy out argument passing of the derived types. Copying the entire large array when only a small part of it is being used causes the derived type arithmetic to be slow compared to making direct calls to the subroutines. Setting NDIGMX to be only slightly higher than a program actually uses minimizes any performance penalty for the derived type arithmetic. To change dimensions so that 10,000 significant digit calculation can be done, NDIGMX needs to be at least 10**4/7 + 5 = 1434. This allows for a few user guard digits to be defined when the precision is changed using CALL FMSET(10000). Changing 'NDIGMX = 55' to 'NDIGMX = 1434' in FMSAVE.f90 will define all the new array sizes. If NDIG much greater than 256 is to be used and elementary functions will be needed, they will be faster if array MJSUMS is larger. The parameter defining the size of MJSUMS is set in the standard version by LJSUMS = 8*(LUNPCK+2) The 8 means that up to eight concurrent sums can be used by the elementary functions. The approximate number needed for best speed is given by 0.051*Log(MBASE)*NDIG**0.333 + 1.85 For example, with MBASE=10**7 and NDIG=1434 this gives 11. Changing 'LJSUMS = 8*(LUNPCK+2)' to 'LJSUMS = 11*(LUNPCK+2)' in FMSAVE.f90 will give slightly better speed. FM numbers in packed format have dimension -1:LPACK, and those in unpacked format have dimension -1:LUNPCK. The parameters LPACKZ and LUNPKZ define the size of the packed and unpacked ZM arrays. The real part starts at the beginning of the array, and the imaginary part starts at word KPTIMP for packed format or at word KPTIMU for unpacked format. 8. PORTABILITY In FMSET several variables are set to machine-dependent values, and many of the variables initialized in module FMVALS in file FMSAVE.f90 are checked to see that they have reasonable values. FMSET will print warning messages on unit KW for any of the FMVALS variables that seem to be poorly initialized. If an FM run fails, call FMVARS to get a list of all the FMVALS variables printed on unit KW. Setting KDEBUG = 1 at the start may also identify some errors. Some compilers object to a function like FMCOMP with side effects such as changing KFLAG or other module variables. Blocks of code in FMCOMP and IMCOMP that modify these variables are identified so they may be removed or commented out to produce a function without side effects. This disables trace printing in FMCOMP and IMCOMP, and error codes are not returned in KFLAG. See FMCOMP and IMCOMP for further details. In FMBER2 and FMPGAM several constants are used that require the machine's integer word size to be at least 32 bits. 9. LIST OF ROUTINES - Shown after section 11 below. 10. NEW FOR VERSION 1.2 Version 1.2 is written in Fortran-90 free source format. The routines for the Gamma function and related mathematical special functions are new in version 1.2. Several new derived-type function interfaces are included in module FMZM in file FMZM90.f90, such as integer multiple precision operations GCD, modular multiplication, and modular powers. There are also formatting functions and function interfaces for the Gamma and related special functions. Two new rounding modes have been added, round toward -infinity and round toward +infinity. See the description of KROUND above. An option has been added to force more guard digits to be used, so that basic arithmetic operations will always round perfectly. See the description of KRPERF above. These options are included for applications that use FM to check IEEE hardware arithmetic. They are not normally useful for most multiple precision calculations. The random number routine FM_RANDOM_NUMBER uses 49-digit prime numbers in a shuffled multiplicative congruential generator. Historically, some popular random number routines tried so hard for maximum speed that they were later found to fail some tests for randomness. FM_RANDOM_NUMBER tries to return high-quality random values. It is much slower than other generators, but can return about 60,000 numbers per second on a 400 MHz single-processor machine. This is usually fast enough to be used as a check for suspicious monte carlo results from other generators. For more details, see the comments in the routine. The arrays for multiple precision numbers were dimensioned starting at 0 in version 1.1, and now begin at -1. Array(-1) now holds the sign of the number instead of combining the sign with Array(2) as before. The reason for moving the sign bit is that many of the original routines, written before Fortran-90 existed, simplified the logic by temporarily making input arguments positive, working with positive values, then restoring the signs to the input arguments upon return. This became illegal under Fortran-90 when used with the derived type interface, which demands the inputs to functions for arithmetic operator overloading be declared with INTENT(IN). The common blocks of earlier versions have been replaced by module FMVALS. This makes it easier to hide the FM internal variable names from the calling program, and these variables can be initialized in the module so the initializing call to FMSET is no longer mandatory. Several new routines are provided to set or return the values for some of these variables. See the descriptions for FMSETVAR, FMFLAG, and FMVARS above. Version 1.0 used integer arrays and integer arithmetic internally to perform the multiple precision operations. Later versions use double precision arithmetic and arrays internally. This is usually faster at higher precisions, and on many machines it is also faster at lower precisions. Version 1.2 is written so that the arithmetic used can easily be changed from double precision to integer, or any other available arithmetic type. This permits the user to make the best use of a given machine's arithmetic hardware. See the EFFICIENCY discussion below. 11. EFFICIENCY When the derived type interface is used to access the FM routines, there may be a loss of speed if the arrays used to define the multiple precision data types are larger than necessary. See comment (b) in the section above on array dimensions. To take advantage of hardware architecture on different machines, the package has been designed so that the arithmetic used to perform the multiple precision operations can easily be changed. All variables that must be changed to get a different arithmetic have names beginning with 'M' and are declared using REAL (KIND(1.0D0)) ... For example, to change the package to use integer arithmetic internally, make these two changes everywhere in the FM.f90 file. Change 'REAL (KIND(1.0D0))' to 'INTEGER'. Change 'AINT (' to 'INT('. Note the blank between AINT and (. On some systems, changing 'AINT (' to '(' may give better speed. In most places in FM, an AINT function is not supposed to be changed. These are written 'AINT(', with no embedded blank, so they will not be changed by the global change above. The first of these changes must also be made throughout the files FMZM90.f90 and FMSAVE.f90. Change 'REAL (KIND(1.0D0))' to 'INTEGER'. Many of the variables in FMSAVE.f90 are initialized when they are declared, so the initialization values should be changed to integer values. Find the lines beginning '! Integer initialization' in file FMSAVE.f90 and change the values. The values needed for 32-bit integer arithmetic are next to the double precision values, but commented out. In every case, the line before the '! Integer initialization' should have '!' inserted in column 1 and the line after should have the '!' removed from column 1. If a different wordsize is used, the first call to FMSET will check the values defined in file FMSAVE.f90 and write messages (on unit KW) if any need to be changed. When changing to a different type of arithmetic, any FM arrays in the user's program must be changed to agree. If derived types are used instead of direct calls, no changes should be needed in the calling program. For example, in the test program TestFM.f90, change all 'REAL (KIND(1.0D0))' to 'INTEGER', as with the other files. This version of FM restricts the base used to be also representable in integer variables, so using precision above double usually does not save much time unless integers can also be declared at a higher precision. Using IEEE Extended would allow a base of around 10**9 to be chosen, but the delayed digit-normalization method used for multiplication and division means that a slightly smaller base like 10**8 would probably run faster. This would usually not be much faster than using the usual base 10**7 with double precision. The value of NBITS defined as a parameter in FMVALS refers to the number of bits used to represent integers in an M-variable word. Typical values for NBITS are: 24 for IEEE single precision, 32 for integer, 53 for IEEE double precision. NBITS controls only array size, so setting it too high is ok, but then the program will use slightly more memory than necessary. For cases where special compiler directives or minor re-writing of the code may improve speed, several of the most important loops in FM are identified by comments containing the string '(Inner Loop)'. -------------------------------------------------------------------------------- --------------- Routines for Real Floating-Point Operations ---------------- These are the FM routines that are designed to be called by the user. All are subroutines except logical function FMCOMP. MA, MB, MC refer to FM format numbers. In Fortran-90 and later versions of the Fortran standard, it is potentially unsafe to use the same array more than once in the calling sequence. The operation MA = MA + MB should not be written as CALL FMADD(MA,MB,MA) since the compiler is allowed to pass the three arguments with a copy in / copy out mechanism. This means the third argument, containing the result, might not be copied out last, and then a later copy out of the original input MA could destroy the computed result. One solution is to use a third array and then put the result back in MA: CALL FMADD(MA,MB,MC) CALL FMEQ(MC,MA) When the first call is doing one of the "fast" operations like addition, the extra call to move the result back to MA can cause a noticeable loss in efficiency. To avoid this, separate routines are provided for the basic arithmetic operations when the result is to be returned in the same array as one of the inputs. A routine name with a suffix of "_R1" returns the result in the first input array, and a suffix of "_R2" returns the result in the second input array. The example above would then be: CALL FMADD_R1(MA,MB) These routines each have one less argument than the original version, since the output is re-directed to one of the inputs. The result array should not be the same as any input array when the original version of the routine is used. The routines that can be used this way are listed below. For others, like CALL FMEXP(MA,MA) the relative cost of doing an extra copy is small. This one should become CALL FMEXP(MA,MB) CALL FMEQ(MB,MA) If the derived-type interface is used, as in TYPE (FM) A,B ... A = A + B there is no problem putting the result back into A, since the interface routine creates a temporary scratch array for the result of A + B, allowing copy in / copy out to work. For each of these routines there is also a version available for which the argument list is the same but all FM numbers are in packed format. The routines using packed numbers have the same names except 'FM' is replaced by 'FP' at the start of each name. FMABS(MA,MB) MB = ABS(MA) FMACOS(MA,MB) MB = ACOS(MA) FMADD(MA,MB,MC) MC = MA + MB FMADD_R1(MA,MB) MA = MA + MB FMADD_R2(MA,MB) MB = MA + MB FMADDI(MA,IVAL) MA = MA + IVAL Increment an FM number by a one word integer. Note this call does not have an "MB" result like FMDIVI and FMMPYI. FMASIN(MA,MB) MB = ASIN(MA) FMATAN(MA,MB) MB = ATAN(MA) FMATN2(MA,MB,MC) MC = ATAN2(MA,MB) FMBIG(MA) MA = Biggest FM number less than overflow. FMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA). Faster than making two separate calls. FMCOMP(MA,LREL,MB) Logical comparison of MA and MB. LREL is a CHARACTER*2 value identifying which of the six comparisons is to be made. Example: IF (FMCOMP(MA,'GE',MB)) ... Also can be: IF (FMCOMP(MA,'>=',MB)) ... CHARACTER*1 is ok: IF (FMCOMP(MA,'>',MB)) ... FMCONS Set several saved constants that depend on MBASE, the base being used. FMCONS should be called immediately after changing MBASE. FMCOS(MA,MB) MB = COS(MA) FMCOSH(MA,MB) MB = COSH(MA) FMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA). Faster than making two separate calls. FMDIG(NSTACK,KST) Find a set of precisions to use during Newton iteration for finding a simple root starting with about double precision accuracy. FMDIM(MA,MB,MC) MC = DIM(MA,MB) FMDIV(MA,MB,MC) MC = MA / MB FMDIV_R1(MA,MB) MA = MA / MB FMDIV_R2(MA,MB) MB = MA / MB FMDIVI(MA,IVAL,MB) MB = MA/IVAL IVAL is a one word integer. FMDIVI_R1(MA,IVAL) MA = MA/IVAL FMDP2M(X,MA) MA = X Convert from double precision to FM. FMDPM(X,MA) MA = X Convert from double precision to FM. Faster than FMDP2M, but MA agrees with X only to D.P. accuracy. See the comments in the two routines. FMEQ(MA,MB) MB = MA Both have precision NDIG. This is the version to use for standard B = A statements. FMEQU(MA,MB,NA,NB) MB = MA Version for changing precision. MA has NA digits (i.e., MA was computed using NDIG = NA), and MB will be defined having NB digits. MB is rounded if NB < NA MB is zero-padded if NB > NA FMEXP(MA,MB) MB = EXP(MA) FMFLAG(K) K = KFLAG get the value of the FM condition flag -- stored in the internal FM variable KFLAG in module FMVALS. FMFORM(FORM,MA,STRING) MA is converted to a character string using format FORM and returned in STRING. FORM can represent I, F, E, or 1PE formats. Example: CALL FMFORM('F60.40',MA,STRING) FMFPRT(FORM,MA) Print MA on unit KW using FORM format. FMI2M(IVAL,MA) MA = IVAL Convert from one word integer to FM. FMINP(LINE,MA,LA,LB) MA = LINE Input conversion. Convert LINE(LA) through LINE(LB) from characters to FM. FMINT(MA,MB) MB = INT(MA) Integer part of MA. FMIPWR(MA,IVAL,MB) MB = MA**IVAL Raise an FM number to a one word integer power. FMLG10(MA,MB) MB = LOG10(MA) FMLN(MA,MB) MB = LOG(MA) FMLNI(IVAL,MA) MA = LOG(IVAL) Natural log of a one word integer. FMM2DP(MA,X) X = MA Convert from FM to double precision. FMM2I(MA,IVAL) IVAL = MA Convert from FM to integer. FMM2SP(MA,X) X = MA Convert from FM to single precision. FMMAX(MA,MB,MC) MC = MAX(MA,MB) FMMIN(MA,MB,MC) MC = MIN(MA,MB) FMMOD(MA,MB,MC) MC = MA mod MB FMMPY(MA,MB,MC) MC = MA * MB FMMPY_R1(MA,MB) MA = MA * MB FMMPY_R2(MA,MB) MB = MA * MB FMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer. FMMPYI_R1(MA,IVAL) MA = MA*IVAL FMNINT(MA,MB) MB = NINT(MA) Nearest FM integer. FMOUT(MA,LINE,LB) LINE = MA Convert from FM to character. LINE is a character array of length LB. FMPI(MA) MA = pi FMPRNT(MA) Print MA on unit KW using current format. FMPWR(MA,MB,MC) MC = MA**MB FM_RANDOM_NUMBER(X) X is returned as a double precision random number, uniform on (0,1). High-quality, long-period generator. Note that X is double precision, unlike the similar Fortran intrinsic random number routine, which returns a single-precision result. See the comments in section 10 below and also those in the routine for more details. FMREAD(KREAD,MA) MA is returned after reading one (possibly multi-line) FM number on unit KREAD. This routine reads numbers written by FMWRIT. FMRPWR(MA,K,J,MB) MB = MA**(K/J) Rational power. Faster than FMPWR for functions like the cube root. FMSET(NPREC) Set the internal FM variables so that the precision is at least NPREC base 10 digits plus three base 10 guard digits. FMSETVAR(STRING) Define a new value for one of the internal FM variables in module FMVALS that controls one of the FM options. STRING has the form variable = value. Example: To change the screen width for FM output: CALL FMSETVAR(' KSWIDE = 120 ') The variables that can be changed and the options they control are listed in sections 2 through 6 above. Only one variable can be set per call. The variable name in STRING must have no embedded blanks. The value part of STRING can be in any numerical format, except in the case of variable CMCHAR, which is character type. To set CMCHAR to 'E', don't use any quotes in STRING: CALL FMSETVAR(' CMCHAR = E ') FMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer. FMSIN(MA,MB) MB = SIN(MA) FMSINH(MA,MB) MB = SINH(MA) FMSP2M(X,MA) MA = X Convert from single precision to FM. FMSQR(MA,MB) MB = MA * MA Faster than FMMPY. FMSQR_R1(MA) MA = MA * MA FMSQRT(MA,MB) MB = SQRT(MA) FMSQRT_R1(MA) MA = SQRT(MA) FMST2M(STRING,MA) MA = STRING Convert from character string to FM. STRING may be in any numerical format. Often more convenient than FMINP, which converts an array of CHARACTER*1 values. Example: CALL FMST2M('123.4',MA) FMSUB(MA,MB,MC) MC = MA - MB FMSUB_R1(MA,MB) MA = MA - MB FMSUB_R2(MA,MB) MB = MA - MB FMTAN(MA,MB) MB = TAN(MA) FMTANH(MA,MB) MB = TANH(MA) FMULP(MA,MB) MB = One Unit in the Last Place of MA. FMVARS Write the current values of the internal FM variables on unit KW. FMWRIT(KWRITE,MA) Write MA on unit KWRITE. Multi-line numbers will have '&' as the last nonblank character on all but the last line. These numbers can then be read easily using FMREAD. These are the Gamma and Related Functions. FMBERN(N,MA,MB) MB = MA*B(N) Multiply by Nth Bernoulli number FMBETA(MA,MB,MC) MC = Beta(MA,MB) FMCOMB(MA,MB,MC) MC = Combination MA choose MB (Binomial coeff.) FMEULR(MA) MA = Euler's constant ( 0.5772156649... ) FMFACT(MA,MB) MB = MA Factorial (Gamma(MA+1)) FMGAM(MA,MB) MB = Gamma(MA) FMIBTA(MX,MA,MB,MC) MC = Incomplete Beta(MX,MA,MB) FMIGM1(MA,MB,MC) MC = Incomplete Gamma(MA,MB). Lower case Gamma(a,x) FMIGM2(MA,MB,MC) MC = Incomplete Gamma(MA,MB). Upper case Gamma(a,x) FMLNGM(MA,MB) MB = Ln(Gamma(MA)) FMPGAM(N,MA,MB) MB = Polygamma(N,MA) (Nth derivative of Psi) FMPOCH(MA,N,MB) MB = MA*(MA+1)*(MA+2)*...*(MA+N-1) (Pochhammer) FMPSI(MA,MB) MB = Psi(MA) (Derivative of Ln(Gamma(MA)) -------------------------------------------------------------------------------- --------------------- Routines for Integer Operations ---------------------- These are the integer routines that are designed to be called by the user. All are subroutines except logical function IMCOMP. MA, MB, MC refer to IM format numbers. In each case the version of the routine to handle packed IM numbers has the same name, with 'IM' replaced by 'IP'. IMABS(MA,MB) MB = ABS(MA) IMADD(MA,MB,MC) MC = MA + MB IMBIG(MA) MA = Biggest IM number less than overflow. IMCOMP(MA,LREL,MB) Logical comparison of MA and MB. LREL is a CHARACTER*2 value identifying which of the six comparisons is to be made. Example: IF (IMCOMP(MA,'GE',MB)) ... Also can be: IF (IMCOMP(MA,'>=',MB)) CHARACTER*1 is ok: IF (IMCOMP(MA,'>',MB)) ... IMDIM(MA,MB,MC) MC = DIM(MA,MB) IMDIV(MA,MB,MC) MC = int(MA/MB) Use IMDIVR if the remainder is also needed. IMDIVI(MA,IVAL,MB) MB = int(MA/IVAL) IVAL is a one word integer. Use IMDVIR to get the remainder also. IMDIVR(MA,MB,MC,MD) MC = int(MA/MB), MD = MA mod MB When both the quotient and remainder are needed, this routine is twice as fast as calling both IMDIV and IMMOD. IMDVIR(MA,IVAL,MB,IREM) MB = int(MA/IVAL), IREM = MA mod IVAL IVAL and IREM are one word integers. IMEQ(MA,MB) MB = MA IMFM2I(MAFM,MB) MB = MAFM Convert from real (FM) format to integer (IM) format. IMFORM(FORM,MA,STRING) MA is converted to a character string using format FORM and returned in STRING. FORM can represent I, F, E, or 1PE formats. Example: CALL IMFORM('I70',MA,STRING) IMFPRT(FORM,MA) Print MA on unit KW using FORM format. IMGCD(MA,MB,MC) MC = greatest common divisor of MA and MB. IMI2FM(MA,MBFM) MBFM = MA Convert from integer (IM) format to real (FM) format. IMI2M(IVAL,MA) MA = IVAL Convert from one word integer to IM. IMINP(LINE,MA,LA,LB) MA = LINE Input conversion. Convert LINE(LA) through LINE(LB) from characters to IM. IMM2DP(MA,X) X = MA Convert from IM to double precision. IMM2I(MA,IVAL) IVAL = MA Convert from IM to one word integer. IMMAX(MA,MB,MC) MC = MAX(MA,MB) IMMIN(MA,MB,MC) MC = MIN(MA,MB) IMMOD(MA,MB,MC) MC = MA mod MB IMMPY(MA,MB,MC) MC = MA*MB IMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer. IMMPYM(MA,MB,MC,MD) MD = MA*MB mod MC Slightly faster than calling IMMPY and IMMOD separately, and it works for cases where IMMPY would return OVERFLOW. IMOUT(MA,LINE,LB) LINE = MA Convert from IM to character. LINE is a character array of length LB. IMPMOD(MA,MB,MC,MD) MD = MA**MB mod MC IMPRNT(MA) Print MA on unit KW. IMPWR(MA,MB,MC) MC = MA**MB IMREAD(KREAD,MA) MA is returned after reading one (possibly multi-line) IM number on unit KREAD. This routine reads numbers written by IMWRIT. IMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer. IMSQR(MA,MB) MB = MA*MA Faster than IMMPY. IMST2M(STRING,MA) MA = STRING Convert from character string to IM. Often more convenient than IMINP, which converts an array of CHARACTER*1 values. Example: CALL IMST2M('12345678901',MA) IMSUB(MA,MB,MC) MC = MA - MB IMWRIT(KWRITE,MA) Write MA on unit KWRITE. Multi-line numbers will have '&' as the last nonblank character on all but the last line. These numbers can then be read easily using IMREAD. -------------------------------------------------------------------------------- -------------- Routines for Complex Floating-Point Operations -------------- These are the complex routines that are designed to be called by the user. All are subroutines, and in each case the version of the routine to handle packed ZM numbers has the same name, with 'ZM' replaced by 'ZP'. MA, MB, MC refer to ZM format complex numbers. MAFM, MBFM, MCFM refer to FM format real numbers. INTEG is a Fortran INTEGER variable. ZVAL is a Fortran COMPLEX variable. ZMABS(MA,MBFM) MBFM = ABS(MA) Result is real. ZMACOS(MA,MB) MB = ACOS(MA) ZMADD(MA,MB,MC) MC = MA + MB ZMADDI(MA,INTEG) MA = MA + INTEG Increment an ZM number by a one word integer. Note this call does not have an "MB" result like ZMDIVI and ZMMPYI. ZMARG(MA,MBFM) MBFM = Argument(MA) Result is real. ZMASIN(MA,MB) MB = ASIN(MA) ZMATAN(MA,MB) MB = ATAN(MA) ZMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA). Faster than 2 calls. ZMCMPX(MAFM,MBFM,MC) MC = CMPLX(MAFM,MBFM) ZMCONJ(MA,MB) MB = CONJG(MA) ZMCOS(MA,MB) MB = COS(MA) ZMCOSH(MA,MB) MB = COSH(MA) ZMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA). Faster than 2 calls. ZMDIV(MA,MB,MC) MC = MA / MB ZMDIVI(MA,INTEG,MB) MB = MA / INTEG ZMEQ(MA,MB) MB = MA ZMEQU(MA,MB,NDA,NDB) MB = MA Version for changing precision. (NDA and NDB are as in FMEQU) ZMEXP(MA,MB) MB = EXP(MA) ZMFORM(FORM1,FORM2,MA,STRING) STRING = MA MA is converted to a character string using format FORM1 for the real part and FORM2 for the imaginary part. The result is returned in STRING. FORM1 and FORM2 can represent I, F, E, or 1PE formats. Example: CALL ZMFORM('F20.10','F15.10',MA,STRING) A 1PE in the first format does not carry over to the other format descriptor, as it would in an ordinary FORMAT statement. ZMFPRT(FORM1,FORM2,MA) Print MA on unit KW using formats FORM1 and FORM2. ZMI2M(INTEG,MA) MA = CMPLX(INTEG,0) ZM2I2M(INTEG1,INTEG2,MA) MA = CMPLX(INTEG1,INTEG2) ZMIMAG(MA,MBFM) MBFM = IMAG(MA) Imaginary part. ZMINP(LINE,MA,LA,LB) MA = LINE Input conversion. Convert LINE(LA) through LINE(LB) from characters to ZM. LINE is a character array of length at least LB. ZMINT(MA,MB) MB = INT(MA) Integer part of both Real and Imaginary parts of MA. ZMIPWR(MA,INTEG,MB) MB = MA ** INTEG Integer power function. ZMLG10(MA,MB) MB = LOG10(MA) ZMLN(MA,MB) MB = LOG(MA) ZMM2I(MA,INTEG) INTEG = INT(REAL(MA)) ZMM2Z(MA,ZVAL) ZVAL = MA ZMMPY(MA,MB,MC) MC = MA * MB ZMMPYI(MA,INTEG,MB) MB = MA * INTEG ZMNINT(MA,MB) MB = NINT(MA) Nearest integer of both Real and Imaginary. ZMOUT(MA,LINE,LB,LAST1,LAST2) LINE = MA Convert from FM to character. LINE is the returned character*1 array. LB is the dimensioned size of LINE. LAST1 is returned as the position in LINE of the last character of REAL(MA). LAST2 is returned as the position in LINE of the last character of AIMAG(MA). ZMPRNT(MA) Print MA on unit KW using current format. ZMPWR(MA,MB,MC) MC = MA ** MB ZMREAD(KREAD,MA) MA is returned after reading one (possibly multi-line) ZM number on unit KREAD. This routine reads numbers written by ZMWRIT. ZMREAL(MA,MBFM) MBFM = REAL(MA) Real part. ZMRPWR(MA,IVAL,JVAL,MB) MB = MA ** (IVAL/JVAL) ZMSET(NPREC) Set precision to the equivalent of a few more than NPREC base 10 digits. This is now the same as FMSET, but is retained for compatibility with earlier versions of the package. ZMSIN(MA,MB) MB = SIN(MA) ZMSINH(MA,MB) MB = SINH(MA) ZMSQR(MA,MB) MB = MA*MA Faster than ZMMPY. ZMSQRT(MA,MB) MB = SQRT(MA) ZMST2M(STRING,MA) MA = STRING Convert from character string to ZM. Often more convenient than ZMINP, which converts an array of CHARACTER*1 values. Example: CALL ZMST2M('123.4+5.67i',MA). ZMSUB(MA,MB,MC) MC = MA - MB ZMTAN(MA,MB) MB = TAN(MA) ZMTANH(MA,MB) MB = TANH(MA) ZMWRIT(KWRITE,MA) Write MA on unit KWRITE. Multi-line numbers are formatted for automatic reading with ZMREAD. ZMZ2M(ZVAL,MA) MA = ZVAL ================================================================================ ================================================================================ SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'Fortran90' then mkdir 'Fortran90' fi cd 'Fortran90' if test ! -d 'Sp' then mkdir 'Sp' fi cd 'Sp' if test ! -d 'Drivers' then mkdir 'Drivers' fi cd 'Drivers' if test -f 'SAMPLE.CHK' then echo shar: will not over-write existing file "'SAMPLE.CHK'" else cat << "SHAR_EOF" > 'SAMPLE.CHK' Sample 1. Real root of f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0. Iteration Newton Approximation 0 3.120000000000000000000000000000000000000000000000000000000000 1 3.120656718532108533919391265947916793506741449899073468862023 2 3.120656215327022122238354686569835883519704471397219749798884 3 3.120656215326726500470956115551705969611230193197937042123082 4 3.120656215326726500470956013523797484654623935599078168006617 5 3.120656215326726500470956013523797484654623935599066014988828 6 3.120656215326726500470956013523797484654623935599066014988828 Sample 2. Find the root above to 300 decimal places. 3.12065621532672650047095601352379748465462393559906601498882843581902649995179546 89783257450017151095811923431332682839420040840535954560118152245371792881305271951 01711893889821240366205830730398354737691328200011005827350420283867070989561927541 348452154928259189115694520078941581838752951201099960 Sample 3. 109 terms were added in the Zeta sum Zeta(3) = 1.202056903159594285399738161511449990764986292340498881792272 Sample 4. 57 values were checked before finding a prime p. p = 5468317884572019103692012212053793153845065543480825746529998049913561 Sample 5. Check that Gamma(1/2) = Sqrt(pi) Gamma(1/2) = 1.772453850905516027298167483341145182797549456122387128213808 Sample 6. Psi and Polygamma functions. Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) = .013499486145413024755107829105035147950644978635837270816327 Sample 7. Incomplete gamma and Gamma functions. Probability = .19373313011487144632751025918250599953472318607121386973066 Sample 8. Complex root of f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0. Iteration Newton Approximation 0 .560000000000000000000000000000 + 1.060000000000000000000000000000 i 1 .561964780980333719745880263787 + 1.061135231152741154895778904059 i 2 .561958308372772219534516409947 + 1.061134679566247415769456345141 i 3 .561958308335403235495113920123 + 1.061134679604332556981397796290 i 4 .561958308335403235498111195347 + 1.061134679604332556983391239059 i 5 .561958308335403235498111195347 + 1.061134679604332556983391239059 i Sample 9. 44 terms were added to get Exp(1.23-2.34i) Result= -2.379681796854777515745457977697 - 2.458032970832342652397461908326 i Sample 10. Exception handling. Iterate Exp(x) starting at 1.0 until overflow occurs. Iteration 1 2.718281828459045235360287471352662497757M+0 Iteration 2 1.515426224147926418976043027262991190553M+1 Iteration 3 3.814279104760220592209219594098203571024M+6 Iteration 4 2.331504399007195462289689911012137666332M+1656520 Iteration 5 + OVERFLOW Overflow was correctly detected. All results were ok. SHAR_EOF fi # end of overwriting check if test -f 'SampleFM.f90' then echo shar: will not over-write existing file "'SampleFM.f90'" else cat << "SHAR_EOF" > 'SampleFM.f90' PROGRAM SAMPLE ! David M. Smith ! This is a sample program using the FM Fortran-90 modules for ! doing arithmetic using the FM, IM, and ZM derived types. ! The output is saved in file SAMPLE.LOG. A comparison file, ! SAMPLE.CHK, is provided showing the expected output from 32-bit ! (IEEE arithmetic) machines. When run on other computers, all the ! numerical results should still be the same, but the number of terms ! needed for some of the results might be slightly different. The ! program checks all the results and the last line of the log file ! should be "All results were ok." ! In a few places, an explicit call is made to an FM or ZM routine. ! For a call like CALL FM_FORM('F65.60',MAFM,ST1), note that the ! "FM_" form is used since MAFM is a TYPE (FM) variable and not just ! an array. See the discussion in FMZM90.f. USE FMZM IMPLICIT NONE TYPE ( FM ) MAFM,MBFM,MCFM,MDFM TYPE ( IM ) MAIM,MBIM,MCIM TYPE ( ZM ) MAZM,MBZM,MCZM,MDZM CHARACTER(80) :: ST1 CHARACTER(175) :: FMT INTEGER ITER,J,K,KLOG,LFLAG,NERROR INTEGER SEED(7) DOUBLE PRECISION VALUE ! Write output to the screen (unit *), and also to the ! file SAMPLE.LOG. KLOG = 18 OPEN (KLOG,FILE='SAMPLE.LOG') NERROR = 0 ! 1. Find a root of the equation ! f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0. ! Set precision to give at least 60 significant digits. CALL FM_SET(60) ! Use Newton's method with initial guess x = 3.12. ! This version is not tuned for speed. See the FMSQRT ! routine for possible ways to increase speed. ! Horner's rule is used to evaluate the function. ! MAFM is the previous iterate. ! MBFM is the current iterate. ! TO_FM is a function for converting other types of numbers ! to type FM. Note that TO_FM(3.12) converts the REAL ! constant to FM, but it is accurate only to single ! precision. TO_FM(3.12D0) agrees with 3.12 to double ! precision accuracy, and TO_FM('3.12') or ! TO_FM(312)/TO_FM(100) agrees to full FM accuracy. ! Here, TO_FM(3.12) would be ok, since Newton iteration ! will correct the error coming from single precision, ! but it is a good habit to use the more accurate form. MAFM = TO_FM('3.12') ! Print the first iteration. FMT = "(//' Sample 1. Real root of f(x) = x**5 - 3x**4 + ',"// & "'x**3 - 4x**2 + x - 6 = 0.'///" // & "' Iteration Newton Approximation')" WRITE (*,FMT) WRITE (KLOG,FMT) ! FM_FORMAT is a formatting function that returns a ! character string (of length 200). ! Avoid using FM_FORMAT in the write list, since this ! function itself does internal WRITE operations, and ! some compilers object to recursive WRITE references. ST1 = FM_FORMAT('F65.60',MAFM) WRITE (* ,"(/I10,4X,A)") 0,TRIM(ST1) WRITE (KLOG,"(/I10,4X,A)") 0,TRIM(ST1) DO ITER = 1, 10 ! MCFM is f(MAFM). MCFM = ((((MAFM-3)*MAFM+1)*MAFM-4)*MAFM+1)*MAFM-6 ! MDFM is f'(MAFM). MDFM = (((5*MAFM-12)*MAFM+3)*MAFM-8)*MAFM+1 MBFM = MAFM - MCFM/MDFM ! Print each iteration. ! FM_FORM is a formatting subroutine. FM_FORM can ! handle output strings longer that 200 characters. CALL FM_FORM('F65.60',MBFM,ST1) WRITE (* ,"(/I10,4X,A)") ITER,TRIM(ST1) WRITE (KLOG,"(/I10,4X,A)") ITER,TRIM(ST1) ! Stop iterating if MAFM and MBFM agree to over 60 places. MDFM = ABS(MAFM-MBFM) IF (MDFM < 1.0D-61) EXIT ! Set MAFM = MBFM for the next iteration. MAFM = MBFM ENDDO ! Check the answer. MCFM = TO_FM('3.120656215326726500470956013523797484654623'// & '9355990660149888284358') ! It is slightly safer to do this test with .NOT. instead of ! IF (ABS(MCFM-MBFM) >= 1.0D-61) THEN ! because if the result of ABS(MCFM-MBFM) is FM's UNKNOWN value, ! the comparison returns false for all comparisons. IF (.NOT.(ABS(MCFM-MBFM) < 1.0D-61)) THEN NERROR = NERROR + 1 WRITE (* ,"(/' Error in sample case number 1.'/)") WRITE (KLOG,"(/' Error in sample case number 1.'/)") ENDIF ! 2. Higher Precision. Compute the root above to 300 decimal places. CALL FM_SET(300) ! It is tempting to just say MAFM = MCFM here to initialize the ! start of the higher precision iterations to be the check value ! defined above. That will not work, because precision has ! changed. Most of the digits of MCFM may be undefined at the ! new precision. ! The usual way to pad a lower precision value with zeros when ! raising precision is to use subroutine FM_EQU, but here it is ! easier to define MAFM from scratch at the new precision. MAFM = TO_FM('3.120656215326726500470956013523797484654623'// & '9355990660149888284358') DO ITER = 1, 10 ! MCFM is f(MAFM). MCFM = ((((MAFM-3)*MAFM+1)*MAFM-4)*MAFM+1)*MAFM-6 ! MDFM is f'(MAFM). MDFM = (((5*MAFM-12)*MAFM+3)*MAFM-8)*MAFM+1 MBFM = MAFM - MCFM/MDFM ! Stop iterating if MAFM and MBFM agree to over 300 places. MDFM = ABS(MAFM-MBFM) IF (MDFM < TO_FM('1.0E-301')) EXIT ! Set MAFM = MBFM for the next iteration. MAFM = MBFM ENDDO ! For very high precision output, it is sometimes more ! convenient to use FM_PRNT to format and print the numbers, ! since the line breaks are handled automatically. ! The unit number for the output, KW, and the format codes ! to be used, JFORM1 and JFORM2, are internal FM variables. ! Subroutine FMSETVAR is used to re-define these, and the ! new values will remain in effect for any further calls ! to FM_PRNT. ! Other variables that can be changed and the options they ! control are listed in the documentation at the top of file ! FM.f. ! Set the format to F305.300 CALL FMSETVAR(' JFORM1 = 2 ') CALL FMSETVAR(' JFORM2 = 300 ') ! Set the output screen width to 90 columns. CALL FMSETVAR(' KSWIDE = 90 ') WRITE (* ,"(///' Sample 2. Find the root above to 300 decimal places.'/)") WRITE (KLOG,"(///' Sample 2. Find the root above to 300 decimal places.'/)") ! Write to the log file. CALL FMSETVAR(' KW = 18 ') CALL FM_PRNT(MBFM) ! Write to the screen (unit 6). CALL FMSETVAR(' KW = 6 ') CALL FM_PRNT(MBFM) ! Check the answer. MCFM = TO_FM('3.12065621532672650047095601352379748465462393559906601'// & '4988828435819026499951795468978325745001715109581192343'// & '1332682839420040840535954560118152245371792881305271951'// & '0171189388982124036620583073039835473769132820001100582'// & '7350420283867070989561927541348452154928259189115694520'// & '0789415818387529512010999602155131321076797099026664236') IF (.NOT.(ABS(MCFM-MBFM) < TO_FM('1.0E-301'))) THEN NERROR = NERROR + 1 WRITE (* ,"(/' Error in sample case number 2.'/)") WRITE (KLOG,"(/' Error in sample case number 2.'/)") ENDIF ! 3. Compute the Riemann Zeta function for s=3. ! Use Gosper's formula: Zeta(3) = ! (5/4)*Sum[ (-1)**k * (k!)**2 / ((k+1)**2 * (2k+1)!) ] ! while k = 0, 1, .... ! MAFM is the current partial sum. ! MBFM is the current term. ! MCFM is k! ! MDFM is (2k+1)! CALL FM_SET(60) MAFM = 1 MCFM = 1 MDFM = 1 DO K = 1, 200 MCFM = K*MCFM J = 2*K*(2*K+1) MDFM = J*MDFM MBFM = MCFM**2 J = (K+1)*(K+1) MBFM = (MBFM/J)/MDFM IF (MOD(K,2) == 0) THEN MAFM = MAFM + MBFM ELSE MAFM = MAFM - MBFM ENDIF ! Test for convergence. IF (MAFM-MBFM == MAFM) THEN WRITE (* , & "(///' Sample 3.',8X,I5,' terms were added in the Zeta sum'/)") K WRITE (KLOG, & "(///' Sample 3.',8X,I5,' terms were added in the Zeta sum'/)") K EXIT ENDIF ENDDO ! Print the result. MAFM = (5*MAFM)/4 CALL FM_FORM('F62.60',MAFM,ST1) WRITE (* ,"(' Zeta(3) = ',A)") TRIM(ST1) WRITE (KLOG,"(' Zeta(3) = ',A)") TRIM(ST1) ! Check the answer. MCFM = TO_FM('1.20205690315959428539973816151144999076498'// & '6292340498881792271555') IF (.NOT.(ABS(MAFM-MCFM) < 1.0D-61)) THEN NERROR = NERROR + 1 WRITE (* ,"(/' Error in sample case number 3.'/)") WRITE (KLOG,"(/' Error in sample case number 3.'/)") ENDIF ! 4. Integer multiple precision calculations. ! Fermat's theorem says x**(p-1) mod p = 1 ! when p is prime and x is not a multiple of p. ! If x**(p-1) mod p gives 1 for some p with ! several different x's, then it is very likely ! that p is prime (but it is not certain until ! further tests are done). ! Find a 70-digit number p that is "probably" prime. ! Use FM_RANDOM_NUMBER to generate a random 70-digit ! starting value and search for a prime from that point. ! Initialize the generator. ! Note that VALUE is double precision, unlike the similar ! Fortran intrinsic random number routine, which returns ! a single-precision result. CALL FM_SET(80) SEED = (/ 2718281,8284590,4523536,0287471,3526624,9775724,7093699 /) CALL FM_RANDOM_SEED(PUT=SEED) ! MAIM is the value p being tested. MAIM = 0 MCIM = TO_IM(10)**13 DO J = 1, 6 CALL FM_RANDOM_NUMBER(VALUE) MBIM = 1.0D+13*VALUE MAIM = MAIM*MCIM + MBIM ENDDO MCIM = TO_IM(10)**70 MAIM = MOD(MAIM,MCIM) ! To speed up the search, test only values that are ! not multiples of 2, 3, 5, 7, 11, 13. K = 2*3*5*7*11*13 MAIM = (MAIM/K)*K + K + 1 MCIM = 3 DO J = 1, 100 MBIM = MAIM - 1 ! Compute 3**(p-1) mod p MCIM = POWER_MOD(MCIM,MBIM,MAIM) IF (MCIM == 1) THEN ! Check that 7**(p-1) mod p is also 1. MCIM = 7 MCIM = POWER_MOD(MCIM,MBIM,MAIM) IF (MCIM == 1) THEN FMT = "(///' Sample 4.',8X,I5,' values were"// & " checked before finding a prime p.'/)" WRITE (* ,FMT) J WRITE (KLOG,FMT) J EXIT ENDIF ENDIF MCIM = 3 MAIM = MAIM + K ENDDO ! Print the result. CALL IM_FORM('I72',MAIM,ST1) WRITE (* ,"(' p =',A)") TRIM(ST1) WRITE (KLOG,"(' p =',A)") TRIM(ST1) ! Check the answer. MCIM = TO_IM('546831788457201910369201221205379315384'// & '5065543480825746529998049913561') IF (.NOT.(MAIM == MCIM)) THEN NERROR = NERROR + 1 WRITE (* ,"(/' Error in sample case number 4.'/)") WRITE (KLOG,"(/' Error in sample case number 4.'/)") ENDIF ! 5. Gamma function. ! Check that Gamma(1/2) is Sqrt(pi) CALL FM_SET(60) WRITE (* ,"(///' Sample 5. Check that Gamma(1/2) = Sqrt(pi)'/)") WRITE (KLOG,"(///' Sample 5. Check that Gamma(1/2) = Sqrt(pi)'/)") MBFM = GAMMA(TO_FM('0.5')) ! Print the result. CALL FM_FORM('F62.60',MBFM,ST1) WRITE (* ,"(' Gamma(1/2) = ',A)") TRIM(ST1) WRITE (KLOG,"(' Gamma(1/2) = ',A)") TRIM(ST1) ! Check the answer. MCFM = SQRT(4*ATAN(TO_FM(1))) IF (.NOT.(ABS(MCFM-MBFM) < 1.0D-61)) THEN NERROR = NERROR + 1 WRITE (* ,"(/' Error in sample case number 5.'/)") WRITE (KLOG,"(/' Error in sample case number 5.'/)") ENDIF ! 6. Psi and Polygamma functions. ! Rational series can often be summed using these functions. ! Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) = ! 16*(Psi(1) - Psi(9/8)) + Polygamma(1,1) + Polygamma(1,9/8) ! Ref: Abramowitz & Stegun, Handbook of Mathematical Functions, ! chapter 6, Example 10. WRITE (* ,"(///' Sample 6. Psi and Polygamma functions.'/)") WRITE (KLOG,"(///' Sample 6. Psi and Polygamma functions.'/)") MBFM = 16*(PSI(TO_FM(1)) - PSI(TO_FM(9)/8)) + & POLYGAMMA(1,TO_FM(1)) + POLYGAMMA(1,TO_FM(9)/8) ! Print the result. CALL FM_FORM('F65.60',MBFM,ST1) WRITE (* ,"(' Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) = '/9X,A)") TRIM(ST1) WRITE (KLOG,"(' Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) = '/9X,A)") TRIM(ST1) ! Check the answer. MCFM = TO_FM('1.34994861454130247551078291050351479506449786'// & '35837270816327396M-2') IF (.NOT.(ABS(MCFM-MBFM) < 1.0D-61)) THEN NERROR = NERROR + 1 WRITE (* ,"(/' Error in sample case number 6.'/)") WRITE (KLOG,"(/' Error in sample case number 6.'/)") ENDIF ! 7. Incomplete gamma and Gamma functions. ! Find the probability that an observed chi-square for a correct ! model should be less that 2.3 when the number of degrees of ! freedom is 5. ! Ref: Knuth, Volume 2, 3rd ed., Page 56, and Press, Flannery, ! Teukolsky, Vetterling, Numerical Recipes, 1st ed., Page 165. WRITE (* ,"(///' Sample 7. Incomplete gamma and Gamma functions.'/)") WRITE (KLOG,"(///' Sample 7. Incomplete gamma and Gamma functions.'/)") MAFM = TO_FM(5)/2 MBFM = INCOMPLETE_GAMMA1(MAFM,TO_FM('2.3')/2) / GAMMA(MAFM) ! Print the result. CALL FM_FORM('F61.60',MBFM,ST1) WRITE (* ,"(' Probability = ',A)") TRIM(ST1) WRITE (KLOG,"(' Probability = ',A)") TRIM(ST1) ! Check the answer. MCFM = TO_FM('0.193733130114871446327510259182505999534723186'// & '07121386973066283739') IF (.NOT.(ABS(MCFM-MBFM) < 1.0D-61)) THEN NERROR = NERROR + 1 WRITE (* ,"(/' Error in sample case number 7.'/)") WRITE (KLOG,"(/' Error in sample case number 7.'/)") ENDIF ! Complex arithmetic. ! Set precision to give at least 30 significant digits. CALL FM_SET(30) ! 8. Find a complex root of the equation ! f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0. ! Newton's method with initial guess x = .56 + 1.06 i. ! This version is not tuned for speed. See the ZMSQRT ! routine for possible ways to increase speed. ! Horner's rule is used to evaluate the function. ! MAZM is the previous iterate. ! MBZM is the current iterate. MAZM = TO_ZM('.56 + 1.06 i') ! Print the first iteration. FMT = "(///' Sample 8. Complex root of f(x) = x**5 - 3x**4 + ',"// & "'x**3 - 4x**2 + x - 6 = 0.'///" // & "' Iteration Newton Approximation')" WRITE (*,FMT) WRITE (KLOG,FMT) CALL ZM_FORM('F32.30','F32.30',MAZM,ST1) WRITE (* ,"(/I6,4X,A)") 0,TRIM(ST1) WRITE (KLOG,"(/I6,4X,A)") 0,TRIM(ST1) DO ITER = 1, 10 ! MCZM is f(MAZM). MCZM = ((((MAZM-3)*MAZM+1)*MAZM-4)*MAZM+1)*MAZM-6 ! MDZM is f'(MAZM). MDZM = (((5*MAZM-12)*MAZM+3)*MAZM-8)*MAZM+1 MBZM = MAZM - MCZM/MDZM ! Print each iteration. CALL ZM_FORM('F32.30','F32.30',MBZM,ST1) WRITE (* ,"(/I6,4X,A)") ITER,TRIM(ST1) WRITE (KLOG,"(/I6,4X,A)") ITER,TRIM(ST1) ! Stop iterating if MAZM and MBZM agree to over 30 places. IF (ABS(MAZM-MBZM) < 1.0D-31) EXIT ! Set MAZM = MBZM for the next iteration. MAZM = MBZM ENDDO ! Check the answer. MCZM = TO_ZM('0.561958308335403235498111195347453 +'// & '1.061134679604332556983391239058885 i') IF (.NOT.(ABS(MCZM-MBZM) < 1.0D-31)) THEN NERROR = NERROR + 1 WRITE (* ,"(/' Error in sample case number 8.'/)") WRITE (KLOG,"(/' Error in sample case number 8.'/)") ENDIF ! 9. Compute Exp(1.23-2.34i). ! Use the direct Taylor series. See the ZMEXP routine ! for a faster way to get Exp(x). ! MAZM is x. ! MBZM is the current term, x**n/n!. ! MCZM is the current partial sum. MAZM = TO_ZM('1.23-2.34i') MBZM = 1 MCZM = 1 DO K = 1, 100 MBZM = MBZM*MAZM/K MDZM = MCZM + MBZM ! Test for convergence. IF (MDZM == MCZM) THEN FMT = "(///' Sample 9.',8X,I5,' terms were added ',"// & "'to get Exp(1.23-2.34i)'/)" WRITE (* ,FMT) K WRITE (KLOG,FMT) K EXIT ENDIF MCZM = MDZM ENDDO ! Print the result. CALL ZM_FORM('F33.30','F32.30',MCZM,ST1) WRITE (* ,"(' Result= ',A)") TRIM(ST1) WRITE (KLOG,"(' Result= ',A)") TRIM(ST1) ! Check the answer. MDZM = TO_ZM('-2.379681796854777515745457977696745 -'// & ' 2.458032970832342652397461908326042 i') IF (.NOT.(ABS(MDZM-MCZM) < 1.0D-31)) THEN NERROR = NERROR + 1 WRITE (* ,"(/' Error in sample case number 9.'/)") WRITE (KLOG,"(/' Error in sample case number 9.'/)") ENDIF ! 10. Exception handling. ! Iterate (real) Exp(x) starting at 1.0 until overflow occurs. ! ! Testing type FM numbers directly using an IF can ! be tricky. When MAFM is +overflow, the statement ! IF (MAFM == TO_FM(' +OVERFLOW ')) THEN ! will return false, since the comparison routine cannot be ! sure that two different overflowed results would have been ! equal if the overflow threshold had been higher. ! ! In this case, calling subroutine FMFLAG will tell when ! an exception has happened. ! ! However, for a complicated expression that generates several ! FM calls using the derived type numbers, note that the FM ! result flag may be zero at the end of the expression even if ! an exception occurred. For example, if EXP(A) overflows in ! X = (3 + 1/EXP(A))*2 ! then the result is 6 with a flag of zero, since the exception ! caused no loss of accuracy in the final result. A warning ! message will still appear because of the overflow. ! ! The FM warning message is written on unit KW, so in this test ! it appears on the screen and not in the log file. ! ! The final result is checked by formatting the result and finding ! that the output string is '+ OVERFLOW'. CALL FM_SET(60) MAFM = TO_FM(1) FMT = "(///' Sample 10. Exception handling.'//" // & "12X,' Iterate Exp(x) starting at 1.0 until overflow occurs.'//" // & "12X,' An FM warning message will be printed before the last iteration.'/)" WRITE (*,FMT) FMT = "(///' Sample 10. Exception handling.'//" // & "12X,' Iterate Exp(x) starting at 1.0 until overflow occurs.'/)" WRITE (KLOG,FMT) DO J = 1, 10 MAFM = EXP(MAFM) CALL FMFLAG(LFLAG) CALL FM_FORM('1PE60.40',MAFM,ST1) WRITE (* ,"(/' Iteration',I3,5X,A)") J,TRIM(ST1) WRITE (KLOG,"(/' Iteration',I3,5X,A)") J,TRIM(ST1) IF (LFLAG < 0) EXIT ENDDO ! Check that the last result was +overflow. IF (FM_FORMAT('E60.40',MAFM) == FM_FORMAT('E60.40',TO_FM('+OVERFLOW'))) THEN WRITE (* ,"(/' Overflow was correctly detected.')") WRITE (KLOG,"(/' Overflow was correctly detected.')") ELSE NERROR = NERROR + 1 WRITE (* ,"(/' Error in sample case number 10.'/)") WRITE (* ,"(/' Overflow was not correctly detected.')") WRITE (KLOG ,"(/' Error in sample case number 10.'/)") WRITE (KLOG ,"(/' Overflow was not correctly detected.')") ENDIF IF (NERROR == 0) THEN WRITE (* ,"(//A/)") ' All results were ok.' WRITE (KLOG,"(//A/)") ' All results were ok.' ELSE WRITE (* ,"(//I3,A/)") NERROR,' error(s) found.' WRITE (KLOG,"(//I3,A/)") NERROR,' error(s) found.' ENDIF END PROGRAM SAMPLE SHAR_EOF fi # end of overwriting check if test -f 'TestFM.f90' then echo shar: will not over-write existing file "'TestFM.f90'" else cat << "SHAR_EOF" > 'TestFM.f90' ! David M. Smith ! This is a test program for FMLIB 1.2, a multiple-precision ! arithmetic package. Most of the FM (floating-point real) ! and ZM (floating-point complex) routines are tested. ! Precision is set to 50 significant digits and the results ! are checked to that accuracy. ! Most of the IM (integer) routines are tested, with exact ! results required to pass the tests. ! Most of the USE FMZM derived type interface routines are ! tested in the same manner as those described above. ! If all tests are completed successfully, this line is printed: ! 935 cases tested. No errors were found. MODULE TEST_VARS USE FMVALS USE FMZM ! Declare arrays for FM variables. REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK), & MD(-1:LUNPCK),ME(-1:LUNPCK),MP1(-1:LPACK), & MP2(-1:LPACK),MP3(-1:LPACK) REAL (KIND(1.0D0)) :: ZA(-1:LUNPKZ),ZB(-1:LUNPKZ),ZC(-1:LUNPKZ), & ZD(-1:LUNPKZ),ZE(-1:LUNPKZ) REAL (KIND(1.0D0)) :: MLNSV2(-1:LUNPCK),MLNSV3(-1:LUNPCK), & MLNSV5(-1:LUNPCK),MLNSV7(-1:LUNPCK) ! Declare derived type variables. TYPE (FM), SAVE :: M_A,M_B,M_C,M_D,MFM1,MFM2,MFM3,MFM4,MFM5,MFM6, & MSMALL,MFMV1(3),MFMV2(3),MFMA(3,3),MFMB(3,3),MFMC(3,3) TYPE (IM), SAVE :: M_J,M_K,M_L,MIM1,MIM2,MIM3,MIM4,MIM5,MIMV1(3), & MIMV2(3),MIMA(2,2),MIMB(2,2),MIMC(2,2) TYPE (ZM), SAVE :: M_X,M_Y,M_Z,MZM1,MZM2,MZM3,MZM4,MZM5,MZMV1(3), & MZMV2(3),MZMA(2,3),MZMB(3,4),MZMC(2,4) INTEGER, SAVE :: J1,J2,J3,J4,J5 REAL, SAVE :: R1,R2,R3,R4,R5,RSMALL DOUBLE PRECISION, SAVE :: D1,D2,D3,D4,D5,DSMALL COMPLEX, SAVE :: C1,C2,C3,C4,C5 COMPLEX (KIND(0.0D0)), SAVE :: CD1,CD2,CD3,CD4 END MODULE TEST_VARS PROGRAM TEST USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE ! Character strings used for input and output. CHARACTER(80) :: ST1,ST2 CHARACTER(160) :: STZ1,STZ2 INTEGER KLOG,KWSAVE,NCASE,NERROR REAL TIME1,TIME2 ! Write output to the standard FM output (unit KW, defined ! in subroutine FMSET), and also to the file TESTFM.LOG. KLOG = 18 OPEN (KLOG,FILE='TESTFM.LOG') KWSAVE = KW KW = KLOG ! Set precision to give at least 50 significant digits ! and initialize the FM package. ! This call also checks many of the initialization values ! used in module FMVALS (file FMSAVE.f90). Set KW = KLOG for ! this call so that any messages concerning these values will ! appear in file TESTFM.LOG. CALL FMSET(50) KW = KWSAVE CALL TIMEIT(TIME1) J2 = 131 R2 = 241.21 D2 = 391.61D0 C2 = ( 411.11D0 , 421.21D0 ) CD2 = ( 431.11D0 , 441.21D0 ) CALL FM_ST2M('581.21',MFM1) CALL FM_ST2M('-572.42',MFM2) CALL IM_ST2M('661',MIM1) CALL IM_ST2M('-602',MIM2) CALL ZM_ST2M('731.51 + 711.41 i',MZM1) CALL ZM_ST2M('-762.12 - 792.42 i',MZM2) ! NERROR is the number of errors found. ! NCASE is the number of cases tested. NERROR = 0 ! Test input and output conversion. CALL TEST1(ST1,ST2,NCASE,NERROR,KLOG) ! Test add and subtract. CALL TEST2(ST1,ST2,NCASE,NERROR,KLOG) ! Test multiply, divide and square root. CALL TEST3(ST1,ST2,NCASE,NERROR,KLOG) ! Test stored constants. CALL TEST4(NCASE,NERROR,KLOG) ! Test exponentials. CALL TEST5(ST1,ST2,NCASE,NERROR,KLOG) ! Test logarithms. CALL TEST6(ST1,ST2,NCASE,NERROR,KLOG) ! Test trigonometric functions. CALL TEST7(ST1,ST2,NCASE,NERROR,KLOG) ! Test inverse trigonometric functions. CALL TEST8(ST1,ST2,NCASE,NERROR,KLOG) ! Test hyperbolic functions. CALL TEST9(ST1,ST2,NCASE,NERROR,KLOG) ! Test integer input and output conversion. CALL TEST10(ST1,ST2,NCASE,NERROR,KLOG) ! Test integer add and subtract. CALL TEST11(ST1,ST2,NCASE,NERROR,KLOG) ! Test integer multiply and divide. CALL TEST12(ST1,ST2,NCASE,NERROR,KLOG) ! Test conversions between FM and IM format. CALL TEST13(NCASE,NERROR,KLOG) ! Test integer power and GCD functions. CALL TEST14(ST1,ST2,NCASE,NERROR,KLOG) ! Test integer modular functions. CALL TEST15(ST1,ST2,NCASE,NERROR,KLOG) ! Test complex input and output conversion. CALL TEST16(STZ1,STZ2,NCASE,NERROR,KLOG) ! Test complex add and subtract. CALL TEST17(STZ1,STZ2,NCASE,NERROR,KLOG) ! Test complex multiply, divide and square root. CALL TEST18(STZ1,STZ2,NCASE,NERROR,KLOG) ! Test complex exponentials. CALL TEST19(STZ1,STZ2,NCASE,NERROR,KLOG) ! Test complex logarithms. CALL TEST20(STZ1,STZ2,NCASE,NERROR,KLOG) ! Test complex trigonometric functions. CALL TEST21(STZ1,STZ2,NCASE,NERROR,KLOG) ! Test complex inverse trigonometric functions. CALL TEST22(STZ1,STZ2,NCASE,NERROR,KLOG) ! Test complex hyperbolic functions. CALL TEST23(STZ1,STZ2,NCASE,NERROR,KLOG) ! Test the derived type = interface. CALL TEST24(NCASE,NERROR,KLOG) ! Test the derived type == interface. CALL TEST25(NCASE,NERROR,KLOG) ! Test the derived type /= interface. CALL TEST26(NCASE,NERROR,KLOG) ! Test the derived type > interface. CALL TEST27(NCASE,NERROR,KLOG) ! Test the derived type >= interface. CALL TEST28(NCASE,NERROR,KLOG) ! Test the derived type < interface. CALL TEST29(NCASE,NERROR,KLOG) ! Test the derived type <= interface. CALL TEST30(NCASE,NERROR,KLOG) ! Test the derived type + interface. CALL TEST31(NCASE,NERROR,KLOG) ! Test the derived type - interface. CALL TEST32(NCASE,NERROR,KLOG) ! Test the derived type * interface. CALL TEST33(NCASE,NERROR,KLOG) ! Test the derived type / interface. CALL TEST34(NCASE,NERROR,KLOG) ! Test the derived type ** interface. CALL TEST35(NCASE,NERROR,KLOG) ! Test the derived type functions ABS, ..., CEILING interface. CALL TEST36(NCASE,NERROR,KLOG) ! Test the derived type functions CMPLX, ..., EXPONENT interface. CALL TEST37(NCASE,NERROR,KLOG) ! Test the derived type functions FLOOR, ..., MIN interface. CALL TEST38(NCASE,NERROR,KLOG) ! Test the derived type functions MINEXPONENT, ..., RRSPACING interface. CALL TEST39(NCASE,NERROR,KLOG) ! Test the derived type functions SCALE, ..., TINY interface. CALL TEST40(NCASE,NERROR,KLOG) ! Test the derived type functions TO_FM, TO_IM, TO_ZM, ..., TO_DPZ interface. CALL TEST41(NCASE,NERROR,KLOG) ! Test the derived type functions ADDI, ..., Z2M interface. CALL TEST42(NCASE,NERROR,KLOG) ! Test Bernoulli numbers, Pochhammer's function, Euler's constant. CALL TEST43(NCASE,NERROR,KLOG) ! Test Gamma, Factorial, Log(Gamma), Beta, Binomial. CALL TEST44(NCASE,NERROR,KLOG) ! Test Incomplete Gamma, Incomplete Beta. CALL TEST45(NCASE,NERROR,KLOG) ! Test Polygamma, Psi. CALL TEST46(NCASE,NERROR,KLOG) ! Test the different rounding modes. CALL TEST47(NCASE,NERROR,KLOG) ! End of tests. CALL TIMEIT(TIME2) IF (NERROR == 0) THEN WRITE (KW, & "(///1X,I5,' cases tested. No errors were found.'/)" & ) NCASE WRITE (KLOG, & "(///1X,I5,' cases tested. No errors were found.'/)" & ) NCASE ELSE IF (NERROR == 1) THEN WRITE (KW, & "(///1X,I5,' cases tested. 1 error was found.'/)" & ) NCASE WRITE (KLOG, & "(///1X,I5,' cases tested. 1 error was found.'/)" & ) NCASE ELSE WRITE (KW, & "(///1X,I5,' cases tested.',I4,' errors were found.'/)" & ) NCASE,NERROR WRITE (KLOG, & "(///1X,I5,' cases tested.',I4,' errors were found.'/)" & ) NCASE,NERROR ENDIF IF (NERROR >= 1) THEN KWSAVE = KW KW = KLOG ! Write some of the initialized values in common. CALL FMVARS KW = KWSAVE ENDIF WRITE (KW,*) ' ' WRITE (KW,"(F10.2,A)") TIME2-TIME1,' Seconds for TestFM.' WRITE (KW,*) ' ' WRITE (KLOG,*) ' ' WRITE (KLOG,"(F10.2,A)") TIME2-TIME1,' Seconds for TestFM.' WRITE (KLOG,*) ' ' WRITE (KW,*)' End of run.' STOP END PROGRAM TEST SUBROUTINE TEST1(ST1,ST2,NCASE,NERROR,KLOG) ! Input and output testing. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE ! Logical function for comparing FM numbers. LOGICAL FMCOMP CHARACTER(80) :: ST1,ST2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing input and output routines.')") NCASE = 1 CALL FMST2M('123',MA) CALL FMI2M(123,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMI2M(10,MB) CALL FMIPWR(MB,-48,ME) CALL FMEQ(ME,MB) ! Use the .NOT. because FMCOMP returns FALSE for special ! cases like MD = UNKNOWN, and these should be treated ! as errors for these tests. IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMST2M',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 2 ST1 = '1.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMI2M(131,MB) CALL FMI2M(97,MC) CALL FMDIV(MB,MC,ME) CALL FMEQ(ME,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMST2M',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 3 ST1 = '1.3505154639175257731958762886597938144329896907216495E-2' CALL FMST2M(ST1,MA) CALL FMI2M(131,MB) CALL FMI2M(9700,MC) CALL FMDIV(MB,MC,ME) CALL FMEQ(ME,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-52',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMST2M',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 4 ST1 = '1.3505154639175257731958762886597938144329896907216495E-2' CALL FMST2M(ST1,MA) CALL FMFORM('F40.30',MA,ST2) CALL FMST2M(ST2,MA) ST1 = ' .013505154639175257731958762887' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('0',MB) IF ((.NOT.FMCOMP(MD,'LE',MB)) .OR. ST1 /= ST2) THEN CALL ERRPRTFM('FMFORM',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 5 ST1 = '1.3505154639175257731958762886597938144329896907216495E+16' CALL FMST2M(ST1,MA) CALL FMFORM('F53.33',MA,ST2) CALL FMST2M(ST2,MA) ST1 = '13505154639175257.731958762886597938144329896907216' CALL FMST2M(ST1,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('0',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMFORM',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 6 ST1 = '1.3505154639175257731958762886597938144329896907216495E+16' CALL FMST2M(ST1,MA) CALL FMFORM('I24',MA,ST2) CALL FMST2M(ST2,MA) ST1 = '13505154639175258' CALL FMST2M(ST1,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('0',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMFORM',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 7 ST1 ='-1.3505154639175257731958762886597938144329896907216495E+16' CALL FMST2M(ST1,MA) CALL FMFORM('E55.49',MA,ST2) CALL FMST2M(ST2,MA) ST1 = '-1.350515463917525773195876288659793814432989690722D16' CALL FMST2M(ST1,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('0',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMFORM',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 8 ST1 ='-1.3505154639175257731958762886597938144329896907216495E+16' CALL FMST2M(ST1,MA) CALL FMFORM('1PE54.46',MA,ST2) CALL FMST2M(ST2,MA) ST1 = '-1.350515463917525773195876288659793814432989691M+16' CALL FMST2M(ST1,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('0',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMFORM',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST1 SUBROUTINE TEST2(ST1,ST2,NCASE,NERROR,KLOG) ! Test add and subtract. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP CHARACTER(80) :: ST1,ST2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing add and subtract routines.')") NCASE = 9 CALL FMST2M('123',MA) CALL FMST2M('789',MB) CALL FMADD(MA,MB,ME) CALL FMEQ(ME,MA) CALL FMI2M(912,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('0',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMADD ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 10 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) ST1 = '0.7319587628865979381443298969072164948453608247422680' CALL FMST2M(ST1,MB) CALL FMADD(MA,MB,ME) CALL FMEQ(ME,MA) ST2 = '1.0824742268041237113402061855670103092783505154639175' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMADD ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 11 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) ST1 = '0.7319587628865979381443298969072164948453608247422680' CALL FMST2M(ST1,MB) CALL FMSUB(MA,MB,ME) CALL FMEQ(ME,MA) ST2 = '-.3814432989690721649484536082474226804123711340206185' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMSUB ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 12 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) ST1 = '0.3505154639175257731443298969072164948453608247422680' CALL FMST2M(ST1,MB) CALL FMSUB(MA,MB,ME) CALL FMEQ(ME,MA) ST2 = '5.15463917525773195876288659793815M-20' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMSUB ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 13 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMADDI(MA,1) ST2 = '1.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMADDI',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 14 ST1 = '4.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMADDI(MA,5) ST2 = '9.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMADDI',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST2 SUBROUTINE TEST3(ST1,ST2,NCASE,NERROR,KLOG) ! Test multiply, divide and square root. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP CHARACTER(80) :: ST1,ST2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing multiply, divide and square root routines.')") NCASE = 15 CALL FMST2M('123',MA) CALL FMST2M('789',MB) CALL FMMPY(MA,MB,ME) CALL FMEQ(ME,MA) CALL FMI2M(97047,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('0',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMMPY ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 16 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) ST1 = '0.7319587628865979381443298969072164948453608247422680' CALL FMST2M(ST1,MB) CALL FMMPY(MA,MB,ME) CALL FMEQ(ME,MA) ST2 = '0.2565628653416941226485280051014985652035285365075991' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMMPY ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 17 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) ST1 = '0.7319587628865979381443298969072164948453608247422680' CALL FMST2M(ST1,MB) CALL FMDIV(MA,MB,ME) CALL FMEQ(ME,MA) ST2 = '0.4788732394366197183098591549295774647887323943661972' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMDIV ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 18 ST1 = '0.7319587628865979381443298969072164948453608247422680' CALL FMST2M(ST1,MA) CALL FMMPYI(MA,14,ME) CALL FMEQ(ME,MA) ST2 = '10.2474226804123711340206185567010309278350515463917526' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMMPYI',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 19 ST1 = '0.7319587628865979381443298969072164948453608247422680' CALL FMST2M(ST1,MA) CALL FMDIVI(MA,24,ME) CALL FMEQ(ME,MA) ST2 = '0.0304982817869415807560137457044673539518900343642612' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMDIVI',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 20 ST1 = '-0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMSQR(MA,ME) CALL FMEQ(ME,MA) ST2 = '0.1228610904453183122542246784993091720692953555106813' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMSQR ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 21 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMSQRT(MA,ME) CALL FMEQ(ME,MA) ST2 = '0.5920434645509785316136003710368759268547372945659987' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMSQRT',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST3 SUBROUTINE TEST4(NCASE,NERROR,KLOG) ! Test stored constants. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP REAL (KIND(1.0D0)) :: MBSAVE INTEGER J,JEXP,KLOG,NCASE,NDGSAV,NERROR WRITE (KW,"(/' Testing stored constants.'//' Check e.'/)") ! Switch to base 10 and check the stored digits. IF (NDIGMX < 55) THEN WRITE (KLOG,*) ' ' WRITE (KLOG,*) & ' To test these constants at their stored precision requires' WRITE (KLOG,*) & ' setting NDIG=55 (number of digits). The current maximum' WRITE (KLOG,*) ' for NDIG is NDIGMX = ',NDIGMX WRITE (KLOG,*) ' Skip the tests for stored constants.' RETURN ENDIF MBSAVE = MBASE NDGSAV = NDIG NCASE = 22 CALL FMSETVAR(' MBASE = 1000 ') CALL FMSETVAR(' NDIG = 55 ') CALL FMCONS CALL FMI2M(1,MB) CALL FMEXP(MB,MC) DO J = 49, 51 NDIG = J NDIGE = 0 CALL FMI2M(1,MB) CALL FMEXP(MB,MA) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMI2M(1000,MB) JEXP = -J + 1 CALL FMIPWR(MB,JEXP,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM(' e ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) EXIT ENDIF ENDDO NCASE = 23 CALL FMSETVAR(' MBASE = 1000 ') CALL FMSETVAR(' NDIG = 55 ') CALL FMI2M(2,MB) CALL FMLN(MB,MC) CALL FMEQ(MLN1,MLNSV2) CALL FMEQ(MLN2,MLNSV3) CALL FMEQ(MLN3,MLNSV5) CALL FMEQ(MLN4,MLNSV7) WRITE (KW,"(' Check ln(2).'/)") DO J = 49, 51 NDIG = J NDIGLI = 0 CALL FMI2M(2,MB) CALL FMLN(MB,MA) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMI2M(1000,MB) JEXP = -J CALL FMIPWR(MB,JEXP,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM(' ln(2)',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) EXIT ENDIF ENDDO NCASE = 24 CALL FMSETVAR(' MBASE = 1000 ') CALL FMSETVAR(' NDIG = 55 ') WRITE (KW,"(' Check ln(3).'/)") CALL FMEQ(MLNSV3,MC) DO J = 49, 51 NDIG = J NDIGLI = 0 CALL FMI2M(3,MB) CALL FMLN(MB,MA) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMI2M(1000,MB) JEXP = -J + 1 CALL FMIPWR(MB,JEXP,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM(' ln(3)',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) EXIT ENDIF ENDDO NCASE = 25 CALL FMSETVAR(' MBASE = 1000 ') CALL FMSETVAR(' NDIG = 55 ') WRITE (KW,"(' Check ln(5).'/)") CALL FMEQ(MLNSV5,MC) DO J = 49, 51 NDIG = J NDIGLI = 0 CALL FMI2M(5,MB) CALL FMLN(MB,MA) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMI2M(1000,MB) JEXP = -J + 1 CALL FMIPWR(MB,JEXP,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM(' ln(5)',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) EXIT ENDIF ENDDO NCASE = 26 CALL FMSETVAR(' MBASE = 1000 ') CALL FMSETVAR(' NDIG = 55 ') WRITE (KW,"(' Check ln(7).'/)") CALL FMEQ(MLNSV7,MC) DO J = 49, 51 NDIG = J NDIGLI = 0 CALL FMI2M(7,MB) CALL FMLN(MB,MA) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMI2M(1000,MB) JEXP = -J + 1 CALL FMIPWR(MB,JEXP,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM(' ln(7)',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) EXIT ENDIF ENDDO NCASE = 27 CALL FMSETVAR(' MBASE = 1000 ') CALL FMSETVAR(' NDIG = 55 ') WRITE (KW,"(' Check pi.')") CALL FMPI(MC) DO J = 49, 51 NDIG = J NDIGPI = 0 CALL FMPI(MA) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMI2M(1000,MB) JEXP = -J + 1 CALL FMIPWR(MB,JEXP,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM(' pi ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) EXIT ENDIF ENDDO ! Restore base and precision. MBASE = MBSAVE NDIG = NDGSAV CALL FMCONS RETURN END SUBROUTINE TEST4 SUBROUTINE TEST5(ST1,ST2,NCASE,NERROR,KLOG) ! Test exponentials. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP CHARACTER(80) :: ST1,ST2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing exponential routines.')") NCASE = 28 ST1 = '-0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMEXP(MA,ME) CALL FMEQ(ME,MA) ST2 = '0.7043249420381570899426746185150096342459216636010743' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMEXP ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 29 ST1 = '5.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMEXP(MA,ME) CALL FMEQ(ME,MA) ST2 = '210.7168868293979289717186453717687341395104929999527672' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-48',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMEXP ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 30 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMIPWR(MA,13,ME) CALL FMEQ(ME,MA) ST2 = '1.205572620050170403854527299272882946980306577287581E-6' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-56',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMIPWR',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 31 ST1 = '0.7319587628865979381443298969072164948453608247422680' CALL FMST2M(ST1,MA) CALL FMIPWR(MA,-1234,ME) CALL FMEQ(ME,MA) ST2 = '1.673084074011006302103793189789209370839697748745938E167' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E+120',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMIPWR',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 32 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) ST1 = '0.7319587628865979381443298969072164948453608247422680' CALL FMST2M(ST1,MB) CALL FMPWR(MA,MB,ME) CALL FMEQ(ME,MA) ST2 = '0.4642420045002127676457665673753493595170650613692580' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMPWR ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 33 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) ST1 = '-34.7319587628865979381443298969072164948453608247422680' CALL FMST2M(ST1,MB) CALL FMPWR(MA,MB,ME) CALL FMEQ(ME,MA) ST2 = '6.504461581246879800523526109766882955934341922848773E15' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-34',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMPWR ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 34 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMRPWR(MA,1,3,ME) CALL FMEQ(ME,MA) ST2 = '0.7050756680967220302067310420367584779561732592049823' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMRPWR',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 35 ST1 = '0.7319587628865979381443298969072164948453608247422680' CALL FMST2M(ST1,MA) CALL FMRPWR(MA,-17,5,ME) CALL FMEQ(ME,MA) ST2 = '2.8889864895853344043562747681699203201333872009477318' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMRPWR',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST5 SUBROUTINE TEST6(ST1,ST2,NCASE,NERROR,KLOG) ! Test logarithms. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP CHARACTER(80) :: ST1,ST2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing logarithm routines.')") NCASE = 36 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMLN(MA,ME) CALL FMEQ(ME,MA) ST2 = '-1.0483504538872214324499548823726586101452117557127813' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-49',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMLN ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 37 ST1 = '0.3505154639175257731958762886597938144329896907216495E123' CALL FMST2M(ST1,MA) CALL FMLN(MA,ME) CALL FMEQ(ME,MA) ST2 = '282.1696159843803977017629940438041389247902713456262947' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-47',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMLN ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 38 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMLG10(MA,ME) CALL FMEQ(ME,MA) ST2 = '-0.4552928172239897280304530226127473926500843247517120' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-49',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMLG10',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 39 CALL FMLNI(210,MA) ST2 = '5.3471075307174686805185894350500696418856767760333836' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-49',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMIPWR',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 40 CALL FMLNI(211,MA) ST2 = '5.3518581334760664957419562654542801180411581735816684' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-49',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMPWR ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST6 SUBROUTINE TEST7(ST1,ST2,NCASE,NERROR,KLOG) ! Test trigonometric functions. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP CHARACTER(80) :: ST1,ST2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing trigonometric routines.')") NCASE = 41 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMCOS(MA,ME) CALL FMEQ(ME,MA) ST2 = '0.9391958366109693586000906984500978377093121163061328' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMCOS ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 42 ST1 = '-43.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMCOS(MA,ME) CALL FMEQ(ME,MA) ST2 = '0.8069765551968063243992244125871029909816207609700968' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMCOS ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 43 ST1 = '-0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMSIN(MA,ME) CALL FMEQ(ME,MA) ST2 = '-0.3433819746180939949443652360333010581867042625893927' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMSIN ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 44 ST1 = '43.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMSIN(MA,ME) CALL FMEQ(ME,MA) ST2 = '-0.5905834736620182429243173169772978155668602154136946' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMSIN ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 45 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMTAN(MA,ME) CALL FMEQ(ME,MA) ST2 = '0.3656127521360899712035823015565426347554405301360773' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMTAN ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 46 ST1 = '43.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMTAN(MA,ME) CALL FMEQ(ME,MA) ST2 = '-0.7318471272291003544610122296764031536071117330470298' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMTAN ',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 47 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMCSSN(MA,ME,MC) CALL FMEQ(ME,MA) ST2 = '0.9391958366109693586000906984500978377093121163061328' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMCSSN',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 48 ST1 = '-43.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMCSSN(MA,ME,MC) CALL FMEQ(ME,MA) ST2 = '0.8069765551968063243992244125871029909816207609700968' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMCSSN',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 49 ST1 = '-0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMCSSN(MA,MC,ME) CALL FMEQ(ME,MA) ST2 = '-0.3433819746180939949443652360333010581867042625893927' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMCSSN',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 50 ST1 = '43.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMCSSN(MA,MC,ME) CALL FMEQ(ME,MA) ST2 = '-0.5905834736620182429243173169772978155668602154136946' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMCSSN',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST7 SUBROUTINE TEST8(ST1,ST2,NCASE,NERROR,KLOG) ! Test inverse trigonometric functions. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP CHARACTER(80) :: ST1,ST2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing inverse trigonometric routines.')") NCASE = 51 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMACOS(MA,ME) CALL FMEQ(ME,MA) ST2 = '1.2126748979730954046873545995574544481988102502510807' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMACOS',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 52 ST1 = '-0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMACOS(MA,ME) CALL FMEQ(ME,MA) ST2 = '1.9289177556166978337752887837220484359983591491240252' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMACOS',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 53 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMASIN(MA,ME) CALL FMEQ(ME,MA) ST2 = '0.3581214288218012145439670920822969938997744494364723' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMASIN',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 54 ST1 = '-0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMASIN(MA,ME) CALL FMEQ(ME,MA) ST2 = '-0.3581214288218012145439670920822969938997744494364723' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMASIN',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 55 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMATAN(MA,ME) CALL FMEQ(ME,MA) ST2 = '0.3371339561772373443347761845672381725353758541616570' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMATAN',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 56 ST1 = '43.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMATAN(MA,ME) CALL FMEQ(ME,MA) ST2 = '1.5477326406586162039457549832092678908202994134569781' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMATAN',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST8 SUBROUTINE TEST9(ST1,ST2,NCASE,NERROR,KLOG) ! Test hyperbolic functions. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP CHARACTER(80) :: ST1,ST2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing hyperbolic routines.')") NCASE = 57 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMCOSH(MA,ME) CALL FMEQ(ME,MA) ST2 = '1.0620620786534654254819884264931372964608741056397718' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-49',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMCOSH',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 58 ST1 = '-43.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMCOSH(MA,ME) CALL FMEQ(ME,MA) ST2 = '3.356291383454381441662669560464886179346554730604556E+18' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-31',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMCOSH',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 59 ST1 = '-0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMSINH(MA,ME) CALL FMEQ(ME,MA) ST2 = '-0.3577371366153083355393138079781276622149524420386975' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMSINH',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 60 ST1 = '43.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMSINH(MA,ME) CALL FMEQ(ME,MA) ST2 = '3.356291383454381441662669560464886179197580776059111E+18' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-31',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMSINH',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 61 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMTANH(MA,ME) CALL FMEQ(ME,MA) ST2 = '0.3368326049912874057089491946232983472275659538703038' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMTANH',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 62 ST1 = '43.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMTANH(MA,ME) CALL FMEQ(ME,MA) ST2 = '0.9999999999999999999999999999999999999556135217341837' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMTANH',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 63 ST1 = '0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMCHSH(MA,ME,MC) CALL FMEQ(ME,MA) ST2 = '1.0620620786534654254819884264931372964608741056397718' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-49',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMCHSH',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 64 ST1 = '-43.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMCHSH(MA,ME,MC) CALL FMEQ(ME,MA) ST2 = '3.356291383454381441662669560464886179346554730604556E+18' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-31',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMCHSH',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 65 ST1 = '-0.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMCHSH(MA,MC,ME) CALL FMEQ(ME,MA) ST2 = '-0.3577371366153083355393138079781276622149524420386975' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-50',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMCHSH',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 66 ST1 = '43.3505154639175257731958762886597938144329896907216495' CALL FMST2M(ST1,MA) CALL FMCHSH(MA,MC,ME) CALL FMEQ(ME,MA) ST2 = '3.356291383454381441662669560464886179197580776059111E+18' CALL FMST2M(ST2,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('1.0E-31',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('FMCHSH',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST9 SUBROUTINE TEST10(ST1,ST2,NCASE,NERROR,KLOG) ! Input and output testing for IM routines. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE ! Logical function for comparing IM numbers. LOGICAL IMCOMP CHARACTER(80) :: ST1,ST2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing integer input and output routines.')") NCASE = 67 CALL IMST2M('123',MA) CALL IMI2M(123,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMST2M',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 68 ST1 = '-350515' CALL IMST2M(ST1,MA) CALL IMI2M(-350515,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMST2M',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 69 ST1 = '19895113660064588580108197261066338165074766609' CALL IMST2M(ST1,MA) CALL IMI2M(23,MB) CALL IMI2M(34,MC) CALL IMPWR(MB,MC,ME) CALL IMEQ(ME,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMPWR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 70 ST1 = '-20800708073664542533904165663516279809808659679033703' CALL IMST2M(ST1,MA) CALL IMI2M(-567,MB) CALL IMI2M(19,MC) CALL IMPWR(MB,MC,ME) CALL IMEQ(ME,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMPWR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 71 ST1 = '19895113660064588580108197261066338165074766609' CALL IMST2M(ST1,MA) CALL IMFORM('I53',MA,ST2) CALL IMST2M(ST2,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMFORM',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 72 ST1 = '-20800708073664542533904165663516279809808659679033703' CALL IMST2M(ST1,MA) CALL IMFORM('I73',MA,ST2) CALL IMST2M(ST2,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMFORM',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST10 SUBROUTINE TEST11(ST1,ST2,NCASE,NERROR,KLOG) ! Test add and subtract for IM routines. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL IMCOMP CHARACTER(80) :: ST1,ST2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing integer add and subtract routines.')") NCASE = 73 CALL IMST2M('123',MA) CALL IMST2M('789',MB) CALL IMADD(MA,MB,ME) CALL IMEQ(ME,MA) CALL IMI2M(912,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMADD ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 74 ST1 = '3505154639175257731958762886597938144329896907216495' CALL IMST2M(ST1,MA) ST1 = '7319587628865979381443298969072164948453608247422680' CALL IMST2M(ST1,MB) CALL IMADD(MA,MB,ME) CALL IMEQ(ME,MA) ST2 = '10824742268041237113402061855670103092783505154639175' CALL IMST2M(ST2,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMADD ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 75 ST1 = '3505154639175257731958762886597938144329896907216495' CALL IMST2M(ST1,MA) ST1 = '7319587628865979381443298969072164948453608247422680' CALL IMST2M(ST1,MB) CALL IMSUB(MA,MB,ME) CALL IMEQ(ME,MA) ST2 = '-3814432989690721649484536082474226804123711340206185' CALL IMST2M(ST2,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMSUB ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 76 ST1 = '3505154639175257731958762886597938144329896907216495' CALL IMST2M(ST1,MA) ST1 = '3505154639175257731443298969072164948453608247422680' CALL IMST2M(ST1,MB) CALL IMSUB(MA,MB,ME) CALL IMEQ(ME,MA) ST2 = '515463917525773195876288659793815' CALL IMST2M(ST2,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMSUB ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST11 SUBROUTINE TEST12(ST1,ST2,NCASE,NERROR,KLOG) ! Test integer multiply and divide. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL IMCOMP CHARACTER(80) :: ST1,ST2 INTEGER IREM,KLOG,NCASE,NERROR WRITE (KW,"(/' Testing integer multiply, divide and square routines.')") NCASE = 77 CALL IMST2M('123',MA) CALL IMST2M('789',MB) CALL IMMPY(MA,MB,ME) CALL IMEQ(ME,MA) CALL IMI2M(97047,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMMPY ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 78 ST1 = '10430738374625018354698' CALL IMST2M(ST1,MA) ST1 = '2879494424799214514791045985' CALL IMST2M(ST1,MB) CALL IMMPY(MA,MB,ME) CALL IMEQ(ME,MA) ST2 = '30035252996271960952238822892375588336807158787530' CALL IMST2M(ST2,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMMPY ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 79 CALL IMST2M('12347',MA) CALL IMST2M('47',MB) CALL IMDIV(MA,MB,ME) CALL IMEQ(ME,MA) CALL IMST2M('262',MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMDIV ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 80 ST1 = '2701314697583086005158008013691015597308949443159762' CALL IMST2M(ST1,MA) ST1 = '-978132616472842669976589722394' CALL IMST2M(ST1,MB) CALL IMDIV(MA,MB,ME) CALL IMEQ(ME,MA) CALL IMST2M('-2761705981469115610382',MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMDIV ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 81 CALL IMST2M('12368',MA) CALL IMST2M('67',MB) CALL IMMOD(MA,MB,ME) CALL IMEQ(ME,MB) CALL IMST2M('40',MC) IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN CALL ERRPRTIM('IMMOD ',MB,'MB',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 82 ST1 = '2701314697583086005158008013691015597308949443159762' CALL IMST2M(ST1,MA) ST1 = '-978132616472842669976589722394' CALL IMST2M(ST1,MB) CALL IMMOD(MA,MB,ME) CALL IMEQ(ME,MB) CALL IMST2M('450750319653685523300198865254',MC) IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN CALL ERRPRTIM('IMMOD ',MB,'MB',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 83 CALL IMST2M('1234',MA) CALL IMST2M('17',MB) CALL IMDIVR(MA,MB,MC,MD) CALL IMEQ(MC,MA) CALL IMEQ(MD,MB) CALL IMST2M('72',MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMDIVR',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF CALL IMST2M('10',MC) IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN CALL ERRPRTIM('IMDIVR',MB,'MB',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 84 ST1 = '34274652243817531418235301715935108945364446765801943' CALL IMST2M(ST1,MA) ST1 = '-54708769795848731641842224621693' CALL IMST2M(ST1,MB) CALL IMDIVR(MA,MB,MC,MD) CALL IMEQ(MC,MA) CALL IMEQ(MD,MB) CALL IMST2M('-626492834178447772323',MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMDIVR',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF CALL IMST2M('31059777254296217822749494999104',MC) IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN CALL ERRPRTIM('IMDIVR',MB,'MB',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 85 CALL IMST2M('4866',MA) CALL IMMPYI(MA,14,ME) CALL IMEQ(ME,MA) CALL IMST2M('68124',MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMMPYI',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 86 CALL IMST2M('270131469758308600515800801369101559730894',MA) CALL IMMPYI(MA,-2895,ME) CALL IMEQ(ME,MA) CALL IMST2M('-782030604950303398493243319963549015420938130',MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMMPYI ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 87 CALL IMST2M('-37179',MA) CALL IMDIVI(MA,129,ME) CALL IMEQ(ME,MA) CALL IMST2M('-288',MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMDIVI',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 88 ST1 = '8267538919383255454483790743961990401918726073065738' CALL IMST2M(ST1,MA) CALL IMDIVI(MA,1729,ME) CALL IMEQ(ME,MA) ST2 = '4781688212483085861471249707323302719444028960708' CALL IMST2M(ST2,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMDIVI',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 89 CALL IMST2M('-71792',MA) CALL IMDVIR(MA,65,MC,IREM) CALL IMEQ(MC,MA) CALL IMST2M('-1104',MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMDVIR',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF CALL IMI2M(IREM,MB) CALL IMI2M(-32,MC) IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN CALL ERRPRTIM('IMDVIR',MB,'MB',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 90 ST1 = '97813261647284266997658972239417958580120170263408655' CALL IMST2M(ST1,MA) CALL IMDVIR(MA,826,MC,IREM) CALL IMEQ(MC,MA) ST2 = '118417992309060855929369215786220288837917881674828' CALL IMST2M(ST2,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMDVIR',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF CALL IMI2M(IREM,MB) CALL IMI2M(727,MC) IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN CALL ERRPRTIM('IMDVIR',MB,'MB',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 91 CALL IMST2M('538',MA) CALL IMSQR(MA,ME) CALL IMEQ(ME,MA) CALL IMST2M('289444',MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMSQR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 92 CALL IMST2M('-47818191879814587168242632',MA) CALL IMSQR(MA,ME) CALL IMEQ(ME,MA) ST2 = '2286579474654765721668058416662636606051551222287424' CALL IMST2M(ST2,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMSQR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST12 SUBROUTINE TEST13(NCASE,NERROR,KLOG) ! Test conversions between FM and IM format. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP,IMCOMP INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing conversions between FM and IM format.')") NCASE = 93 CALL IMST2M('123',MA) CALL IMI2FM(MA,MB) CALL FMI2M(123,MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('0',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('IMI2FM',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 94 CALL IMST2M('979282999076598337488362000995916',MA) CALL IMI2FM(MA,MB) CALL FMST2M('979282999076598337488362000995916',MC) CALL FMSUB(MA,MC,MD) CALL FMABS(MD,ME) CALL FMEQ(ME,MD) CALL FMST2M('0',MB) IF (.NOT.FMCOMP(MD,'LE',MB)) THEN CALL ERRPRTFM('IMI2FM',MA,'MA',MC,'MC',MD,'MD', & NCASE,NERROR,KLOG) ENDIF NCASE = 95 CALL FMST2M('123.4',MA) CALL IMFM2I(MA,MB) CALL IMI2M(123,MC) IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN CALL ERRPRTIM('IMFM2I',MB,'MB',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 96 CALL FMST2M('979282999076598337488362000995916',MA) CALL IMFM2I(MA,MB) CALL IMST2M('979282999076598337488362000995916',MC) IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN CALL ERRPRTIM('IMFM2I',MB,'MB',MC,'MC',NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST13 SUBROUTINE TEST14(ST1,ST2,NCASE,NERROR,KLOG) ! Test integer power and GCD functions. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL IMCOMP CHARACTER(80) :: ST1,ST2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing integer GCD and power routines.')") NCASE = 97 CALL IMST2M('123',MA) CALL IMST2M('789',MB) CALL IMGCD(MA,MB,ME) CALL IMEQ(ME,MA) CALL IMI2M(3,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMGCD ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 98 ST1 = '431134020618556701030927835051546391752577319587628885' CALL IMST2M(ST1,MA) ST1 = '900309278350515463917525773195876288659793814432989640' CALL IMST2M(ST1,MB) CALL IMGCD(MA,MB,ME) CALL IMEQ(ME,MA) CALL IMST2M('615',MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMGCD ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 99 ST1 = '5877631675869176172956662762822298812326084745145447940' CALL IMST2M(ST1,MA) ST1 = '10379997509886032090765062511740075746391432253007667' CALL IMST2M(ST1,MB) CALL IMGCD(MA,MB,ME) CALL IMEQ(ME,MA) CALL IMST2M('1',MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMGCD ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 100 CALL IMST2M('47',MA) CALL IMST2M('34',MB) CALL IMPWR(MA,MB,ME) CALL IMEQ(ME,MA) ST2 = '710112520079088427392020925014421733344154169313556279969' CALL IMST2M(ST2,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMPWR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 101 CALL IMST2M('2',MA) CALL IMST2M('187',MB) CALL IMPWR(MA,MB,ME) CALL IMEQ(ME,MA) ST2 = '196159429230833773869868419475239575503198607639501078528' CALL IMST2M(ST2,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMPWR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 102 CALL IMST2M('-3',MA) CALL IMST2M('101',MB) CALL IMPWR(MA,MB,ME) CALL IMEQ(ME,MA) ST2 = '-1546132562196033993109383389296863818106322566003' CALL IMST2M(ST2,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMPWR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST14 SUBROUTINE TEST15(ST1,ST2,NCASE,NERROR,KLOG) ! Test integer modular functions. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL IMCOMP CHARACTER(80) :: ST1,ST2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing integer modular routines.')") NCASE = 103 CALL IMST2M('123',MA) CALL IMST2M('789',MB) CALL IMST2M('997',MC) CALL IMMPYM(MA,MB,MC,ME) CALL IMEQ(ME,MA) CALL IMI2M(338,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMMPYM',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 104 ST1 = '431134020618556701030927835051546391752577319587628885' CALL IMST2M(ST1,MA) ST1 = '36346366019557973241042306587666640486264616086971724' CALL IMST2M(ST1,MB) ST1 = '900309278350515463917525773195876288659793814432989640' CALL IMST2M(ST1,MC) CALL IMMPYM(MA,MB,MC,ME) CALL IMEQ(ME,MA) ST2 = '458279704440780378752997531208983184411293504187816380' CALL IMST2M(ST2,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMMPYM',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 105 ST1 = '914726194238000125985765939883182' CALL IMST2M(ST1,MA) ST1 = '-75505764717193044779376979508186553225192' CALL IMST2M(ST1,MB) ST1 = '18678872625055834600521936' CALL IMST2M(ST1,MC) CALL IMMPYM(MA,MB,MC,ME) CALL IMEQ(ME,MA) ST2 = '-7769745969769966093344960' CALL IMST2M(ST2,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMMPYM',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 106 CALL IMST2M('123',MA) CALL IMST2M('789',MB) CALL IMST2M('997',MC) CALL IMPMOD(MA,MB,MC,ME) CALL IMEQ(ME,MA) CALL IMI2M(240,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMPMOD',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 107 ST1 = '431134020618556701030927835051546391752577319587628885' CALL IMST2M(ST1,MA) ST1 = '36346366019557973241042306587666640486264616086971724' CALL IMST2M(ST1,MB) ST1 = '900309278350515463917525773195876288659793814432989640' CALL IMST2M(ST1,MC) CALL IMPMOD(MA,MB,MC,ME) CALL IMEQ(ME,MA) ST2 = '755107893576299697276281907390144058060594744720442385' CALL IMST2M(ST2,MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMPMOD',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF NCASE = 108 CALL IMST2M('314159',MA) CALL IMST2M('1411695892374393248272691827763664225585897550',MB) CALL IMST2M('1411695892374393248272691827763664225585897551',MC) CALL IMPMOD(MA,MB,MC,ME) CALL IMEQ(ME,MA) CALL IMST2M('1',MC) IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN CALL ERRPRTIM('IMPMOD',MA,'MA',MC,'MC',NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST15 SUBROUTINE TEST16(STZ1,STZ2,NCASE,NERROR,KLOG) ! Complex input and output testing. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE ! Logical function for comparing FM numbers. LOGICAL FMCOMP CHARACTER(160) :: STZ1,STZ2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing complex input and output routines.')") NCASE = 109 CALL ZMST2M('123 + 456 i',ZA) CALL ZM2I2M(123,456,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-48,ME) CALL FMEQ(ME,MB) ! Use the .NOT. because FMCOMP returns FALSE for special ! cases like ZD = UNKNOWN, and these should be treated ! as errors for these tests. IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMST2M',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 110 STZ1 = '0.3505154639175257731958762886597938144329896907216495 + ' & // '0.7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(STZ1,ZA) CALL ZM2I2M(34,71,ZC) CALL ZMDIVI(ZC,97,ZE) CALL ZMEQ(ZE,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMST2M',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 111 STZ1 = '0.3505154639175257731958762886597938144329896907216495E-5 ' & //'+ 0.7319587628865979381443298969072164948453608247422680D-5 i' CALL ZMST2M(STZ1,ZA) CALL ZM2I2M(34,71,ZC) CALL ZMDIVI(ZC,9700000,ZE) CALL ZMEQ(ZE,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-55,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMST2M',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 112 STZ1 = '7.699115044247787610619469026548672566371681415929204e 03 ' & //'- 5.221238938053097345132743362831858407079646017699115M 03 I' CALL ZMST2M(STZ1,ZA) CALL ZM2I2M(87,-59,ZC) CALL ZMDIVI(ZC,113,ZE) CALL ZMEQ(ZE,ZC) CALL ZMMPYI(ZC,10000,ZE) CALL ZMEQ(ZE,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-47,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMST2M',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 113 STZ1 = '7.699115044247787610619469026548672566371681415929204e+3 ' & //'- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL ZMST2M(STZ1,ZA) CALL ZMFORM('F53.33','F50.30',ZA,STZ2) CALL ZMST2M(STZ2,ZA) STZ1 = '7699.115044247787610619469026548673 ' & // '-5221.238938053097345132743362831858 i' CALL ZMST2M(STZ1,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-30,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMFORM',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 114 STZ1 = '7.699115044247787610619469026548672566371681415929204e+3 ' & //'- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL ZMST2M(STZ1,ZA) CALL ZMFORM('I9','I7',ZA,STZ2) CALL ZMST2M(STZ2,ZA) STZ1 = '7699 -5221 i' CALL ZMST2M(STZ1,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(0,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMFORM',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 115 STZ1 = '7.699115044247787610619469026548672566371681415929204e+3 ' & //'- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL ZMST2M(STZ1,ZA) CALL ZMFORM('E59.50','E58.49',ZA,STZ2) CALL ZMST2M(STZ2,ZA) STZ1 = '7.6991150442477876106194690265486725663716814159292E3' & //'- 5.221238938053097345132743362831858407079646017699E3 i' CALL ZMST2M(STZ1,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-48,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMFORM',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 116 STZ1 = '7.699115044247787610619469026548672566371681415929204e+3 ' & //'- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL ZMST2M(STZ1,ZA) CALL ZMFORM('1PE59.50','1PE58.49',ZA,STZ2) CALL ZMST2M(STZ2,ZA) CALL ZMST2M(STZ1,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-44,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMFORM',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST16 SUBROUTINE TEST17(STZ1,STZ2,NCASE,NERROR,KLOG) ! Test complex add and subtract. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP CHARACTER(160) :: STZ1,STZ2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing complex add and subtract routines.')") NCASE = 117 CALL ZMST2M('123 + 456 i',ZA) CALL ZMST2M('789 - 543 i',ZB) CALL ZMADD(ZA,ZB,ZE) CALL ZMEQ(ZE,ZA) CALL ZM2I2M(912,-87,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(0,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMADD ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 118 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) STZ1 = '.3505154639175257731958762886597938144329896907216495 ' & //'+ .7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(STZ1,ZB) CALL ZMADD(ZA,ZB,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '1.1204269683423045342578231913146610710701578323145698 ' & //'+ 0.2098348690812882036310555606240306541373962229723565 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-49,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMADD ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 119 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) STZ1 = '.3505154639175257731958762886597938144329896907216495 ' & //'+ .7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(STZ1,ZB) CALL ZMSUB(ZA,ZB,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.4193960405072529878660706139950734422041784508712709 ' & //'- 1.2540826566919076726576042331904023355533254265121795 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-49,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMSUB ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 120 STZ1 = '.7699115044247787610619469026548672566371681415929204E3 ' & //'- .5221238938053097345132743362831858407079646017699115E3 i' CALL ZMST2M(STZ1,ZA) STZ1 = '.3505154639175257731958762886597938144329896907216495 ' & //'+ .7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(STZ1,ZB) CALL ZMSUB(ZA,ZB,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '769.5609889608612352887510263662074628227351519021987045 ' & //'- 522.8558525681963324514186661800930572028099625946537725 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-47,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMSUB ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST17 SUBROUTINE TEST18(STZ1,STZ2,NCASE,NERROR,KLOG) ! Test complex multiply, divide and square root. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP CHARACTER(160) :: STZ1,STZ2 INTEGER KLOG,NCASE,NERROR WRITE (KW, & "(/' Testing complex multiply, divide and square root routines.')") NCASE = 121 CALL ZMST2M('123 + 456 i',ZA) CALL ZMST2M('789 - 543 i',ZB) CALL ZMMPY(ZA,ZB,ZE) CALL ZMEQ(ZE,ZA) CALL ZM2I2M(344655,292995,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(0,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMMPY ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 122 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) STZ1 = '.3505154639175257731958762886597938144329896907216495 ' & //'+ .7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(STZ1,ZB) CALL ZMMPY(ZA,ZB,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.6520390475321594745005017790347596022260742632971444 ' & //'+ 0.3805309734513274336283185840707964601769911504424779 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMMPY ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 123 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) STZ1 = '.3505154639175257731958762886597938144329896907216495 ' & //'+ .7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(STZ1,ZB) CALL ZMDIV(ZA,ZB,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '-.1705178497731560089737969128653459210208765017614861 ' & //'- 1.1335073636829696356072949942949842987114804337239972 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-49,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMDIV ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 124 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMMPYI(ZA,36,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '27.7168141592920353982300884955752212389380530973451327 ' & //'- 18.7964601769911504424778761061946902654867256637168142 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-48,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMMPYI',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 125 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMDIVI(ZA,37,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '2.080841903850753408275532169337479071992346328629514E-2 ' & //'- 1.411145658933269552738579287251853623535039464243004E-2 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-52,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMDIVI',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 126 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMSQR(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.3201503641632077688150990680554467851828647505677813 ' & //'- 0.8039783851515388832328295089670295246299631921058814 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMSQR ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 127 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMSQRT(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.9219999909012323458336720551458583330580388434229845 ' & //'- 0.2831474506279259570386845864488094697732718981999941 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMSQRT',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST18 SUBROUTINE TEST19(STZ1,STZ2,NCASE,NERROR,KLOG) ! Test complex exponentials. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP CHARACTER(160) :: STZ1,STZ2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing complex exponential routines.')") NCASE = 128 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMEXP(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '1.8718374504057787925867989348073888855260008469310002 ' & //'- 1.0770279996847678711699041910427261417963102075889234 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-49,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMEXP ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 129 STZ1 = '5.7699115044247787610619469026548672566371681415929204 ' & //'- 4.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMEXP(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '-60.6144766542152809520229386164396710991242264070603612 ' & //'+ 314.7254994809539691403004121118801578835669635535466592 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-47,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMEXP ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 130 STZ1 = '1.7699115044247787610619469026548672566371681415929204 ' & //'- 1.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMIPWR(ZA,45,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '31595668743300099.70429472191424818167262151605608585179 ' & //'- 19209634448276799.67717448173630165852744930837930753788 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-33,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMIPWR',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 131 STZ1 = '1.7699115044247787610619469026548672566371681415929204 ' & //'- 1.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMIPWR(ZA,-122,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '3.1000215641022021714480000129414241564868699479432E-46 ' & //'- 1.1687846789859477815450163510927243367234863123667E-45 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-93,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMIPWR',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 132 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) STZ1 = '.3505154639175257731958762886597938144329896907216495 ' & //'+ .7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(STZ1,ZB) CALL ZMPWR(ZA,ZB,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '1.4567089343012352449621841355636496276866203747888724 ' & //'- 0.3903177712261966292764255714390622205129978923650749 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-49,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMPWR ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 133 STZ1 = '.3505154639175257731958762886597938144329896907216495 ' & //'+ .7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(STZ1,ZA) STZ1 = '2.7699115044247787610619469026548672566371681415929204 ' & //'- 0.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZB) CALL ZMPWR(ZA,ZB,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '-1.0053105716678380336247948739245187868180079734997482 ' & // '- 0.0819537653234704467729051473979237153087038930127116 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-49,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMPWR ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 134 STZ1 = '0.7699115044247787610619469026548672566371681415929204 ' & //'- 0.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMRPWR(ZA,2,7,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.9653921326136512316639621651337975772631340364271270 ' & //'- 0.1659768285667051396562270035411852432430188906482848 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMRPWR',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 135 STZ1 = '0.7699115044247787610619469026548672566371681415929204 ' & //'- 0.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMRPWR(ZA,-19,7,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '-0.0567985880053556315170006800325686036902111276420647 ' & // '+ 1.2154793972711356706410882510363594270389067962568571 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-49,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMRPWR',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST19 SUBROUTINE TEST20(STZ1,STZ2,NCASE,NERROR,KLOG) ! Test complex logarithms. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP CHARACTER(160) :: STZ1,STZ2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing complex logarithm routines.')") NCASE = 136 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMLN(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '-0.0722949652393911311212450699415231782692434885813725 ' & //'- 0.5959180055163009910007765127008371205749515965219804 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMLN ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 137 STZ1 = '.7699115044247787610619469026548672566371681415929204E28 ' & //'- .5221238938053097345132743362831858407079646017699115E28 i' CALL ZMST2M(STZ1,ZA) CALL ZMLN(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '64.4000876385938880213825156612206746345615981930242708 ' & //'- 0.5959180055163009910007765127008371205749515965219804 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-48,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMLN ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 138 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMLG10(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '-0.0313973044728549715287589498363619677438302809470943 ' & //'- 0.2588039014625211035392823012785304771809982053965284 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMLG10',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 139 STZ1 = '.7699115044247787610619469026548672566371681415929204E82 ' & //'- .5221238938053097345132743362831858407079646017699115E82 i' CALL ZMST2M(STZ1,ZA) CALL ZMLG10(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '81.9686026955271450284712410501636380322561697190529057 ' & //'- 0.2588039014625211035392823012785304771809982053965284 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-48,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMLG10',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST20 SUBROUTINE TEST21(STZ1,STZ2,NCASE,NERROR,KLOG) ! Test complex trigonometric functions. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP CHARACTER(160) :: STZ1,STZ2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing complex trigonometric routines.')") NCASE = 140 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMCOS(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.8180802525254482451348613286211514555816444253416895 ' & //'+ 0.3801751200076938035500853542125525088505055292851393 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMCOS ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 141 STZ1 = '34.7699115044247787610619469026548672566371681415929204 ' & //'- 42.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMCOS(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '-1432925478410268113.5816466154230974355002592549420099 ' & //'- 309002816679456015.00151246245263842483282458519462258 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-31,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMCOS ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 142 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMSIN(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.7931260548991613428648822413402447097755865697557818 ' & //'- 0.3921366045897070762848927655743167937790944353110710 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMSIN ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 143 STZ1 = '34.7699115044247787610619469026548672566371681415929204 ' & //'- 42.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMSIN(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '-3.090028166794560150015124624526384249047272360765358E17 ' & //'+ 1.432925478410268113581646615423097435166828182950161E18 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-31,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMSIN ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 144 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMTAN(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.6141156219447569167198437040270236055089243090199979 ' & //'- 0.7647270337230070156308196055474639461102792169274526 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMTAN ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 145 STZ1 = '35.7699115044247787610619469026548672566371681415929204 ' & //'- 43.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMTAN(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '2.068934241218867332441292427642153175237611151321340E-38 ' & //'- 1.000000000000000000000000000000000000023741659169354 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-49,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMTAN ',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 146 STZ1 = '0.3505154639175257731958762886597938144329896907216495 ' & //'+ 0.7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(STZ1,ZA) CALL ZMCSSN(ZA,ZE,ZC) CALL ZMEQ(ZE,ZA) STZ2 = '1.2022247452809115256533054407001508718694617802593324 ' & //'- 0.2743936538120352873902095801531325075994392065668943 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-49,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMCSSN',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 147 STZ1 = '0.3505154639175257731958762886597938144329896907216495 ' & //'+ 0.7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(STZ1,ZA) CALL ZMCSSN(ZA,ZC,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.4395486978082638069281369170831952476351663772871008 ' & //'+ 0.7505035100906417134864779281080728222900154610025883 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMCSSN',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST21 SUBROUTINE TEST22(STZ1,STZ2,NCASE,NERROR,KLOG) ! Test complex inverse trigonometric functions. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP CHARACTER(160) :: STZ1,STZ2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing complex inverse trigonometric routines.')") NCASE = 148 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMACOS(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.8797127900868121872960714368309657795959216549012347 ' & //'+ 0.6342141347945396859119941874681961111936156338608130 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMACOS',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 149 STZ1 = '.7699115044247787610619469026548672566371681415929204E12 ' & //'- .5221238938053097345132743362831858407079646017699115E12 i' CALL ZMST2M(STZ1,ZA) CALL ZMACOS(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.5959180055163009910007767810953294528367807973983794 ' & //'+28.2518733312491023865118844008522768856672089946951468 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-48,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMACOS',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 150 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMASIN(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.6910835367080844319352502548087856625026630447863182 ' & //'- 0.6342141347945396859119941874681961111936156338608130 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMASIN',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 151 STZ1 = '.7699115044247787610619469026548672566371681415929204E13 ' & //'- .5221238938053097345132743362831858407079646017699115E13 i' CALL ZMST2M(STZ1,ZA) CALL ZMASIN(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.9748783212785956282305451762549693982010148111568094 ' & //'-30.5544584242431480705298759613446206186670533428066404 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-48,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMASIN',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 152 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMATAN(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.7417952692265900376512911713942700568648670953521258 ' & //'- 0.3162747143126729004878357203292329539837025170484857 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMATAN',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 153 STZ1 = '.7699115044247787610619469026548672566371681415929204E13 ' & //'- .5221238938053097345132743362831858407079646017699115E13 i' CALL ZMST2M(STZ1,ZA) CALL ZMATAN(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = ' 1.570796326794807650905529836436131532596233124329403 ' & //'-6.033484162895927601809954710695221401671437742867605E-14 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-49,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMATAN',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST22 SUBROUTINE TEST23(STZ1,STZ2,NCASE,NERROR,KLOG) ! Test complex hyperbolic functions. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE LOGICAL FMCOMP CHARACTER(160) :: STZ1,STZ2 INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing complex hyperbolic routines.')") NCASE = 154 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMCOSH(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '1.1365975275870879962259716562608779977957563621412079 ' & //'- 0.4230463404769118342540441830446134405410543954181579 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-49,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMCOSH',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 155 STZ1 = '34.7699115044247787610619469026548672566371681415929204 ' & //'- 42.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMCOSH(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '69552104658681.7558589320148420094288419217262200765435 ' & //'+ 626163773308016.884007302915197616300902876551542156676 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-35,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMCOSH',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 156 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMSINH(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.7352399228186907963608272785465108877302444847897922 ' & //'- 0.6539816592078560369158600079981127012552558121707655 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMSINH',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 157 STZ1 = '34.7699115044247787610619469026548672566371681415929204 ' & //'- 42.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMSINH(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '6.955210465868175585893201484192181376093291191637290E 13 ' & //'+ 6.261637733080168840073029151984050820616907795167046E 14 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-35,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMSINH',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 158 STZ1 = '.7699115044247787610619469026548672566371681415929204 ' & //'- .5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMTANH(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.7562684782933185240709480231996041186654551038993505 ' & //'- 0.2938991498221693198532255749292372853685311106820169 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMTANH',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 159 STZ1 = '35.7699115044247787610619469026548672566371681415929204 ' & //'- 43.5221238938053097345132743362831858407079646017699115 i' CALL ZMST2M(STZ1,ZA) CALL ZMTANH(ZA,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '9.999999999999999999999999999998967653135180689424497E-01 ' & //'+ 1.356718776492102400812550018433337461876455254467192E-31 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMTANH',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 160 STZ1 = '0.3505154639175257731958762886597938144329896907216495 ' & //'+ 0.7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(STZ1,ZA) CALL ZMCHSH(ZA,ZE,ZC) CALL ZMEQ(ZE,ZA) STZ2 = '0.7900326499280864816444807620997665088044412803737969 ' & //'+ 0.2390857359988804105051429301542214823277594407302781 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMCHSH',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF NCASE = 161 STZ1 = '0.3505154639175257731958762886597938144329896907216495 ' & //'+ 0.7319587628865979381443298969072164948453608247422680 i' CALL ZMST2M(STZ1,ZA) CALL ZMCHSH(ZA,ZC,ZE) CALL ZMEQ(ZE,ZA) STZ2 = '0.2661087555034471983220879532235334422670297141428191 ' & //'+ 0.7098057980612199357870532628105009808447460332437714 i' CALL ZMST2M(STZ2,ZC) CALL ZMSUB(ZA,ZC,ZD) CALL ZMABS(ZD,MA) CALL FMI2M(10,MB) CALL FMIPWR(MB,-50,ME) CALL FMEQ(ME,MB) IF (.NOT.FMCOMP(MA,'LE',MB)) THEN CALL ERRPRTZM('ZMCHSH',ZA,'ZA',ZC,'ZC',ZD,'ZD', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST23 SUBROUTINE TEST24(NCASE,NERROR,KLOG) ! Test the = assignment interface. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER NERROR,NCASE,KLOG LOGICAL FM_COMP,IM_COMP WRITE (KW,"(/' Testing the derived type = interface.')") RSMALL = EPSILON(1.0)*100.0 DSMALL = EPSILON(1.0D0)*100.0 MSMALL = EPSILON(TO_FM(1))*10000.0 NCASE = 162 J4 = MFM1 IF (J4 /= 581) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 163 J4 = MIM1 IF (J4 /= 661) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 164 J4 = MZM1 IF (J4 /= 731) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 165 R4 = MFM1 IF (ABS((R4-581.21)/581.21) > RSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 166 R4 = MIM1 IF (ABS((R4-661.0)/661.0) > RSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 167 R4 = MZM1 IF (ABS((R4-731.51)/731.51) > RSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 168 D4 = MFM1 IF (ABS((D4-581.21D0)/581.21D0) > DSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 169 D4 = MIM1 IF (ABS((D4-661.0D0)/661.0D0) > DSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 170 D4 = MZM1 IF (ABS((D4-731.51D0)/731.51D0) > DSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 171 C4 = MFM1 IF (ABS((C4-581.21)/581.21) > RSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 172 C4 = MIM1 IF (ABS((C4-661.0)/661.0) > RSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 173 C4 = MZM1 IF (ABS((C4-(731.51,711.41))/(731.51,711.41)) > RSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 174 CD4 = MFM1 IF (ABS((CD4-581.21D0)/581.21D0) > DSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 175 CD4 = MIM1 IF (ABS((CD4-661.0D0)/661.0D0) > DSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 176 CD4 = MZM1 IF (ABS((CD4-(731.51D0,711.41D0))/(731.51D0,711.41D0)) > DSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 177 MFM3 = J2 CALL FM_I2M(131,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ST2M('0',MFM3) IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 178 MFM3 = R2 CALL FM_ST2M('241.21',MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = RSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 179 MFM3 = D2 CALL FM_ST2M('391.61',MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = DSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 180 MFM3 = C2 CALL FM_ST2M('411.11',MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = RSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 181 MFM3 = CD2 CALL FM_ST2M('431.11',MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = DSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 182 MFM3 = MFM1 CALL FM_ST2M('581.21',MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_EQ(MSMALL,MFM3) IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 183 MFM3 = MIM1 CALL FM_ST2M('661',MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ST2M('0',MFM3) IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 184 MFM3 = MZM1 CALL FM_ST2M('731.51',MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = MSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 185 MIM3 = J2 CALL IM_I2M(131,MIM4) CALL IM_SUB(MIM3,MIM4,MIM5) CALL IM_EQ(MIM5,MIM4) CALL IM_ST2M('0',MIM3) IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 186 MIM3 = R2 CALL IM_ST2M('241',MIM4) CALL IM_SUB(MIM3,MIM4,MIM5) CALL IM_EQ(MIM5,MIM4) CALL IM_ST2M('0',MIM3) IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 187 MIM3 = D2 CALL IM_ST2M('391',MIM4) CALL IM_SUB(MIM3,MIM4,MIM5) CALL IM_EQ(MIM5,MIM4) CALL IM_ST2M('0',MIM3) IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 188 MIM3 = C2 CALL IM_ST2M('411',MIM4) CALL IM_SUB(MIM3,MIM4,MIM5) CALL IM_EQ(MIM5,MIM4) CALL IM_ST2M('0',MIM3) IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 189 MIM3 = CD2 CALL IM_ST2M('431',MIM4) CALL IM_SUB(MIM3,MIM4,MIM5) CALL IM_EQ(MIM5,MIM4) CALL IM_ST2M('0',MIM3) IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 190 MIM3 = MFM1 CALL IM_ST2M('581',MIM4) CALL IM_SUB(MIM3,MIM4,MIM5) CALL IM_EQ(MIM5,MIM4) CALL IM_ST2M('0',MIM3) IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 191 MIM3 = MIM1 CALL IM_ST2M('661',MIM4) CALL IM_SUB(MIM3,MIM4,MIM5) CALL IM_EQ(MIM5,MIM4) CALL IM_ST2M('0',MIM3) IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 192 MIM3 = MZM1 CALL IM_ST2M('731',MIM4) CALL IM_SUB(MIM3,MIM4,MIM5) CALL IM_EQ(MIM5,MIM4) CALL IM_ST2M('0',MIM3) IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 193 MZM3 = J2 CALL ZM_I2M(131,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) CALL FM_ST2M('0',MFM3) IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 194 MZM3 = R2 CALL ZM_ST2M('241.21',MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) MFM3 = RSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 195 MZM3 = D2 CALL ZM_ST2M('391.61',MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) MFM3 = DSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 196 MZM3 = C2 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) MFM3 = RSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 197 MZM3 = CD2 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) MFM3 = DSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 198 MZM3 = MFM1 CALL ZM_ST2M('581.21',MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) MFM3 = MSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 199 MZM3 = MIM1 CALL ZM_ST2M('661',MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) CALL FM_ST2M('0',MFM3) IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 200 MZM3 = MZM1 CALL ZM_ST2M('731.51 + 711.41 i',MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) MFM3 = MSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) END SUBROUTINE TEST24 SUBROUTINE TEST25(NCASE,NERROR,KLOG) ! Test the derived type == interface. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NCASE,NERROR LOGICAL FM_COMP WRITE (KW,"(/' Testing the derived type == interface.')") NCASE = 201 M_A = 123 M_B = M_A IF (.NOT.FM_COMP(M_A,'==',M_B)) THEN CALL ERRPRT_FM(' == ',M_A,'M_A',M_B,'M_B',M_B,'M_B', & NCASE,NERROR,KLOG) ENDIF NCASE = 202 M_A = 123 M_B = M_A IF (.NOT.FM_COMP(M_A,'EQ',M_B)) THEN CALL ERRPRT_FM(' == ',M_A,'M_A',M_B,'M_B',M_B,'M_B', & NCASE,NERROR,KLOG) ENDIF NCASE = 203 J1 = 123 M_A = J1 IF (.NOT.(M_A == J1)) THEN CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 204 J1 = 123 M_A = J1 IF (.NOT.(J1 == M_A)) THEN CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 205 J1 = 123 M_J = J1 IF (.NOT.(M_J == J1)) THEN CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 206 J1 = 123 M_J = J1 IF (.NOT.(J1 == M_J)) THEN CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 207 J1 = 123 M_Z = J1 IF (.NOT.(M_Z == J1)) THEN CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 208 J1 = 123 M_Z = J1 IF (.NOT.(J1 == M_Z)) THEN CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 209 R1 = 12.3 M_A = R1 IF (.NOT.(M_A == R1)) THEN CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 210 R1 = 12.3 M_A = R1 IF (.NOT.(R1 == M_A)) THEN CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 211 R1 = 123 M_J = R1 IF (.NOT.(M_J == R1)) THEN CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 212 R1 = 123 M_J = R1 IF (.NOT.(R1 == M_J)) THEN CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 213 R1 = 12.3 M_Z = R1 IF (.NOT.(M_Z == R1)) THEN CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 214 R1 = 12.3 M_Z = R1 IF (.NOT.(R1 == M_Z)) THEN CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 215 D1 = 12.3 M_A = D1 IF (.NOT.(M_A == D1)) THEN CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 216 D1 = 12.3 M_A = D1 IF (.NOT.(D1 == M_A)) THEN CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 217 D1 = 123 M_J = D1 IF (.NOT.(M_J == D1)) THEN CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 218 D1 = 123 M_J = D1 IF (.NOT.(D1 == M_J)) THEN CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 219 D1 = 12.3 M_Z = D1 IF (.NOT.(M_Z == D1)) THEN CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 220 D1 = 12.3 M_Z = D1 IF (.NOT.(D1 == M_Z)) THEN CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 221 C1 = 12.3 M_A = C1 IF (.NOT.(M_A == C1)) THEN CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 222 C1 = 12.3 M_A = C1 IF (.NOT.(C1 == M_A)) THEN CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 223 C1 = 123 M_J = C1 IF (.NOT.(M_J == C1)) THEN CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 224 C1 = 123 M_J = C1 IF (.NOT.(C1 == M_J)) THEN CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 225 C1 = (12.3 , 45.6) M_Z = C1 IF (.NOT.(M_Z == C1)) THEN CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 226 C1 = (12.3 , 45.6) M_Z = C1 IF (.NOT.(C1 == M_Z)) THEN CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 227 CD1 = 12.3 M_A = CD1 IF (.NOT.(M_A == CD1)) THEN CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 228 CD1 = 12.3 M_A = CD1 IF (.NOT.(CD1 == M_A)) THEN CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 229 CD1 = 123 M_J = CD1 IF (.NOT.(M_J == CD1)) THEN CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 230 CD1 = 123 M_J = CD1 IF (.NOT.(CD1 == M_J)) THEN CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 231 CD1 = (12.3 , 45.6) M_Z = CD1 IF (.NOT.(M_Z == CD1)) THEN CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 232 CD1 = (12.3 , 45.6) M_Z = CD1 IF (.NOT.(CD1 == M_Z)) THEN CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 233 M_B = 12.3 M_A = M_B IF (.NOT.(M_A == M_B)) THEN CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 234 M_B = 123 M_J = M_B IF (.NOT.(M_J == M_B)) THEN CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 235 M_B = 123 M_J = M_B IF (.NOT.(M_B == M_J)) THEN CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 236 M_B = (12.3 , 45.6) M_Z = M_B IF (.NOT.(M_Z == M_B)) THEN CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 237 M_B = (12.3 , 45.6) M_Z = M_B IF (.NOT.(M_B == M_Z)) THEN CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 238 M_K = 123 M_J = M_K IF (.NOT.(M_J == M_K)) THEN CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 239 M_K = (12.3 , 45.6) M_Z = M_K IF (.NOT.(M_Z == M_K)) THEN CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 240 M_K = (12.3 , 45.6) M_Z = M_K IF (.NOT.(M_K == M_Z)) THEN CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 241 M_Y = (12.3 , 45.6) M_Z = M_Y IF (.NOT.(M_Y == M_Z)) THEN CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST25 SUBROUTINE TEST26(NCASE,NERROR,KLOG) ! Test the derived type /= interface. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NCASE,NERROR LOGICAL FM_COMP WRITE (KW,"(/' Testing the derived type /= interface.')") NCASE = 242 M_A = 123 M_B = 124 IF (.NOT.FM_COMP(M_A,'/=',M_B)) THEN CALL ERRPRT_FM(' == ',M_A,'M_A',M_B,'M_B',M_B,'M_B', & NCASE,NERROR,KLOG) ENDIF NCASE = 243 M_A = 123 M_B = 124 IF (.NOT.FM_COMP(M_A,'NE',M_B)) THEN CALL ERRPRT_FM(' == ',M_A,'M_A',M_B,'M_B',M_B,'M_B', & NCASE,NERROR,KLOG) ENDIF NCASE = 244 J1 = 123 M_A = 1 + J1 IF (.NOT.(M_A /= J1)) THEN CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 245 J1 = 123 M_A = 1 + J1 IF (.NOT.(J1 /= M_A)) THEN CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 246 J1 = 123 M_J = 1 + J1 IF (.NOT.(M_J /= J1)) THEN CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 247 J1 = 123 M_J = 1 + J1 IF (.NOT.(J1 /= M_J)) THEN CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 248 J1 = 123 M_Z = 1 + J1 IF (.NOT.(M_Z /= J1)) THEN CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 249 J1 = 123 M_Z = 1 + J1 IF (.NOT.(J1 /= M_Z)) THEN CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 250 R1 = 12.3 M_A = 1 + R1 IF (.NOT.(M_A /= R1)) THEN CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 251 R1 = 12.3 M_A = 1 + R1 IF (.NOT.(R1 /= M_A)) THEN CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 252 R1 = 123 M_J = 1 + R1 IF (.NOT.(M_J /= R1)) THEN CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 253 R1 = 123 M_J = 1 + R1 IF (.NOT.(R1 /= M_J)) THEN CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 254 R1 = 12.3 M_Z = 1 + R1 IF (.NOT.(M_Z /= R1)) THEN CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 255 R1 = 12.3 M_Z = 1 + R1 IF (.NOT.(R1 /= M_Z)) THEN CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 256 D1 = 12.3 M_A = 1 + D1 IF (.NOT.(M_A /= D1)) THEN CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 257 D1 = 12.3 M_A = 1 + D1 IF (.NOT.(D1 /= M_A)) THEN CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 258 D1 = 123 M_J = 1 + D1 IF (.NOT.(M_J /= D1)) THEN CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 259 D1 = 123 M_J = 1 + D1 IF (.NOT.(D1 /= M_J)) THEN CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 260 D1 = 12.3 M_Z = 1 + D1 IF (.NOT.(M_Z /= D1)) THEN CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 261 D1 = 12.3 M_Z = 1 + D1 IF (.NOT.(D1 /= M_Z)) THEN CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 262 C1 = 12.3 M_A = 1 + C1 IF (.NOT.(M_A /= C1)) THEN CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 263 C1 = 12.3 M_A = 1 + C1 IF (.NOT.(C1 /= M_A)) THEN CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 264 C1 = 123 M_J = 1 + C1 IF (.NOT.(M_J /= C1)) THEN CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 265 C1 = 123 M_J = 1 + C1 IF (.NOT.(C1 /= M_J)) THEN CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 266 C1 = (12.3 , 45.6) M_Z = 1 + C1 IF (.NOT.(M_Z /= C1)) THEN CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 267 C1 = (12.3 , 45.6) M_Z = 1 + C1 IF (.NOT.(C1 /= M_Z)) THEN CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 268 CD1 = 12.3 M_A = 1 + CD1 IF (.NOT.(M_A /= CD1)) THEN CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 269 CD1 = 12.3 M_A = 1 + CD1 IF (.NOT.(CD1 /= M_A)) THEN CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 270 CD1 = 123 M_J = 1 + CD1 IF (.NOT.(M_J /= CD1)) THEN CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 271 CD1 = 123 M_J = 1 + CD1 IF (.NOT.(CD1 /= M_J)) THEN CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 272 CD1 = (12.3 , 45.6) M_Z = 1 + CD1 IF (.NOT.(M_Z /= CD1)) THEN CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 273 CD1 = (12.3 , 45.6) M_Z = 1 + CD1 IF (.NOT.(CD1 /= M_Z)) THEN CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 274 M_B = 12.3 M_A = 1 + M_B IF (.NOT.(M_A /= M_B)) THEN CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 275 M_B = 123 M_J = 1 + M_B IF (.NOT.(M_J /= M_B)) THEN CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 276 M_B = 123 M_J = 1 + M_B IF (.NOT.(M_B /= M_J)) THEN CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 277 M_B = (12.3 , 45.6) M_Z = 1 + M_B IF (.NOT.(M_Z /= M_B)) THEN CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 278 M_B = (12.3 , 45.6) M_Z = 1 + M_B IF (.NOT.(M_B /= M_Z)) THEN CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 279 M_K = 123 M_J = 1 + M_K IF (.NOT.(M_J /= M_K)) THEN CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 280 M_K = (12.3 , 45.6) M_Z = 1 + M_K IF (.NOT.(M_Z /= M_K)) THEN CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 281 M_K = (12.3 , 45.6) M_Z = 1 + M_K IF (.NOT.(M_K /= M_Z)) THEN CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF NCASE = 282 M_Y = (12.3 , 45.6) M_Z = 1 + M_Y IF (.NOT.(M_Y /= M_Z)) THEN CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST26 SUBROUTINE TEST27(NCASE,NERROR,KLOG) ! Test the derived type > interface. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NCASE,NERROR LOGICAL FM_COMP WRITE (KW,"(/' Testing the derived type > interface.')") NCASE = 283 M_A = 125 M_B = 124 IF (.NOT.FM_COMP(M_A,'>',M_B)) THEN CALL ERRPRT_FM(' > ',M_A,'M_A',M_B,'M_B',M_B,'M_B', & NCASE,NERROR,KLOG) ENDIF NCASE = 284 M_A = 125 M_B = 124 IF (.NOT.FM_COMP(M_A,'GT',M_B)) THEN CALL ERRPRT_FM(' > ',M_A,'M_A',M_B,'M_B',M_B,'M_B', & NCASE,NERROR,KLOG) ENDIF NCASE = 285 J1 = 123 M_A = J1 + 1 IF (.NOT.(M_A > J1)) THEN CALL ERRPRT_FM(' > ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 286 J1 = 123 M_A = J1 - 1 IF (.NOT.(J1 > M_A)) THEN CALL ERRPRT_FM(' > ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 287 J1 = 123 M_J = J1 + 1 IF (.NOT.(M_J > J1)) THEN CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 288 J1 = 123 M_J = J1 - 1 IF (.NOT.(J1 > M_J)) THEN CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 289 R1 = 12.3 M_A = R1 + 1 IF (.NOT.(M_A > R1)) THEN CALL ERRPRT_FM(' > ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 290 R1 = 12.3 M_A = R1 - 1 IF (.NOT.(R1 > M_A)) THEN CALL ERRPRT_FM(' > ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 291 R1 = 123 M_J = R1 + 1 IF (.NOT.(M_J > R1)) THEN CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 292 R1 = 123 M_J = R1 - 1 IF (.NOT.(R1 > M_J)) THEN CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 293 D1 = 12.3 M_A = D1 + 1 IF (.NOT.(M_A > D1)) THEN CALL ERRPRT_FM(' > ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 294 D1 = 12.3 M_A = D1 - 1 IF (.NOT.(D1 > M_A)) THEN CALL ERRPRT_FM(' > ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 295 D1 = 123 M_J = D1 + 1 IF (.NOT.(M_J > D1)) THEN CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 296 D1 = 123 M_J = D1 - 1 IF (.NOT.(D1 > M_J)) THEN CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 297 M_B = 12.3 M_A = M_B + 1 IF (.NOT.(M_A > M_B)) THEN CALL ERRPRT_FM(' > ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 298 M_B = 123 M_J = M_B + 1 IF (.NOT.(M_J > M_B)) THEN CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 299 M_B = 123 M_J = M_B - 1 IF (.NOT.(M_B > M_J)) THEN CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 300 M_K = 123 M_J = M_K + 1 IF (.NOT.(M_J > M_K)) THEN CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST27 SUBROUTINE TEST28(NCASE,NERROR,KLOG) ! Test the derived type >= interface. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NCASE,NERROR LOGICAL FM_COMP WRITE (KW,"(/' Testing the derived type >= interface.')") NCASE = 301 M_A = 125 M_B = 124 IF (.NOT.FM_COMP(M_A,'>=',M_B)) THEN CALL ERRPRT_FM(' >= ',M_A,'M_A',M_B,'M_B',M_B,'M_B', & NCASE,NERROR,KLOG) ENDIF NCASE = 302 M_A = 125 M_B = 124 IF (.NOT.FM_COMP(M_A,'GE',M_B)) THEN CALL ERRPRT_FM(' >= ',M_A,'M_A',M_B,'M_B',M_B,'M_B', & NCASE,NERROR,KLOG) ENDIF NCASE = 303 J1 = 123 M_A = J1 + 1 IF (.NOT.(M_A >= J1)) THEN CALL ERRPRT_FM(' >= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 304 J1 = 123 M_A = J1 - 1 IF (.NOT.(J1 >= M_A)) THEN CALL ERRPRT_FM(' >= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 305 J1 = 123 M_J = J1 + 1 IF (.NOT.(M_J >= J1)) THEN CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 306 J1 = 123 M_J = J1 - 1 IF (.NOT.(J1 >= M_J)) THEN CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 307 R1 = 12.3 M_A = R1 + 1 IF (.NOT.(M_A >= R1)) THEN CALL ERRPRT_FM(' >= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 308 R1 = 12.3 M_A = R1 - 1 IF (.NOT.(R1 >= M_A)) THEN CALL ERRPRT_FM(' >= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 309 R1 = 123 M_J = R1 + 1 IF (.NOT.(M_J >= R1)) THEN CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 310 R1 = 123 M_J = R1 - 1 IF (.NOT.(R1 >= M_J)) THEN CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 311 D1 = 12.3 M_A = D1 + 1 IF (.NOT.(M_A >= D1)) THEN CALL ERRPRT_FM(' >= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 312 D1 = 12.3 M_A = D1 - 1 IF (.NOT.(D1 >= M_A)) THEN CALL ERRPRT_FM(' >= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 313 D1 = 123 M_J = D1 + 1 IF (.NOT.(M_J >= D1)) THEN CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 314 D1 = 123 M_J = D1 - 1 IF (.NOT.(D1 >= M_J)) THEN CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 315 M_B = 12.3 M_A = M_B + 1 IF (.NOT.(M_A >= M_B)) THEN CALL ERRPRT_FM(' >= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 316 M_B = 123 M_J = M_B + 1 IF (.NOT.(M_J >= M_B)) THEN CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 317 M_B = 123 M_J = M_B - 1 IF (.NOT.(M_B >= M_J)) THEN CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 318 M_K = 123 M_J = M_K + 1 IF (.NOT.(M_J >= M_K)) THEN CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST28 SUBROUTINE TEST29(NCASE,NERROR,KLOG) ! Test the derived type < interface. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NCASE,NERROR LOGICAL FM_COMP WRITE (KW,"(/' Testing the derived type < interface.')") NCASE = 319 M_A = 123 M_B = 124 IF (.NOT.FM_COMP(M_A,'<',M_B)) THEN CALL ERRPRT_FM(' < ',M_A,'M_A',M_B,'M_B',M_B,'M_B', & NCASE,NERROR,KLOG) ENDIF NCASE = 320 M_A = 123 M_B = 124 IF (.NOT.FM_COMP(M_A,'LT',M_B)) THEN CALL ERRPRT_FM(' < ',M_A,'M_A',M_B,'M_B',M_B,'M_B', & NCASE,NERROR,KLOG) ENDIF NCASE = 321 J1 = 123 M_A = J1 - 2 IF (.NOT.(M_A < J1)) THEN CALL ERRPRT_FM(' < ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 322 J1 = 123 M_A = J1 + 2 IF (.NOT.(J1 < M_A)) THEN CALL ERRPRT_FM(' < ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 323 J1 = 123 M_J = J1 - 2 IF (.NOT.(M_J < J1)) THEN CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 324 J1 = 123 M_J = J1 + 2 IF (.NOT.(J1 < M_J)) THEN CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 325 R1 = 12.3 M_A = R1 - 2 IF (.NOT.(M_A < R1)) THEN CALL ERRPRT_FM(' < ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 326 R1 = 12.3 M_A = R1 + 2 IF (.NOT.(R1 < M_A)) THEN CALL ERRPRT_FM(' < ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 327 R1 = 123 M_J = R1 - 2 IF (.NOT.(M_J < R1)) THEN CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 328 R1 = 123 M_J = R1 + 2 IF (.NOT.(R1 < M_J)) THEN CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 329 D1 = 12.3 M_A = D1 - 2 IF (.NOT.(M_A < D1)) THEN CALL ERRPRT_FM(' < ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 330 D1 = 12.3 M_A = D1 + 2 IF (.NOT.(D1 < M_A)) THEN CALL ERRPRT_FM(' < ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 331 D1 = 123 M_J = D1 - 2 IF (.NOT.(M_J < D1)) THEN CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 332 D1 = 123 M_J = D1 + 2 IF (.NOT.(D1 < M_J)) THEN CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 333 M_B = 12.3 M_A = M_B - 2 IF (.NOT.(M_A < M_B)) THEN CALL ERRPRT_FM(' < ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 334 M_B = 123 M_J = M_B - 2 IF (.NOT.(M_J < M_B)) THEN CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 335 M_B = 123 M_J = M_B + 2 IF (.NOT.(M_B < M_J)) THEN CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 336 M_K = 123 M_J = M_K - 2 IF (.NOT.(M_J < M_K)) THEN CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST29 SUBROUTINE TEST30(NCASE,NERROR,KLOG) ! Test the derived type <= interface. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NCASE,NERROR LOGICAL FM_COMP WRITE (KW,"(/' Testing the derived type <= interface.')") NCASE = 337 M_A = 123 M_B = 124 IF (.NOT.FM_COMP(M_A,'<=',M_B)) THEN CALL ERRPRT_FM(' <= ',M_A,'M_A',M_B,'M_B',M_B,'M_B', & NCASE,NERROR,KLOG) ENDIF NCASE = 338 M_A = 123 M_B = 124 IF (.NOT.FM_COMP(M_A,'LE',M_B)) THEN CALL ERRPRT_FM(' <= ',M_A,'M_A',M_B,'M_B',M_B,'M_B', & NCASE,NERROR,KLOG) ENDIF NCASE = 339 J1 = 123 M_A = J1 - 2 IF (.NOT.(M_A <= J1)) THEN CALL ERRPRT_FM(' <= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 340 J1 = 123 M_A = J1 + 2 IF (.NOT.(J1 <= M_A)) THEN CALL ERRPRT_FM(' <= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 341 J1 = 123 M_J = J1 - 2 IF (.NOT.(M_J <= J1)) THEN CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 342 J1 = 123 M_J = J1 + 2 IF (.NOT.(J1 <= M_J)) THEN CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 343 R1 = 12.3 M_A = R1 - 2 IF (.NOT.(M_A <= R1)) THEN CALL ERRPRT_FM(' <= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 344 R1 = 12.3 M_A = R1 + 2 IF (.NOT.(R1 <= M_A)) THEN CALL ERRPRT_FM(' <= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 345 R1 = 123 M_J = R1 - 2 IF (.NOT.(M_J <= R1)) THEN CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 346 R1 = 123 M_J = R1 + 2 IF (.NOT.(R1 <= M_J)) THEN CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 347 D1 = 12.3 M_A = D1 - 2 IF (.NOT.(M_A <= D1)) THEN CALL ERRPRT_FM(' <= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 348 D1 = 12.3 M_A = D1 + 2 IF (.NOT.(D1 <= M_A)) THEN CALL ERRPRT_FM(' <= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 349 D1 = 123 M_J = D1 - 2 IF (.NOT.(M_J <= D1)) THEN CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 350 D1 = 123 M_J = D1 + 2 IF (.NOT.(D1 <= M_J)) THEN CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 351 M_B = 12.3 M_A = M_B - 2 IF (.NOT.(M_A <= M_B)) THEN CALL ERRPRT_FM(' <= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', & NCASE,NERROR,KLOG) ENDIF NCASE = 352 M_B = 123 M_J = M_B - 2 IF (.NOT.(M_J <= M_B)) THEN CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 353 M_B = 123 M_J = M_B + 2 IF (.NOT.(M_B <= M_J)) THEN CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF NCASE = 354 M_K = 123 M_J = M_K - 2 IF (.NOT.(M_J <= M_K)) THEN CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST30 SUBROUTINE TEST31(NCASE,NERROR,KLOG) ! Test the '+' arithmetic operator. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NERROR,NCASE WRITE (KW,"(/' Testing the derived type + interface.')") RSMALL = EPSILON(1.0)*100.0 DSMALL = EPSILON(1.0D0)*100.0 NCASE = 355 MFM3 = J2 + MFM1 CALL FM_ST2M('131',MFM4) CALL FM_ADD(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 356 MIM3 = J2 + MIM1 CALL IM_ST2M('131',MIM4) CALL IM_ADD(MIM4,MIM1,MIM5) CALL IM_EQ(MIM5,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 357 MZM3 = J2 + MZM1 CALL ZM_ST2M('131',MZM4) CALL ZM_ADD(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 358 MFM3 = R2 + MFM1 CALL FM_ST2M('241.21',MFM4) CALL FM_ADD(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 359 CALL FM_ST2M('241.21',MFM4) CALL FM_ST2M('661',MFM3) CALL FM_ADD(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = R2 + MIM1 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 360 MZM3 = R2 + MZM1 CALL ZM_ST2M('241.21',MZM4) CALL ZM_ADD(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 361 MFM3 = D2 + MFM1 CALL FM_ST2M('391.61',MFM4) CALL FM_ADD(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 362 CALL FM_ST2M('391.61',MFM4) CALL FM_ST2M('661',MFM3) CALL FM_ADD(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = D2 + MIM1 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 363 MZM3 = D2 + MZM1 CALL ZM_ST2M('391.61',MZM4) CALL ZM_ADD(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 364 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_ST2M('581.21',MZM3) CALL ZM_ADD(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = C2 + MFM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 365 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_ST2M('661',MZM3) CALL ZM_ADD(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = C2 + MIM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 366 MZM3 = C2 + MZM1 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_ADD(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 367 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_ST2M('581.21',MZM3) CALL ZM_ADD(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = CD2 + MFM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 368 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_ST2M('661',MZM3) CALL ZM_ADD(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = CD2 + MIM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 369 MZM3 = CD2 + MZM1 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_ADD(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 370 MFM3 = MFM1 + J2 CALL FM_ST2M('131',MFM4) CALL FM_ADD(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 371 MFM3 = MFM1 + R2 CALL FM_ST2M('241.21',MFM4) CALL FM_ADD(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 372 MFM3 = MFM1 + D2 CALL FM_ST2M('391.61',MFM4) CALL FM_ADD(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 373 CALL ZM_ST2M('581.21',MZM3) CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_ADD(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MFM1 + C2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 374 CALL ZM_ST2M('431.11 + 441.21 i',MZM3) CALL ZM_ST2M('581.21',MZM4) CALL ZM_ADD(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MFM1 + CD2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 375 MFM3 = MFM1 + MFM2 CALL FM_ADD(MFM1,MFM2,MFM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 376 MFM3 = MFM1 + MIM1 CALL FM_ST2M('661',MFM4) CALL FM_ADD(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 377 MZM3 = MFM1 + MZM1 CALL ZM_ST2M('581.21',MZM4) CALL ZM_ADD(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 378 MIM3 = MIM1 + J2 CALL IM_ST2M('131',MIM4) CALL IM_ADD(MIM1,MIM4,MIM5) CALL IM_EQ(MIM5,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 379 CALL FM_ST2M('241.21',MFM3) CALL FM_ST2M('661',MFM4) CALL FM_ADD(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = MIM1 + R2 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 380 CALL FM_ST2M('391.61',MFM3) CALL FM_ST2M('661',MFM4) CALL FM_ADD(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = MIM1 + D2 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 381 CALL ZM_ST2M('411.11 + 421.21 i',MZM3) CALL ZM_ST2M('661',MZM4) CALL ZM_ADD(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MIM1 + C2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 382 CALL ZM_ST2M('431.11 + 441.21 i',MZM3) CALL ZM_ST2M('661',MZM4) CALL ZM_ADD(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MIM1 + CD2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 383 MFM3 = MIM1 + MFM1 CALL FM_ST2M('661',MFM4) CALL FM_ADD(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 384 MIM3 = MIM1 + MIM2 CALL IM_ADD(MIM1,MIM2,MIM4) IF (MIM4 /= MIM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 385 MZM3 = MIM1 + MZM1 CALL ZM_ST2M('661',MZM4) CALL ZM_ADD(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 386 MZM3 = MZM1 + J2 CALL ZM_ST2M('131',MZM4) CALL ZM_ADD(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 387 MZM3 = MZM1 + R2 CALL ZM_ST2M('241.21',MZM4) CALL ZM_ADD(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 388 MZM3 = MZM1 + D2 CALL ZM_ST2M('391.61',MZM4) CALL ZM_ADD(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 389 MZM3 = MZM1 + C2 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_ADD(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 390 MZM3 = MZM1 + CD2 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_ADD(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 391 MZM3 = MZM1 + MFM1 CALL ZM_ST2M('581.21',MZM4) CALL ZM_ADD(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 392 MZM3 = MZM1 + MIM1 CALL ZM_ST2M('661',MZM4) CALL ZM_ADD(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 393 MZM3 = MZM1 + MZM2 CALL ZM_ADD(MZM1,MZM2,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 394 MFM3 = +MFM1 CALL FM_EQ(MFM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 395 MIM3 = +MIM1 CALL IM_EQ(MIM1,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 396 MZM3 = +MZM1 CALL ZM_EQ(MZM1,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) END SUBROUTINE TEST31 SUBROUTINE TEST32(NCASE,NERROR,KLOG) ! Test the '-' arithmetic operator. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NERROR,NCASE WRITE (KW,"(/' Testing the derived type - interface.')") RSMALL = EPSILON(1.0)*100.0 DSMALL = EPSILON(1.0D0)*100.0 NCASE = 397 MFM3 = J2 - MFM1 CALL FM_ST2M('131',MFM4) CALL FM_SUB(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 398 MIM3 = J2 - MIM1 CALL IM_ST2M('131',MIM4) CALL IM_SUB(MIM4,MIM1,MIM5) CALL IM_EQ(MIM5,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 399 MZM3 = J2 - MZM1 CALL ZM_ST2M('131',MZM4) CALL ZM_SUB(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 400 MFM3 = R2 - MFM1 CALL FM_ST2M('241.21',MFM4) CALL FM_SUB(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 401 CALL FM_ST2M('241.21',MFM4) CALL FM_ST2M('661',MFM3) CALL FM_SUB(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = R2 - MIM1 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 402 MZM3 = R2 - MZM1 CALL ZM_ST2M('241.21',MZM4) CALL ZM_SUB(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 403 MFM3 = D2 - MFM1 CALL FM_ST2M('391.61',MFM4) CALL FM_SUB(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 404 CALL FM_ST2M('391.61',MFM4) CALL FM_ST2M('661',MFM3) CALL FM_SUB(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = D2 - MIM1 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 405 MZM3 = D2 - MZM1 CALL ZM_ST2M('391.61',MZM4) CALL ZM_SUB(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 406 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_ST2M('581.21',MZM3) CALL ZM_SUB(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = C2 - MFM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 407 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_ST2M('661',MZM3) CALL ZM_SUB(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = C2 - MIM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 408 MZM3 = C2 - MZM1 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_SUB(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 409 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_ST2M('581.21',MZM3) CALL ZM_SUB(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = CD2 - MFM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 410 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_ST2M('661',MZM3) CALL ZM_SUB(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = CD2 - MIM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 411 MZM3 = CD2 - MZM1 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_SUB(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 412 MFM3 = MFM1 - J2 CALL FM_ST2M('131',MFM4) CALL FM_SUB(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 413 MFM3 = MFM1 - R2 CALL FM_ST2M('241.21',MFM4) CALL FM_SUB(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 414 MFM3 = MFM1 - D2 CALL FM_ST2M('391.61',MFM4) CALL FM_SUB(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 415 CALL ZM_ST2M('581.21',MZM3) CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MFM1 - C2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 416 CALL ZM_ST2M('431.11 + 441.21 i',MZM3) CALL ZM_ST2M('581.21',MZM4) CALL ZM_SUB(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MFM1 - CD2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 417 MFM3 = MFM1 - MFM2 CALL FM_SUB(MFM1,MFM2,MFM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 418 MFM3 = MFM1 - MIM1 CALL FM_ST2M('661',MFM4) CALL FM_SUB(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 419 MZM3 = MFM1 - MZM1 CALL ZM_ST2M('581.21',MZM4) CALL ZM_SUB(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 420 MIM3 = MIM1 - J2 CALL IM_ST2M('131',MIM4) CALL IM_SUB(MIM1,MIM4,MIM5) CALL IM_EQ(MIM5,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 421 CALL FM_ST2M('241.21',MFM3) CALL FM_ST2M('661',MFM4) CALL FM_SUB(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = MIM1 - R2 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 422 CALL FM_ST2M('391.61',MFM3) CALL FM_ST2M('661',MFM4) CALL FM_SUB(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = MIM1 - D2 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 423 CALL ZM_ST2M('411.11 + 421.21 i',MZM3) CALL ZM_ST2M('661',MZM4) CALL ZM_SUB(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MIM1 - C2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 424 CALL ZM_ST2M('431.11 + 441.21 i',MZM3) CALL ZM_ST2M('661',MZM4) CALL ZM_SUB(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MIM1 - CD2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 425 MFM3 = MIM1 - MFM1 CALL FM_ST2M('661',MFM4) CALL FM_SUB(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 426 MIM3 = MIM1 - MIM2 CALL IM_SUB(MIM1,MIM2,MIM4) IF (MIM4 /= MIM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 427 MZM3 = MIM1 - MZM1 CALL ZM_ST2M('661',MZM4) CALL ZM_SUB(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 428 MZM3 = MZM1 - J2 CALL ZM_ST2M('131',MZM4) CALL ZM_SUB(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 429 MZM3 = MZM1 - R2 CALL ZM_ST2M('241.21',MZM4) CALL ZM_SUB(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 430 MZM3 = MZM1 - D2 CALL ZM_ST2M('391.61',MZM4) CALL ZM_SUB(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 431 MZM3 = MZM1 - C2 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_SUB(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 432 MZM3 = MZM1 - CD2 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_SUB(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 433 MZM3 = MZM1 - MFM1 CALL ZM_ST2M('581.21',MZM4) CALL ZM_SUB(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 434 MZM3 = MZM1 - MIM1 CALL ZM_ST2M('661',MZM4) CALL ZM_SUB(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 435 MZM3 = MZM1 - MZM2 CALL ZM_SUB(MZM1,MZM2,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 436 MFM3 = -MFM1 CALL FM_I2M(0,MFM4) CALL FM_SUB(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 437 MIM3 = -MIM1 CALL IM_I2M(0,MIM4) CALL IM_SUB(MIM4,MIM1,MIM5) CALL IM_EQ(MIM5,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 438 MZM3 = -MZM1 CALL ZM_I2M(0,MZM4) CALL ZM_SUB(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) END SUBROUTINE TEST32 SUBROUTINE TEST33(NCASE,NERROR,KLOG) ! Test the '*' arithmetic operator. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NERROR,NCASE WRITE (KW,"(/' Testing the derived type * interface.')") RSMALL = EPSILON(1.0)*100.0 DSMALL = EPSILON(1.0D0)*100.0 NCASE = 439 MFM3 = J2 * MFM1 CALL FM_ST2M('131',MFM4) CALL FM_MPY(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 440 MIM3 = J2 * MIM1 CALL IM_ST2M('131',MIM4) CALL IM_MPY(MIM4,MIM1,MIM5) CALL IM_EQ(MIM5,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 441 MZM3 = J2 * MZM1 CALL ZM_ST2M('131',MZM4) CALL ZM_MPY(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 442 MFM3 = R2 * MFM1 CALL FM_ST2M('241.21',MFM4) CALL FM_MPY(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 443 CALL FM_ST2M('241.21',MFM4) CALL FM_ST2M('661',MFM3) CALL FM_MPY(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = R2 * MIM1 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 444 MZM3 = R2 * MZM1 CALL ZM_ST2M('241.21',MZM4) CALL ZM_MPY(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 445 MFM3 = D2 * MFM1 CALL FM_ST2M('391.61',MFM4) CALL FM_MPY(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 446 CALL FM_ST2M('391.61',MFM4) CALL FM_ST2M('661',MFM3) CALL FM_MPY(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = D2 * MIM1 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 447 MZM3 = D2 * MZM1 CALL ZM_ST2M('391.61',MZM4) CALL ZM_MPY(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 448 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_ST2M('581.21',MZM3) CALL ZM_MPY(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = C2 * MFM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 449 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_ST2M('661',MZM3) CALL ZM_MPY(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = C2 * MIM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 450 MZM3 = C2 * MZM1 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_MPY(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 451 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_ST2M('581.21',MZM3) CALL ZM_MPY(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = CD2 * MFM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 452 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_ST2M('661',MZM3) CALL ZM_MPY(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = CD2 * MIM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 453 MZM3 = CD2 * MZM1 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_MPY(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 454 MFM3 = MFM1 * J2 CALL FM_ST2M('131',MFM4) CALL FM_MPY(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 455 MFM3 = MFM1 * R2 CALL FM_ST2M('241.21',MFM4) CALL FM_MPY(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 456 MFM3 = MFM1 * D2 CALL FM_ST2M('391.61',MFM4) CALL FM_MPY(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 457 CALL ZM_ST2M('581.21',MZM3) CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_MPY(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MFM1 * C2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 458 CALL ZM_ST2M('431.11 + 441.21 i',MZM3) CALL ZM_ST2M('581.21',MZM4) CALL ZM_MPY(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MFM1 * CD2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 459 MFM3 = MFM1 * MFM2 CALL FM_MPY(MFM1,MFM2,MFM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 460 MFM3 = MFM1 * MIM1 CALL FM_ST2M('661',MFM4) CALL FM_MPY(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 461 MZM3 = MFM1 * MZM1 CALL ZM_ST2M('581.21',MZM4) CALL ZM_MPY(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 462 MIM3 = MIM1 * J2 CALL IM_ST2M('131',MIM4) CALL IM_MPY(MIM1,MIM4,MIM5) CALL IM_EQ(MIM5,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 463 CALL FM_ST2M('241.21',MFM3) CALL FM_ST2M('661',MFM4) CALL FM_MPY(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = MIM1 * R2 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 464 CALL FM_ST2M('391.61',MFM3) CALL FM_ST2M('661',MFM4) CALL FM_MPY(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = MIM1 * D2 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 465 CALL ZM_ST2M('411.11 + 421.21 i',MZM3) CALL ZM_ST2M('661',MZM4) CALL ZM_MPY(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MIM1 * C2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 466 CALL ZM_ST2M('431.11 + 441.21 i',MZM3) CALL ZM_ST2M('661',MZM4) CALL ZM_MPY(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MIM1 * CD2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 467 MFM3 = MIM1 * MFM1 CALL FM_ST2M('661',MFM4) CALL FM_MPY(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 468 MIM3 = MIM1 * MIM2 CALL IM_MPY(MIM1,MIM2,MIM4) IF (MIM4 /= MIM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 469 MZM3 = MIM1 * MZM1 CALL ZM_ST2M('661',MZM4) CALL ZM_MPY(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 470 MZM3 = MZM1 * J2 CALL ZM_ST2M('131',MZM4) CALL ZM_MPY(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 471 MZM3 = MZM1 * R2 CALL ZM_ST2M('241.21',MZM4) CALL ZM_MPY(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 472 MZM3 = MZM1 * D2 CALL ZM_ST2M('391.61',MZM4) CALL ZM_MPY(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 473 MZM3 = MZM1 * C2 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_MPY(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 474 MZM3 = MZM1 * CD2 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_MPY(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 475 MZM3 = MZM1 * MFM1 CALL ZM_ST2M('581.21',MZM4) CALL ZM_MPY(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 476 MZM3 = MZM1 * MIM1 CALL ZM_ST2M('661',MZM4) CALL ZM_MPY(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 477 MZM3 = MZM1 * MZM2 CALL ZM_MPY(MZM1,MZM2,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) END SUBROUTINE TEST33 SUBROUTINE TEST34(NCASE,NERROR,KLOG) ! Test the '/' arithmetic operator. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NERROR,NCASE WRITE (KW,"(/' Testing the derived type / interface.')") RSMALL = EPSILON(1.0)*100.0 DSMALL = EPSILON(1.0D0)*100.0 NCASE = 478 MFM3 = J2 / MFM1 CALL FM_ST2M('131',MFM4) CALL FM_DIV(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 479 MIM3 = J2 / MIM1 CALL IM_ST2M('131',MIM4) CALL IM_DIV(MIM4,MIM1,MIM5) CALL IM_EQ(MIM5,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 480 MZM3 = J2 / MZM1 CALL ZM_ST2M('131',MZM4) CALL ZM_DIV(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 481 MFM3 = R2 / MFM1 CALL FM_ST2M('241.21',MFM4) CALL FM_DIV(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 482 CALL FM_ST2M('241.21',MFM4) CALL FM_ST2M('661',MFM3) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = R2 / MIM1 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 483 MZM3 = R2 / MZM1 CALL ZM_ST2M('241.21',MZM4) CALL ZM_DIV(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 484 MFM3 = D2 / MFM1 CALL FM_ST2M('391.61',MFM4) CALL FM_DIV(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 485 CALL FM_ST2M('391.61',MFM4) CALL FM_ST2M('661',MFM3) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = D2 / MIM1 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 486 MZM3 = D2 / MZM1 CALL ZM_ST2M('391.61',MZM4) CALL ZM_DIV(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 487 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_ST2M('581.21',MZM3) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = C2 / MFM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 488 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_ST2M('661',MZM3) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = C2 / MIM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 489 MZM3 = C2 / MZM1 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_DIV(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 490 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_ST2M('581.21',MZM3) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = CD2 / MFM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 491 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_ST2M('661',MZM3) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = CD2 / MIM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 492 MZM3 = CD2 / MZM1 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_DIV(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 493 MFM3 = MFM1 / J2 CALL FM_ST2M('131',MFM4) CALL FM_DIV(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 494 MFM3 = MFM1 / R2 CALL FM_ST2M('241.21',MFM4) CALL FM_DIV(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 495 MFM3 = MFM1 / D2 CALL FM_ST2M('391.61',MFM4) CALL FM_DIV(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 496 CALL ZM_ST2M('581.21',MZM3) CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_DIV(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MFM1 / C2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 497 CALL ZM_ST2M('431.11 + 441.21 i',MZM3) CALL ZM_ST2M('581.21',MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MFM1 / CD2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 498 MFM3 = MFM1 / MFM2 CALL FM_DIV(MFM1,MFM2,MFM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 499 MFM3 = MFM1 / MIM1 CALL FM_ST2M('661',MFM4) CALL FM_DIV(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 500 MZM3 = MFM1 / MZM1 CALL ZM_ST2M('581.21',MZM4) CALL ZM_DIV(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 501 MIM3 = MIM1 / J2 CALL IM_ST2M('131',MIM4) CALL IM_DIV(MIM1,MIM4,MIM5) CALL IM_EQ(MIM5,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 502 CALL FM_ST2M('241.21',MFM3) CALL FM_ST2M('661',MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = MIM1 / R2 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 503 CALL FM_ST2M('391.61',MFM3) CALL FM_ST2M('661',MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = MIM1 / D2 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 504 CALL ZM_ST2M('411.11 + 421.21 i',MZM3) CALL ZM_ST2M('661',MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MIM1 / C2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 505 CALL ZM_ST2M('431.11 + 441.21 i',MZM3) CALL ZM_ST2M('661',MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MIM1 / CD2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 506 MFM3 = MIM1 / MFM1 CALL FM_ST2M('661',MFM4) CALL FM_DIV(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 507 MIM3 = MIM1 / MIM2 CALL IM_DIV(MIM1,MIM2,MIM4) IF (MIM4 /= MIM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 508 MZM3 = MIM1 / MZM1 CALL ZM_ST2M('661',MZM4) CALL ZM_DIV(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 509 MZM3 = MZM1 / J2 CALL ZM_ST2M('131',MZM4) CALL ZM_DIV(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 510 MZM3 = MZM1 / R2 CALL ZM_ST2M('241.21',MZM4) CALL ZM_DIV(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 511 MZM3 = MZM1 / D2 CALL ZM_ST2M('391.61',MZM4) CALL ZM_DIV(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 512 MZM3 = MZM1 / C2 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_DIV(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 513 MZM3 = MZM1 / CD2 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_DIV(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 514 MZM3 = MZM1 / MFM1 CALL ZM_ST2M('581.21',MZM4) CALL ZM_DIV(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 515 MZM3 = MZM1 / MIM1 CALL ZM_ST2M('661',MZM4) CALL ZM_DIV(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 516 MZM3 = MZM1 / MZM2 CALL ZM_DIV(MZM1,MZM2,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) END SUBROUTINE TEST34 SUBROUTINE TEST35(NCASE,NERROR,KLOG) ! Test the '**' arithmetic operator. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NERROR,NCASE WRITE (KW,"(/' Testing the derived type ** interface.')") ! Use a larger error tolerance for large exponents. RSMALL = EPSILON(1.0)*10000.0 DSMALL = EPSILON(1.0D0)*10000.0 NCASE = 517 MFM3 = J2 ** MFM1 CALL FM_ST2M('131',MFM4) CALL FM_PWR(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 518 J4 = 2 MIM3 = J4 ** MIM1 CALL IM_ST2M('2',MIM4) CALL IM_PWR(MIM4,MIM1,MIM5) CALL IM_EQ(MIM5,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 519 MZM3 = J2 ** MZM1 CALL ZM_ST2M('131',MZM4) CALL ZM_PWR(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 520 MFM3 = R2 ** MFM1 CALL FM_ST2M('241.21',MFM4) CALL FM_PWR(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 521 CALL FM_ST2M('241.21',MFM4) CALL FM_ST2M('661',MFM3) CALL FM_PWR(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = R2 ** MIM1 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 522 MZM3 = R2 ** MZM1 CALL ZM_ST2M('241.21',MZM4) CALL ZM_PWR(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 523 MFM3 = D2 ** MFM1 CALL FM_ST2M('391.61',MFM4) CALL FM_PWR(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 524 CALL FM_ST2M('391.61',MFM4) CALL FM_ST2M('661',MFM3) CALL FM_PWR(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = D2 ** MIM1 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 525 MZM3 = D2 ** MZM1 CALL ZM_ST2M('391.61',MZM4) CALL ZM_PWR(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 526 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_ST2M('581.21',MZM3) CALL ZM_PWR(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = C2 ** MFM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 527 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_ST2M('661',MZM3) CALL ZM_PWR(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = C2 ** MIM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 528 MZM3 = C2 ** MZM1 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_PWR(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 529 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_ST2M('581.21',MZM3) CALL ZM_PWR(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = CD2 ** MFM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 530 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_ST2M('661',MZM3) CALL ZM_PWR(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = CD2 ** MIM1 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 531 MZM3 = CD2 ** MZM1 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_PWR(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 532 MFM3 = MFM1 ** J2 CALL FM_ST2M('131',MFM4) CALL FM_PWR(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 533 MFM3 = MFM1 ** R2 CALL FM_ST2M('241.21',MFM4) CALL FM_PWR(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 534 MFM3 = MFM1 ** D2 CALL FM_ST2M('391.61',MFM4) CALL FM_PWR(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 535 CALL ZM_ST2M('581.21',MZM3) CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_PWR(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MFM1 ** C2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 536 CALL ZM_ST2M('431.11 + 441.21 i',MZM3) CALL ZM_ST2M('581.21',MZM4) CALL ZM_PWR(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MFM1 ** CD2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 537 MFM3 = MFM1 ** MFM2 CALL FM_PWR(MFM1,MFM2,MFM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 538 MFM3 = MFM1 ** MIM1 CALL FM_ST2M('661',MFM4) CALL FM_PWR(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 539 MZM3 = MFM1 ** MZM1 CALL ZM_ST2M('581.21',MZM4) CALL ZM_PWR(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 540 J4 = 17 MIM3 = MIM1 ** J4 CALL IM_ST2M('17',MIM4) CALL IM_PWR(MIM1,MIM4,MIM5) CALL IM_EQ(MIM5,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 541 CALL FM_ST2M('241.21',MFM3) CALL FM_ST2M('661',MFM4) CALL FM_PWR(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = MIM1 ** R2 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 542 CALL FM_ST2M('391.61',MFM3) CALL FM_ST2M('661',MFM4) CALL FM_PWR(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = MIM1 ** D2 CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 543 CALL ZM_ST2M('411.11 + 421.21 i',MZM3) CALL ZM_ST2M('661',MZM4) CALL ZM_PWR(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MIM1 ** C2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 544 CALL ZM_ST2M('431.11 + 441.21 i',MZM3) CALL ZM_ST2M('661',MZM4) CALL ZM_PWR(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) MZM3 = MIM1 ** CD2 CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 545 MFM3 = MIM1 ** MFM1 CALL FM_ST2M('661',MFM4) CALL FM_PWR(MFM4,MFM1,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 546 MIM4 = 19 MIM3 = MIM1 ** MIM4 CALL IM_PWR(MIM1,MIM4,MIM5) CALL IM_EQ(MIM5,MIM4) IF (MIM4 /= MIM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 547 MZM3 = MIM1 ** MZM1 CALL ZM_ST2M('661',MZM4) CALL ZM_PWR(MZM4,MZM1,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 548 MZM3 = MZM1 ** J2 CALL ZM_ST2M('131',MZM4) CALL ZM_PWR(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 549 MZM3 = MZM1 ** R2 CALL ZM_ST2M('241.21',MZM4) CALL ZM_PWR(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 550 MZM3 = MZM1 ** D2 CALL ZM_ST2M('391.61',MZM4) CALL ZM_PWR(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 551 MZM3 = MZM1 ** C2 CALL ZM_ST2M('411.11 + 421.21 i',MZM4) CALL ZM_PWR(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 552 MZM3 = MZM1 ** CD2 CALL ZM_ST2M('431.11 + 441.21 i',MZM4) CALL ZM_PWR(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 553 MZM3 = MZM1 ** MFM1 CALL ZM_ST2M('581.21',MZM4) CALL ZM_PWR(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 554 MZM3 = MZM1 ** MIM1 CALL ZM_ST2M('661',MZM4) CALL ZM_PWR(MZM1,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 555 MZM3 = MZM1 ** MZM2 CALL ZM_PWR(MZM1,MZM2,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR) END SUBROUTINE TEST35 SUBROUTINE TEST36(NCASE,NERROR,KLOG) ! Test functions ABS, ..., CEILING. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER J,JERR,KLOG,NERROR,NCASE WRITE (KW,"(/' Testing the derived type ABS, ..., CEILING interfaces.')") NCASE = 556 MFM3 = ABS(MFM1) CALL FM_ABS(MFM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 557 MIM3 = ABS(MIM1) CALL IM_ABS(MIM1,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 558 MFM3 = ABS(MZM1) CALL ZM_ABS(MZM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 559 CALL FM_ST2M('0.7654',MFM4) MFM3 = ACOS(MFM4) CALL FM_ACOS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 560 CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4) MZM3 = ACOS(MZM4) CALL ZM_ACOS(MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 561 CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4) MFM3 = AIMAG(MZM4) CALL ZM_IMAG(MZM4,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 562 MFM3 = AINT(MFM1) CALL FM_INT(MFM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 563 MZM3 = AINT(MZM1) CALL ZM_INT(MZM1,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 564 MFM3 = ANINT(MFM1) CALL FM_NINT(MFM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 565 MZM3 = ANINT(MZM1) CALL ZM_NINT(MZM1,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 566 CALL FM_ST2M('0.7654',MFM4) MFM3 = ASIN(MFM4) CALL FM_ASIN(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 567 CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4) MZM3 = ASIN(MZM4) CALL ZM_ASIN(MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 568 CALL FM_ST2M('0.7654',MFM4) MFM3 = ATAN(MFM4) CALL FM_ATAN(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 569 CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4) MZM3 = ATAN(MZM4) CALL ZM_ATAN(MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 570 MFM3 = ATAN2(MFM1,MFM2) CALL FM_ATN2(MFM1,MFM2,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 571 JERR = -1 DO J = 0, 10 IF (BTEST(661,J)) THEN IF (.NOT.BTEST(MIM1,J)) JERR = J ELSE IF (BTEST(MIM1,J)) JERR = J ENDIF ENDDO IF (JERR >= 0) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 572 CALL FM_ST2M('12.37654',MFM4) MFM3 = CEILING(MFM4) CALL FM_ST2M('13',MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 573 CALL FM_ST2M('-12.7654',MFM4) MFM3 = CEILING(MFM4) CALL FM_ST2M('-12',MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 574 CALL ZM_ST2M('12.37654 - 22.54 i',MZM4) MZM3 = CEILING(MZM4) CALL ZM_ST2M('13 - 22 i',MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 575 CALL ZM_ST2M('-12.7654 + 22.31 i',MZM4) MZM3 = CEILING(MZM4) CALL ZM_ST2M('-12 + 23 i',MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) END SUBROUTINE TEST36 SUBROUTINE TEST37(NCASE,NERROR,KLOG) ! Test functions CMPLX, ..., EXPONENT. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER J,KLOG,NERROR,NCASE WRITE (KW,"(/"// & "' Testing the derived type CMPLX, ..., EXPONENT interfaces.')") NCASE = 576 MZM3 = CMPLX(MFM1,MFM2) CALL ZM_CMPX(MFM1,MFM2,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 577 MZM3 = CMPLX(MIM1,MIM2) CALL IM_I2FM(MIM1,MFM3) CALL IM_I2FM(MIM2,MFM4) CALL ZM_CMPX(MFM3,MFM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 578 MZM3 = CMPLX(MFM1) CALL FM_I2M(0,MFM4) CALL ZM_CMPX(MFM1,MFM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 579 MZM3 = CMPLX(MIM1) CALL IM_I2FM(MIM1,MFM3) CALL FM_I2M(0,MFM4) CALL ZM_CMPX(MFM3,MFM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 580 MZM3 = CONJG(MZM1) CALL ZM_CONJ(MZM1,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 581 CALL FM_ST2M('0.7654',MFM4) MFM3 = COS(MFM4) CALL FM_COS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 582 CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4) MZM3 = COS(MZM4) CALL ZM_COS(MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 583 CALL FM_ST2M('0.7654',MFM4) MFM3 = COSH(MFM4) CALL FM_COSH(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 584 CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4) MZM3 = COSH(MZM4) CALL ZM_COSH(MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 585 MFM3 = DBLE(MFM1) CALL FM_EQ(MFM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 586 MFM3 = DBLE(MIM1) CALL IM_I2FM(MIM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 587 MFM3 = DBLE(MZM1) CALL ZM_REAL(MZM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 588 J = DIGITS(MFM1) IF (J /= NDIG) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 589 J = DIGITS(MIM1) IF (J /= NDIGMX) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 590 J = DIGITS(MZM1) IF (J /= NDIG) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 591 MFM3 = DIM(MFM1,MFM2) CALL FM_DIM(MFM1,MFM2,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 592 MIM3 = DIM(MIM1,MIM2) CALL IM_DIM(MIM1,MIM2,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 593 MFM3 = DINT (MFM1) CALL FM_INT(MFM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 594 MZM3 = DINT (MZM1) CALL ZM_INT(MZM1,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 595 CALL FM_ST2M('1.23',MFMV1(1)) CALL FM_ST2M('2.23',MFMV1(2)) CALL FM_ST2M('3.23',MFMV1(3)) CALL FM_ST2M('4.23',MFMV2(1)) CALL FM_ST2M('5.23',MFMV2(2)) CALL FM_ST2M('6.23',MFMV2(3)) MFM3 = DOTPRODUCT(MFMV1,MFMV2) MFM4 = 0 DO J = 1, 3 MFM4 = MFM4 + MFMV1(J)*MFMV2(J) ENDDO IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 596 CALL IM_ST2M('12',MIMV1(1)) CALL IM_ST2M('23',MIMV1(2)) CALL IM_ST2M('34',MIMV1(3)) CALL IM_ST2M('-14',MIMV2(1)) CALL IM_ST2M('-5',MIMV2(2)) CALL IM_ST2M('16',MIMV2(3)) MIM3 = DOTPRODUCT(MIMV1,MIMV2) MIM4 = 0 DO J = 1, 3 MIM4 = MIM4 + MIMV1(J)*MIMV2(J) ENDDO IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 597 CALL ZM_ST2M('1.23 + 1.67 i',MZMV1(1)) CALL ZM_ST2M('2.23 - 2.56 i',MZMV1(2)) CALL ZM_ST2M('3.23 + 3.45 i',MZMV1(3)) CALL ZM_ST2M('4.23 - 4.34 i',MZMV2(1)) CALL ZM_ST2M('5.23 + 5.23 i',MZMV2(2)) CALL ZM_ST2M('6.23 - 6.12 i',MZMV2(3)) MZM3 = DOTPRODUCT(MZMV1,MZMV2) MZM4 = 0 DO J = 1, 3 MZM4 = MZM4 + MZMV1(J)*MZMV2(J) ENDDO IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 598 MFM3 = EPSILON(MFM1) CALL FM_I2M(1,MFM4) CALL FM_ULP(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 599 CALL FM_ST2M('0.7654',MFM4) MFM3 = EXP(MFM4) CALL FM_EXP(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 600 CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4) MZM3 = EXP(MZM4) CALL ZM_EXP(MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 601 J = EXPONENT(MFM1) IF (J /= INT(MFM1%MFM(1))) CALL PRTERR(KW,KLOG,NCASE,NERROR) END SUBROUTINE TEST37 SUBROUTINE TEST38(NCASE,NERROR,KLOG) ! Test functions FLOOR, ..., MIN. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER I,J,KLOG,NERROR,NCASE WRITE (KW,"(/"// & "' Testing the derived type FLOOR, ..., MIN interfaces.')") NCASE = 602 CALL FM_ST2M('12.37654',MFM4) MFM3 = FLOOR(MFM4) CALL FM_ST2M('12',MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 603 CALL FM_ST2M('-12.7654',MFM4) MFM3 = FLOOR(MFM4) CALL FM_ST2M('-13',MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 604 CALL IM_ST2M('12',MIM4) MIM3 = FLOOR(MIM4) CALL IM_ST2M('12',MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 605 CALL IM_ST2M('-123',MIM4) MIM3 = FLOOR(MIM4) CALL IM_ST2M('-123',MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 606 CALL ZM_ST2M('12.37654 - 22.54 i',MZM4) MZM3 = FLOOR(MZM4) CALL ZM_ST2M('12 - 23 i',MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 607 CALL ZM_ST2M('-12.7654 + 22.31 i',MZM4) MZM3 = FLOOR(MZM4) CALL ZM_ST2M('-13 + 22 i',MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 608 CALL FM_ST2M('12.37654',MFM4) MFM3 = FRACTION(MFM4) MFM4%MFM(1) = 0 IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 609 CALL ZM_ST2M('12.37654 - 22.54',MZM4) MZM3 = FRACTION(MZM4) MZM4%MZM(1) = 0 MZM4%MZM(KPTIMU+01) = 0 IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 610 MFM3 = HUGE(MFM1) CALL FM_BIG(MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 611 MIM3 = HUGE(MIM1) CALL IM_BIG(MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 612 MZM3 = HUGE(MZM1) CALL FM_BIG(MFM4) CALL ZM_CMPX(MFM4,MFM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 613 MIM3 = INT(MFM1) CALL FM_INT(MFM1,MFM4) CALL IM_FM2I(MFM4,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 614 MIM3 = INT(MIM1) CALL IM_EQ(MIM1,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 615 MIM3 = INT(MZM1) CALL ZM_INT(MZM1,MZM4) CALL ZM_REAL(MZM4,MFM4) CALL IM_FM2I(MFM4,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 616 CALL FM_ST2M('0.7654',MFM4) MFM3 = LOG(MFM4) CALL FM_LN(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 617 CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4) MZM3 = LOG(MZM4) CALL ZM_LN(MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 618 CALL FM_ST2M('0.7654',MFM4) MFM3 = LOG10(MFM4) CALL FM_LG10(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 619 CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4) MZM3 = LOG10(MZM4) CALL ZM_LG10(MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 620 DO I = 1, 3 DO J = 1, 3 MFMA(I,J) = 3*(J-1) + I MFMB(I,J) = 3*(I-1) + J + 10 ENDDO ENDDO MFMC = MATMUL(MFMA,MFMB) MFM3 = ABS(MFMC(1,1)-186)+ABS(MFMC(1,2)-198)+ABS(MFMC(1,3)-210)+ & ABS(MFMC(2,1)-228)+ABS(MFMC(2,2)-243)+ABS(MFMC(2,3)-258)+ & ABS(MFMC(3,1)-270)+ABS(MFMC(3,2)-288)+ABS(MFMC(3,3)-306) IF (MFM3 /= 0) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 621 DO I = 1, 2 DO J = 1, 2 MIMA(I,J) = 2*(J-1) + I + 20 MIMB(I,J) = 2*(I-1) + J + 30 ENDDO ENDDO MIMC = MATMUL(MIMA,MIMB) MIM3 = ABS(MIMC(1,1)-1410) + ABS(MIMC(1,2)-1454) + & ABS(MIMC(2,1)-1474) + ABS(MIMC(2,2)-1520) IF (MIM3 /= 0) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 622 DO I = 1, 2 DO J = 1, 3 MZMA(I,J) = CMPLX(TO_FM(2*(J-1)+I+10),TO_FM(2*(J-1)+I+20)) ENDDO ENDDO DO I = 1, 3 DO J = 1, 4 MZMB(I,J) = CMPLX(TO_FM(4*(I-1)+J+50),TO_FM(4*(I-1)+J+30)) ENDDO ENDDO MZMC = MATMUL(MZMA,MZMB) MFM3 = ABS(MZMC(1,1)-TO_ZM('-270 + 5192 i')) + & ABS(MZMC(1,2)-TO_ZM('-300 + 5300 i')) + & ABS(MZMC(1,3)-TO_ZM('-330 + 5408 i')) + & ABS(MZMC(1,4)-TO_ZM('-360 + 5516 i')) + & ABS(MZMC(2,1)-TO_ZM('-210 + 5462 i')) + & ABS(MZMC(2,2)-TO_ZM('-240 + 5576 i')) + & ABS(MZMC(2,3)-TO_ZM('-270 + 5690 i')) + & ABS(MZMC(2,4)-TO_ZM('-300 + 5804 i')) IF (MFM3 /= 0) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 623 MFM3 = MAX(MFM1,MFM2) CALL FM_MAX(MFM1,MFM2,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 624 CALL FM_ST2M('0.7654',MFM4) MFM3 = MAX(MFM2,MFM1,MFM4) CALL FM_MAX(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_MAX(MFM2,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 625 MIM3 = MAX(MIM1,MIM2) CALL IM_MAX(MIM1,MIM2,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 626 CALL IM_ST2M('7654',MIM4) CALL IM_ST2M('-1654',MIM3) MIM3 = MAX(MIM2,MIM1,MIM3,MIM4) CALL IM_ST2M('7654',MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 627 J = MAXEXPONENT(MFM1) IF (J /= INT(MXEXP)+1) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 628 MFM3 = MIN(MFM1,MFM2) CALL FM_MIN(MFM1,MFM2,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 629 CALL FM_ST2M('0.7654',MFM4) MFM3 = MIN(MFM2,MFM1,MFM4) CALL FM_MIN(MFM1,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_MIN(MFM2,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 630 MIM3 = MIN(MIM1,MIM2) CALL IM_MIN(MIM1,MIM2,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 631 CALL IM_ST2M('7654',MIM4) CALL IM_ST2M('-1654',MIM3) MIM3 = MIN(MIM2,MIM1,MIM3,MIM4) CALL IM_ST2M('-1654',MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) END SUBROUTINE TEST38 SUBROUTINE TEST39(NCASE,NERROR,KLOG) ! Test functions MINEXPONENT, ..., RRSPACING. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER J,KLOG,NERROR,NCASE WRITE (KW,"(/"// & "' Testing the derived type MINEXPONENT, ..., RRSPACING interfaces.')") NCASE = 632 J = MINEXPONENT(MFM1) IF (J /= -INT(MXEXP)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 633 CALL FM_ST2M('8',MFM3) CALL FM_ST2M('5',MFM4) MFM3 = MOD(MFM3,MFM4) CALL FM_ST2M('3',MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 634 CALL FM_ST2M('-8',MFM3) CALL FM_ST2M('5',MFM4) MFM3 = MOD(MFM3,MFM4) CALL FM_ST2M('-3',MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 635 CALL FM_ST2M('8',MFM3) CALL FM_ST2M('-5',MFM4) MFM3 = MOD(MFM3,MFM4) CALL FM_ST2M('3',MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 636 CALL FM_ST2M('-8',MFM3) CALL FM_ST2M('-5',MFM4) MFM3 = MOD(MFM3,MFM4) CALL FM_ST2M('-3',MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 637 CALL IM_ST2M('8',MIM3) CALL IM_ST2M('5',MIM4) MIM3 = MOD(MIM3,MIM4) CALL IM_ST2M('3',MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 638 CALL IM_ST2M('-8',MIM3) CALL IM_ST2M('5',MIM4) MIM3 = MOD(MIM3,MIM4) CALL IM_ST2M('-3',MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 639 CALL IM_ST2M('8',MIM3) CALL IM_ST2M('-5',MIM4) MIM3 = MOD(MIM3,MIM4) CALL IM_ST2M('3',MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 640 CALL IM_ST2M('-8',MIM3) CALL IM_ST2M('-5',MIM4) MIM3 = MOD(MIM3,MIM4) CALL IM_ST2M('-3',MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 641 CALL FM_ST2M('8',MFM3) CALL FM_ST2M('5',MFM4) MFM3 = MODULO(MFM3,MFM4) CALL FM_ST2M('3',MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 642 CALL FM_ST2M('-8',MFM3) CALL FM_ST2M('5',MFM4) MFM3 = MODULO(MFM3,MFM4) CALL FM_ST2M('2',MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 643 CALL FM_ST2M('8',MFM3) CALL FM_ST2M('-5',MFM4) MFM3 = MODULO(MFM3,MFM4) CALL FM_ST2M('-2',MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 644 CALL FM_ST2M('-8',MFM3) CALL FM_ST2M('-5',MFM4) MFM3 = MODULO(MFM3,MFM4) CALL FM_ST2M('-3',MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 645 CALL IM_ST2M('8',MIM3) CALL IM_ST2M('5',MIM4) MIM3 = MODULO(MIM3,MIM4) CALL IM_ST2M('3',MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 646 CALL IM_ST2M('-8',MIM3) CALL IM_ST2M('5',MIM4) MIM3 = MODULO(MIM3,MIM4) CALL IM_ST2M('2',MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 647 CALL IM_ST2M('8',MIM3) CALL IM_ST2M('-5',MIM4) MIM3 = MODULO(MIM3,MIM4) CALL IM_ST2M('-2',MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 648 CALL IM_ST2M('-8',MIM3) CALL IM_ST2M('-5',MIM4) MIM3 = MODULO(MIM3,MIM4) CALL IM_ST2M('-3',MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 649 CALL FM_ST2M('0',MFM4) CALL FM_ST2M('1',MFM3) CALL FM_BIG(MFM5) CALL FM_DIV(MFM3,MFM5,MFM6) CALL FM_EQ(MFM6,MFM5) MFM3 = NEAREST(MFM4,MFM3) IF (MFM3 /= MFM5) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 650 CALL FM_ST2M('0',MFM4) CALL FM_ST2M('-1',MFM3) CALL FM_BIG(MFM5) CALL FM_DIV(MFM3,MFM5,MFM6) CALL FM_EQ(MFM6,MFM5) MFM3 = NEAREST(MFM4,MFM3) IF (MFM3 /= MFM5) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 651 CALL FM_ST2M('2.345',MFM4) CALL FM_ST2M('1',MFM3) MFM3 = NEAREST(MFM4,MFM3) CALL FM_ULP(MFM4,MFM5) CALL FM_ADD(MFM4,MFM5,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 652 CALL FM_ST2M('2.345',MFM4) CALL FM_ST2M('-1',MFM3) MFM3 = NEAREST(MFM4,MFM3) CALL FM_ULP(MFM4,MFM5) CALL FM_SUB(MFM4,MFM5,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 653 CALL FM_ST2M('1',MFM4) CALL FM_ST2M('-1',MFM3) MFM3 = NEAREST(MFM4,MFM3) CALL FM_ST2M('0.99',MFM5) CALL FM_ULP(MFM5,MFM6) CALL FM_EQ(MFM6,MFM5) CALL FM_SUB(MFM4,MFM5,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 654 CALL FM_ST2M('-1',MFM4) CALL FM_ST2M('12',MFM3) MFM3 = NEAREST(MFM4,MFM3) CALL FM_ST2M('-0.99',MFM5) CALL FM_ULP(MFM5,MFM6) CALL FM_EQ(MFM6,MFM5) CALL FM_SUB(MFM4,MFM5,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 655 MIM3 = NINT(MFM1) CALL FM_NINT(MFM1,MFM4) CALL IM_FM2I(MFM4,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 656 MIM3 = NINT(MIM1) CALL IM_EQ(MIM1,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 657 MIM3 = NINT(MZM1) CALL ZM_NINT(MZM1,MZM4) CALL ZM_REAL(MZM4,MFM4) CALL IM_FM2I(MFM4,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 658 J = PRECISION(MFM1) IF (J /= INT(LOG10(REAL(MBASE))*(NDIG-1) + 1)) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 659 J = PRECISION(MZM1) IF (J /= INT(LOG10(REAL(MBASE))*(NDIG-1) + 1)) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 660 J = RADIX(MFM1) IF (J /= INT(MBASE)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 661 J = RADIX(MIM1) IF (J /= INT(MBASE)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 662 J = RADIX(MZM1) IF (J /= INT(MBASE)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 663 J = RANGE(MFM1) IF (J /= INT(MXEXP*LOG10(REAL(MBASE)))) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 664 J = RANGE(MIM1) IF (J /= INT(NDIGMX*LOG10(REAL(MBASE)))) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 665 J = RANGE(MZM1) IF (J /= INT(MXEXP*LOG10(REAL(MBASE)))) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 666 MFM3 = REAL(MFM1) CALL FM_EQ(MFM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 667 MFM3 = REAL(MIM1) CALL IM_I2FM(MIM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 668 MFM3 = REAL(MZM1) CALL ZM_REAL(MZM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 669 MFM3 = RRSPACING(MFM1) CALL FM_ABS(MFM1,MFM4) MFM4%MFM(1) = NDIG IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) END SUBROUTINE TEST39 SUBROUTINE TEST40(NCASE,NERROR,KLOG) ! Test functions SCALE, ..., TINY. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NERROR,NCASE WRITE (KW,"(/"// & "' Testing the derived type SCALE, ..., TINY interfaces.')") NCASE = 670 CALL FM_ST2M('0.7654',MFM4) MFM3 = SCALE(MFM4,1) CALL FM_MPYI(MFM4,INT(MBASE),MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 671 CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4) MZM3 = SCALE(MZM4,-2) CALL ZM_DIVI(MZM4,INT(MBASE),MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIVI(MZM4,INT(MBASE),MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 672 CALL FM_ST2M('0.7654',MFM4) MFM3 = SETEXPONENT(MFM4,1) CALL FM_MPYI(MFM4,INT(MBASE),MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 673 CALL FM_ST2M('0.7654',MFM4) MFM3 = SIGN(MFM4,MFM2) CALL FM_SIGN(MFM4,MFM2,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 674 CALL IM_ST2M('231',MIM4) MIM3 = SIGN(MIM4,MIM2) CALL IM_SIGN(MIM4,MIM2,MIM5) CALL IM_EQ(MIM5,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 675 CALL FM_ST2M('0.7654',MFM4) MFM3 = SIN(MFM4) CALL FM_SIN(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 676 CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4) MZM3 = SIN(MZM4) CALL ZM_SIN(MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 677 CALL FM_ST2M('0.7654',MFM4) MFM3 = SINH(MFM4) CALL FM_SINH(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 678 CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4) MZM3 = SINH(MZM4) CALL ZM_SINH(MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 679 CALL FM_ST2M('-0.7654',MFM4) MFM3 = SPACING(MFM4) CALL FM_ULP(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 680 CALL FM_ST2M('0.7654',MFM4) MFM3 = SQRT(MFM4) CALL FM_SQRT(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 681 CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4) MZM3 = SQRT(MZM4) CALL ZM_SQRT(MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 682 CALL FM_ST2M('0.7654',MFM4) MFM3 = TAN(MFM4) CALL FM_TAN(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 683 CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4) MZM3 = TAN(MZM4) CALL ZM_TAN(MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 684 CALL FM_ST2M('0.7654',MFM4) MFM3 = TANH(MFM4) CALL FM_TANH(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 685 CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4) MZM3 = TANH(MZM4) CALL ZM_TANH(MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 686 CALL FM_BIG(MFM4) CALL FM_I2M(1,MFM3) CALL FM_DIV(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = TINY(MFM1) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 687 MIM3 = TINY(MIM1) CALL IM_I2M(1,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 688 CALL FM_BIG(MFM4) CALL FM_I2M(1,MFM3) CALL FM_DIV(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL ZM_CMPX(MFM4,MFM4,MZM4) MZM3 = TINY(MZM1) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) END SUBROUTINE TEST40 SUBROUTINE TEST41(NCASE,NERROR,KLOG) ! Test functions TO_FM, TO_IM, TO_ZM, ..., TO_DPZ. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NERROR,NCASE LOGICAL FM_COMP WRITE (KW,"(/"// & "' Testing the derived type TO_FM, ..., TO_DPZ interfaces.')") RSMALL = EPSILON(1.0)*100.0 DSMALL = EPSILON(1.0D0)*100.0 NCASE = 689 MFM3 = TO_FM(123) CALL FM_I2M(123,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 690 MFM3 = TO_FM(123.4) CALL FM_SP2M(123.4,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = RSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 691 MFM3 = TO_FM(123.45D0) CALL FM_DP2M(123.45D0,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = DSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 692 MFM3 = TO_FM(CMPLX(123.4,567.8)) CALL FM_SP2M(123.4,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = RSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 693 MFM3 = TO_FM(CMPLX(123.4D0,567.8D0,KIND(1.0D0))) CALL FM_DP2M(123.4D0,MFM4) CALL FM_SUB(MFM3,MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_DIV(MFM4,MFM3,MFM6) CALL FM_EQ(MFM6,MFM4) CALL FM_ABS(MFM4,MFM6) CALL FM_EQ(MFM6,MFM4) MFM3 = DSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 694 MFM3 = TO_FM(MFM1) CALL FM_EQ(MFM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 695 MFM3 = TO_FM(MIM1) CALL IM_I2FM(MIM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 696 MFM3 = TO_FM(MZM1) CALL ZM_REAL(MZM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 697 MFM3 = TO_FM('-123.654') CALL FM_ST2M('-123.654',MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 698 MIM3 = TO_IM(123) CALL IM_I2M(123,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 699 MIM3 = TO_IM(123.4) CALL FM_SP2M(123.4,MFM4) CALL IM_FM2I(MFM4,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 700 MIM3 = TO_IM(123.45D0) CALL FM_DP2M(123.45D0,MFM4) CALL IM_FM2I(MFM4,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 701 MIM3 = TO_IM(CMPLX(123.4,567.8)) CALL FM_SP2M(123.4,MFM4) CALL IM_FM2I(MFM4,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 702 MIM3 = TO_IM(CMPLX(123.4D0,567.8D0,KIND(1.0D0))) CALL FM_DP2M(123.4D0,MFM4) CALL IM_FM2I(MFM4,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 703 MIM3 = TO_IM(MFM1) CALL FM_EQ(MFM1,MFM4) CALL IM_FM2I(MFM4,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 704 MIM3 = TO_IM(MIM1) CALL IM_I2FM(MIM1,MFM4) CALL IM_FM2I(MFM4,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 705 MIM3 = TO_IM(MZM1) CALL ZM_REAL(MZM1,MFM4) CALL IM_FM2I(MFM4,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 706 MIM3 = TO_IM('-123654') CALL IM_ST2M('-123654',MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 707 MZM3 = TO_ZM(123) CALL ZM_I2M(123,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 708 MZM3 = TO_ZM(123.4) CALL FM_SP2M(123.4,MFM4) CALL FM_I2M(0,MFM5) CALL ZM_CMPX(MFM4,MFM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) MFM3 = RSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 709 MZM3 = TO_ZM(123.45D0) CALL FM_DP2M(123.45D0,MFM4) CALL FM_I2M(0,MFM5) CALL ZM_CMPX(MFM4,MFM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) MFM3 = DSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 710 MZM3 = TO_ZM(CMPLX(123.4,567.8)) CALL FM_SP2M(123.4,MFM4) CALL FM_SP2M(567.8,MFM5) CALL ZM_CMPX(MFM4,MFM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) MFM3 = RSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 711 MZM3 = TO_ZM(CMPLX(123.4D0,567.8D0,KIND(1.0D0))) CALL FM_DP2M(123.4D0,MFM4) CALL FM_DP2M(567.8D0,MFM5) CALL ZM_CMPX(MFM4,MFM5,MZM4) CALL ZM_SUB(MZM3,MZM4,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_DIV(MZM4,MZM3,MZM5) CALL ZM_EQ(MZM5,MZM4) CALL ZM_ABS(MZM4,MFM4) MFM3 = DSMALL IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 712 MZM3 = TO_ZM(MFM1) CALL FM_EQ(MFM1,MFM4) CALL FM_I2M(0,MFM5) CALL ZM_CMPX(MFM4,MFM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 713 MZM3 = TO_ZM(MIM1) CALL IM_I2FM(MIM1,MFM4) CALL FM_I2M(0,MFM5) CALL ZM_CMPX(MFM4,MFM5,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 714 MZM3 = TO_ZM(MZM1) CALL ZM_EQ(MZM1,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 715 MZM3 = TO_ZM('-123.654 + 98.7 i') CALL ZM_ST2M('-123.654 + 98.7 i',MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 716 CALL FM_M2I(MFM1,J3) IF (TO_INT(MFM1) /= J3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 717 CALL IM_M2I(MIM1,J3) IF (TO_INT(MIM1) /= J3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 718 CALL ZM_M2I(MZM1,J3) IF (TO_INT(MZM1) /= J3) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 719 CALL FM_M2SP(MFM1,R3) IF (ABS((TO_SP(MFM1)-R3)/R3) > RSMALL) THEN CALL PRTERR(KW,KLOG,NCASE,NERROR) ENDIF NCASE = 720 CALL IM_M2DP(MIM1,D3) R3 = D3 IF (ABS((TO_SP(MIM1)-R3)/R3) > RSMALL) THEN CALL PRTERR(KW,KLOG,NCASE,NERROR) ENDIF NCASE = 721 CALL ZM_REAL(MZM1,MFM4) CALL FM_M2SP(MFM4,R3) IF (ABS((TO_SP(MZM1)-R3)/R3) > RSMALL) THEN CALL PRTERR(KW,KLOG,NCASE,NERROR) ENDIF NCASE = 722 CALL FM_M2DP(MFM1,D3) IF (ABS((TO_DP(MFM1)-D3)/D3) > DSMALL) THEN CALL PRTERR(KW,KLOG,NCASE,NERROR) ENDIF NCASE = 723 CALL IM_M2DP(MIM1,D3) IF (ABS((TO_DP(MIM1)-D3)/D3) > DSMALL) THEN CALL PRTERR(KW,KLOG,NCASE,NERROR) ENDIF NCASE = 724 CALL ZM_REAL(MZM1,MFM4) CALL FM_M2DP(MFM4,D3) IF (ABS((TO_DP(MZM1)-D3)/D3) > DSMALL) THEN CALL PRTERR(KW,KLOG,NCASE,NERROR) ENDIF NCASE = 725 CALL FM_M2SP(MFM1,R3) C3 = R3 IF (ABS((TO_SPZ(MFM1)-C3)/C3) > RSMALL) THEN CALL PRTERR(KW,KLOG,NCASE,NERROR) ENDIF NCASE = 726 CALL IM_M2DP(MIM1,D3) C3 = D3 IF (ABS((TO_SPZ(MIM1)-C3)/C3) > RSMALL) THEN CALL PRTERR(KW,KLOG,NCASE,NERROR) ENDIF NCASE = 727 CALL ZM_M2Z(MZM1,C3) IF (ABS((TO_SPZ(MZM1)-C3)/C3) > RSMALL) THEN CALL PRTERR(KW,KLOG,NCASE,NERROR) ENDIF NCASE = 728 CALL FM_M2DP(MFM1,D3) CD3 = D3 IF (ABS((TO_DPZ(MFM1)-CD3)/CD3) > DSMALL) THEN CALL PRTERR(KW,KLOG,NCASE,NERROR) ENDIF NCASE = 729 CALL IM_M2DP(MIM1,D3) CD3 = D3 IF (ABS((TO_DPZ(MIM1)-CD3)/CD3) > DSMALL) THEN CALL PRTERR(KW,KLOG,NCASE,NERROR) ENDIF NCASE = 730 CALL ZM_REAL(MZM1,MFM4) CALL FM_M2DP(MFM4,D3) CALL ZM_IMAG(MZM1,MFM4) CALL FM_M2DP(MFM4,D4) CD3 = CMPLX( D3 , D4 , KIND(0.0D0) ) IF (ABS((TO_DPZ(MZM1)-CD3)/CD3) > DSMALL) THEN CALL PRTERR(KW,KLOG,NCASE,NERROR) ENDIF END SUBROUTINE TEST41 SUBROUTINE TEST42(NCASE,NERROR,KLOG) ! Test the derived-type interface routines that are not ! used elsewhere in this program. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE CHARACTER(80) :: STRING INTEGER KLOG,NERROR,NCASE WRITE (KW,"(/"// & "' Testing the derived type ADDI, ..., Z2M interfaces.')") RSMALL = EPSILON(1.0)*100.0 DSMALL = EPSILON(1.0D0)*100.0 MSMALL = EPSILON(TO_FM(1))*10000.0 NCASE = 731 MFM3 = MFM1 + 123 MFM4 = MFM1 CALL FM_ADDI(MFM4,123) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 732 CALL FM_CHSH(MFM1,MFM4,MFM3) MFM3 = COSH(MFM1) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 733 CALL FM_CHSH(MFM1,MFM3,MFM4) MFM3 = SINH(MFM1) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 734 CALL FM_CSSN(MFM1,MFM4,MFM3) MFM3 = COS(MFM1) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 735 CALL FM_CSSN(MFM1,MFM3,MFM4) MFM3 = SIN(MFM1) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 736 MFM3 = MFM1 / 123 CALL FM_DIVI(MFM1,123,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 737 MFM3 = 123.45D0 CALL FM_DPM(123.45D0,MFM4) IF (ABS((MFM3-MFM4)/MFM4) > DSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 738 CALL FM_FORM('F70.56',MFM1,STRING) CALL FM_ST2M(STRING(1:70),MFM4) IF (ABS((MFM1-MFM4)/MFM4) > MSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 739 STRING = FM_FORMAT('F70.56',MFM1) CALL FM_ST2M(STRING(1:70),MFM4) IF (ABS((MFM1-MFM4)/MFM4) > MSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 740 MFM3 = MFM1 ** 123 CALL FM_IPWR(MFM1,123,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 741 MFM3 = LOG(TO_FM(123)) CALL FM_LNI(123,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 742 D4 = MFM1 CALL FM_M2DP(MFM1,D5) IF (ABS((D4-D5)/D4) > DSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 743 J4 = MFM1 CALL FM_M2I(MFM1,J5) IF (J4 /= J5) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 744 R4 = MFM1 CALL FM_M2SP(MFM1,R5) IF (ABS((R4-R5)/R4) > RSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 745 MFM3 = 2.67 CALL FM_MOD(MFM1,MFM3,MFM4) MFM3 = MOD(MFM1,MFM3) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 746 CALL FM_PI(MFM4) MFM3 = 4*ATAN(TO_FM(1)) IF (ABS((MFM3-MFM4)/MFM4) > MSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 747 MFM3 = MFM1 ** (TO_FM(1)/TO_FM(3)) CALL FM_RPWR(MFM1,1,3,MFM4) IF (ABS((MFM3-MFM4)/MFM4) > MSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 748 CALL FM_SQR(MFM1,MFM4) MFM3 = MFM1*MFM1 IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 749 MIM3 = MIM1 / 13 CALL IM_DIVI(MIM1,13,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 750 MIM3 = 13 CALL IM_DIVR(MIM1,MIM3,MIM5,MIM4) MIM3 = MOD(MIM1,MIM3) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 751 MIM3 = 13 CALL IM_DIVR(MIM1,MIM3,MIM5,MIM4) CALL IM_EQ(MIM5,MIM3) MIM4 = MIM1 / 13 IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 752 MIM3 = MIM1 / 13 CALL IM_DVIR(MIM1,13,MIM4,J5) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 753 J4 = MOD(MIM1,TO_IM(13)) CALL IM_DVIR(MIM1,13,MIM4,J5) IF (J4 /= J5) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 754 CALL IM_FORM('I70',MIM1,STRING) CALL IM_ST2M(STRING(1:70),MIM4) IF (MIM1 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 755 STRING = IM_FORMAT('I70',MIM1) CALL IM_ST2M(STRING(1:70),MIM4) IF (MIM1 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 756 MIM3 = 40833 MIM4 = 16042 CALL IM_GCD(MIM3,MIM4,MIM5) CALL IM_EQ(MIM5,MIM4) IF (MIM4 /= 13) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 757 MIM3 = 40833 MIM4 = 16042 MIM4 = GCD(MIM3,MIM4) IF (MIM4 /= 13) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 758 D4 = MIM1 CALL IM_M2DP(MIM1,D5) IF (ABS((D4-D5)/D4) > DSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 759 J4 = MIM1 CALL IM_M2I(MIM1,J5) IF (J4 /= J5) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 760 MIM3 = 6 CALL IM_MOD(MIM1,MIM3,MIM4) MIM3 = MOD(MIM1,MIM3) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 761 MIM3 = MIM1 * 123 CALL IM_MPYI(MIM1,123,MIM4) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 762 MIM2 = 3141 MIM3 = 133 CALL IM_MPYM(MIM1,MIM2,MIM3,MIM4) MIM3 = MOD(MIM1*MIM2,MIM3) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 763 MIM2 = 3141 MIM3 = 133 MIM4 = MULTIPLY_MOD(MIM1,MIM2,MIM3) MIM3 = MOD(MIM1*MIM2,MIM3) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 764 MIM2 = 31 MIM3 = 147 CALL IM_PMOD(MIM1,MIM2,MIM3,MIM4) MIM3 = MOD(MIM1**MIM2,MIM3) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 765 MIM2 = 31 MIM3 = 147 MIM4 = POWER_MOD(MIM1,MIM2,MIM3) MIM3 = MOD(MIM1**MIM2,MIM3) IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 766 CALL IM_SQR(MIM1,MIM4) MIM3 = MIM1*MIM1 IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 767 MZM3 = MZM1 + 123 MZM4 = MZM1 CALL ZM_ADDI(MZM4,123) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 768 MFM3 = ATAN2(AIMAG(MZM1),REAL(MZM1)) CALL ZM_ARG(MZM1,MFM4) IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 769 CALL ZM_CHSH(MZM1,MZM4,MZM3) MZM3 = COSH(MZM1) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 770 CALL ZM_CHSH(MZM1,MZM3,MZM4) MZM3 = SINH(MZM1) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 771 CALL ZM_CSSN(MZM1,MZM4,MZM3) MZM3 = COS(MZM1) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 772 CALL ZM_CSSN(MZM1,MZM3,MZM4) MZM3 = SIN(MZM1) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 773 CALL ZM_FORM('F35.26','F35.26',MZM1,STRING) CALL ZM_ST2M(STRING(1:75),MZM4) IF (ABS((MZM1-MZM4)/MZM4) > MSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 774 STRING = ZM_FORMAT('F35.26','F35.26',MZM1) CALL ZM_ST2M(STRING(1:75),MZM4) IF (ABS((MZM1-MZM4)/MZM4) > MSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 775 MZM3 = TO_ZM('123-456i') CALL ZM_2I2M(123,-456,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 776 MZM3 = MZM1 ** 123 CALL ZM_IPWR(MZM1,123,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 777 J4 = MZM1 CALL ZM_M2I(MZM1,J5) IF (J4 /= J5) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 778 C4 = MZM1 CALL ZM_M2Z(MZM1,C5) IF (ABS((C4-C5)/C4) > RSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 779 MZM3 = MZM1 * 123 CALL ZM_MPYI(MZM1,123,MZM4) IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 780 MZM3 = MZM1 ** (TO_ZM(1)/TO_ZM(3)) CALL ZM_RPWR(MZM1,1,3,MZM4) IF (ABS((MZM3-MZM4)/MZM4) > MSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 781 CALL ZM_SQR(MZM1,MZM4) MZM3 = MZM1*MZM1 IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR) NCASE = 782 MZM3 = C2 CALL ZM_Z2M(C2,MZM4) IF (ABS((MZM3-MZM4)/MZM3) > RSMALL) & CALL PRTERR(KW,KLOG,NCASE,NERROR) END SUBROUTINE TEST42 SUBROUTINE TEST43(NCASE,NERROR,KLOG) ! Test Bernoulli numbers, Pochhammer's function, Euler's constant. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NCASE,NERROR,NDGSAV WRITE (KW,"(/' Testing Bernoulli, Pochhammer, Euler.')") NCASE = 783 M_A = 1 CALL FM_BERN(10,M_A,M_C) M_D = TO_FM('7.5757575757575757575757575757575757575757575757575758M-2') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 784 M_A = 1 CALL FM_BERN(0,M_A,M_C) M_D = TO_FM('1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 785 M_A = 1 CALL FM_BERN(1,M_A,M_C) M_D = TO_FM('-0.5') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 786 M_A = 1 CALL FM_BERN(41,M_A,M_C) M_D = TO_FM('0') M_D = ABS(M_C - M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 787 M_A = 0 CALL FM_BERN(52,M_A,M_C) M_D = TO_FM('0') M_D = ABS(M_C - M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 788 M_A = TO_FM('.7699115044247787610619469026548672566371681415929204') CALL FM_BERN(102,M_A,M_C) M_D = TO_FM('5.7022917356035929245914353639470138260075545712953255M+80') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 789 M_A = TO_FM('.7699115044247787610619469026548672566371681415929204') CALL FM_BERN(76,M_A,M_C) M_D = TO_FM('-6.3274121765674850311763600458139008604123253720098077M+50') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 790 M_A = TO_FM('.7699115044247787610619469026548672566371681415929204') M_C = BERNOULLI(76)*M_A M_D = TO_FM('-6.3274121765674850311763600458139008604123253720098077M+50') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 791 M_A = TO_FM('769.9115044247787610619469026548672566371681415929204') CALL FM_POCH(M_A,10,M_C) M_D = TO_FM('7.7568981408767238023000514593534249181767332686451635M+28') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 792 M_A = TO_FM('7699.115044247787610619469026548672566371681415929204') CALL FM_POCH(M_A,2222,M_C) M_D = TO_FM('1.3306321985792900130409652455318897459921360351317942M+8763') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 793 M_A = TO_FM('-7') CALL FM_POCH(M_A,12,M_C) M_D = TO_FM('0') M_D = ABS(M_C - M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 794 M_A = TO_FM('7.7568981408767238023000514593534249181767332686451635M+281') CALL FM_POCH(M_A,6,M_C) M_D = TO_FM('2.1783543710019819738631136312604490177244818356538937M+1691') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 795 M_A = TO_FM('7.7568981408767238023000514593534249181767332686451635M-281') CALL FM_POCH(M_A,8,M_C) M_D = TO_FM('3.9094766630018687963592259355141261587610735673971624M-277') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 796 M_A = TO_FM('7.7568981408767238023000514593534249181767332686451635M-281') CALL FM_POCH(M_A,1,M_C) M_D = TO_FM('7.7568981408767238023000514593534249181767332686451635M-281') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 797 M_A = TO_FM('7.7568981408767238023000514593534249181767332686451635M-281') CALL FM_POCH(M_A,0,M_C) M_D = TO_FM('1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 798 M_A = TO_FM('0') CALL FM_POCH(M_A,8,M_C) M_D = TO_FM('0') M_D = ABS(M_C - M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 799 M_A = TO_FM('769.9115044247787610619469026548672566371681415929204') M_C = POCHHAMMER(M_A,10) M_D = TO_FM('7.7568981408767238023000514593534249181767332686451635M+28') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 800 CALL FM_EULR(M_C) M_D = TO_FM('.5772156649015328606065120900824024310421593359399236') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' EULR ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 801 NDGSAV = NDIG NDIG = MIN(NDIGMX,INT(1785*DLOGTN/DLOGMB)+2) CALL FM_EULR(M_C) M_D = TO_FM( & ' .5772156649015328606065120900824024310421593359399235988057672348848677267'// & '776646709369470632917467495146314472498070824809605040144865428362241739976'// & '449235362535003337429373377376739427925952582470949160087352039481656708532'// & '331517766115286211995015079847937450857057400299213547861466940296043254215'// & '190587755352673313992540129674205137541395491116851028079842348775872050384'// & '310939973613725530608893312676001724795378367592713515772261027349291394079'// & '843010341777177808815495706610750101619166334015227893586796549725203621287'// & '922655595366962817638879272680132431010476505963703947394957638906572967929'// & '601009015125195950922243501409349871228247949747195646976318506676129063811'// & '051824197444867836380861749455169892792301877391072945781554316005002182844'// & '096053772434203285478367015177394398700302370339518328690001558193988042707'// & '411542227819716523011073565833967348717650491941812300040654693142999297779'// & '569303100503086303418569803231083691640025892970890985486825777364288253954'// & '925873629596133298574739302373438847070370284412920166417850248733379080562'// & '754998434590761643167103146710722370021810745044418664759134803669025532458'// & '625442225345181387912434573501361297782278288148945909863846006293169471887'// & '149587525492366493520473243641097268276160877595088095126208404544477992299'// & '157248292516251278427659657083214610298214617951957959095922704208989627971'// & '255363217948873764210660607065982561990102880756125199137511678217643619057'// & '058440783573501580056077457934213144988500786415171615194565706170432450750'// & '081687052307890937046143066848179164968425491504967243121837838753564894950'// & '868454102340601622508515583867234944187880440940770106883795111307872023426'// & '395226920971608856908382511378712836820491178925944784861991185293910293099'// & '059255266917274468920443869711147174571574573203935209122316085086828') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= MAX(TO_FM('1.0E-1785'),10*EPSILON(M_C)))) THEN CALL ERRPRT_FM(' EULR ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NDIG = NDGSAV RETURN END SUBROUTINE TEST43 SUBROUTINE TEST44(NCASE,NERROR,KLOG) ! Test Gamma, Factorial, Log(Gamma), Beta, Binomial. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing Gamma, Factorial, Log(Gamma), Beta, Binomial.')") NCASE = 802 M_A = 19 CALL FM_GAM(M_A,M_C) M_D = TO_FM('6.402373705728M+15') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 803 M_A = TO_FM('.7699115044247787610619469026548672566371681415929204') CALL FM_GAM(M_A,M_C) M_D = TO_FM('1.1998023858495967876496039855917100290498970370440326') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 804 M_A = TO_FM('.7699115044247787610619469026548672566371681415929204') CALL FM_GAM(M_A,M_C) M_D = TO_FM('1.1998023858495967876496039855917100290498970370440326') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 805 M_A = TO_FM('5.7699115044247787610619469026548672566371681415929204') CALL FM_GAM(M_A,M_C) M_D = TO_FM('8.1434691207877806133071511233406796488474685081500979M+1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 806 M_A = TO_FM('7.7568981408767238023000514593534249181767332686451635M-281') CALL FM_GAM(M_A,M_C) M_D = TO_FM('1.2891751081921193691625844770542239587773115818085396M+280') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 807 M_A = TO_FM('2') CALL FM_GAM(M_A,M_C) M_D = TO_FM('1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 808 M_A = TO_FM('5.7699115044247787610619469026548672566371681415929204') M_C = GAMMA(M_A) M_D = TO_FM('8.1434691207877806133071511233406796488474685081500979M+1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 809 M_A = 33 CALL FM_FACT(M_A,M_C) M_D = TO_FM('8.68331761881188649551819440128M+36') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' FACT ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 810 M_A = TO_FM('769.9115044247787610619469026548672566371681415929204') CALL FM_FACT(M_A,M_C) M_D = TO_FM('5.9982590033571347622193071279165294725603013413394492M+1889') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' FACT ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 811 M_A = TO_FM('769.9115044247787610619469026548672566371681415929204') M_C = FACTORIAL(M_A) M_D = TO_FM('5.9982590033571347622193071279165294725603013413394492M+1889') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' FACT ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 812 M_A = TO_FM('1.0M-222') CALL FM_LNGM(M_A,M_C) M_D = TO_FM('5.1117389064467814185199410293992885408744453047558760M+2') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' LNGM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 813 M_A = TO_FM('2') CALL FM_LNGM(M_A,M_C) M_D = TO_FM('0') M_D = ABS(M_C - M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' LNGM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 814 M_A = TO_FM('33') CALL FM_LNGM(M_A,M_C) M_D = TO_FM('8.1557959456115037178502968666011206687099284403417368M+1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' LNGM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 815 M_A = TO_FM('2.00000000000000000001') CALL FM_LNGM(M_A,M_C) M_D = TO_FM('4.2278433509846713939671258025183870114019600466320121M-21') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' LNGM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 816 M_C = LOG_GAMMA(TO_FM('33')) M_D = TO_FM('8.1557959456115037178502968666011206687099284403417368M+1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' LNGM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 817 M_A = TO_FM('2.0706137739520290320140007735608464643737932737070189M-223') M_B = TO_FM('.78') CALL FM_BETA(M_A,M_B,M_C) M_D = TO_FM('4.8294858876137637017880452468052846823385248996130407M+222') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 818 M_A = TO_FM('.78') M_B = TO_FM('2.0706137739520290320140007735608464643737932737070189M-223') CALL FM_BETA(M_A,M_B,M_C) M_D = TO_FM('4.8294858876137637017880452468052846823385248996130407M+222') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 819 M_A = TO_FM('-4.5') M_B = TO_FM('4.5') CALL FM_BETA(M_A,M_B,M_C) M_D = TO_FM('0') M_D = ABS(M_C - M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 820 M_A = TO_FM('-5.5') M_B = TO_FM('4.5') CALL FM_BETA(M_A,M_B,M_C) M_D = TO_FM('0') M_D = ABS(M_C - M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 821 M_A = TO_FM('10') M_B = TO_FM('4') CALL FM_BETA(M_A,M_B,M_C) M_D = TO_FM('3.4965034965034965034965034965034965034965034965034965M-4') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 822 M_A = TO_FM('1.0M+1234') M_B = TO_FM('2.2') CALL FM_BETA(M_A,M_B,M_C) M_D = TO_FM('1.7462392672319547876554292922652110015806932440139209M-2715') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 823 M_A = TO_FM('10') M_B = TO_FM('5.3') CALL FM_BETA(M_A,M_B,M_C) M_D = TO_FM('7.0836036771097107530120640698518155187687458162734679M-5') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 824 M_A = TO_FM('10.3') M_B = TO_FM('5') CALL FM_BETA(M_A,M_B,M_C) M_D = TO_FM('8.8146035423244390793072072569173028531206477712519934M-5') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 825 M_A = TO_FM('10.3') M_B = TO_FM('5') M_C = BETA(M_A,M_B) M_D = TO_FM('8.8146035423244390793072072569173028531206477712519934M-5') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 826 M_A = TO_FM('12.5') M_B = TO_FM('0') CALL FM_COMB(M_A,M_B,M_C) M_D = TO_FM('1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 827 M_A = TO_FM('5') M_B = TO_FM('-2') CALL FM_COMB(M_A,M_B,M_C) M_D = TO_FM('0') M_D = ABS(M_C - M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 828 M_A = TO_FM('12.5') M_B = TO_FM('12.5') CALL FM_COMB(M_A,M_B,M_C) M_D = TO_FM('1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 829 M_A = TO_FM('-4.5') M_B = TO_FM('4.5') CALL FM_COMB(M_A,M_B,M_C) M_D = TO_FM('0') M_D = ABS(M_C - M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 830 M_A = TO_FM('-4.5') M_B = TO_FM('4.5') CALL FM_COMB(M_A,M_B,M_C) M_D = TO_FM('0') M_D = ABS(M_C - M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 831 M_A = TO_FM('-10') M_B = TO_FM('3') CALL FM_COMB(M_A,M_B,M_C) M_D = TO_FM('-220') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 832 M_A = TO_FM('52') M_B = TO_FM('5') CALL FM_COMB(M_A,M_B,M_C) M_D = TO_FM('2.59896M+6') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 833 M_A = TO_FM('1.0M+1234') M_B = TO_FM('7') CALL FM_COMB(M_A,M_B,M_C) M_D = TO_FM('1.9841269841269841269841269841269841269841269841269841M+8634') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 834 M_A = TO_FM('1.0M+123') M_B = TO_FM('2.2') CALL FM_COMB(M_A,M_B,M_C) M_D = TO_FM('1.6423797032130683531106846289429264567307029528308099M+270') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 835 M_A = TO_FM('1.0M-100') M_B = TO_FM('4') CALL FM_COMB(M_A,M_B,M_C) M_D = TO_FM('-2.5M-101') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 836 M_A = TO_FM('1.0M+123') M_B = TO_FM('2.2') M_C = BINOMIAL(M_A,M_B) M_D = TO_FM('1.6423797032130683531106846289429264567307029528308099M+270') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST44 SUBROUTINE TEST45(NCASE,NERROR,KLOG) ! Test Incomplete Gamma, Incomplete Beta. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing Incomplete Gamma, Incomplete Beta.')") NCASE = 837 M_A = TO_FM('2.0706137739520290320140007735608464643737932737070189M-145') M_B = TO_FM('.34') CALL FM_IGM1(M_A,M_B,M_C) M_D = TO_FM('4.8294858876137637017880452468052846823385248996130407M+144') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 838 M_A = TO_FM('1.0E-50') M_B = TO_FM('1.0E+555') CALL FM_IGM1(M_A,M_B,M_C) M_D = TO_FM('9.9999999999999999999999999999999999999999999999999423M+49') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 839 M_A = TO_FM('1.2') M_B = TO_FM('2.3') CALL FM_IGM1(M_A,M_B,M_C) M_D = TO_FM('7.9163089830797686672658085698101181778608009481363580M-1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 840 M_A = TO_FM('23.4') M_B = TO_FM('456.7') CALL FM_IGM1(M_A,M_B,M_C) M_D = TO_FM('3.9191215305400046110416169991395759293572844563673750M+21') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 841 M_A = TO_FM('1.2') M_B = TO_FM('0') CALL FM_IGM1(M_A,M_B,M_C) M_D = TO_FM('0') M_D = ABS(M_C - M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 842 M_A = TO_FM('-1234.5') M_B = TO_FM('3.4') CALL FM_IGM1(M_A,M_B,M_C) M_D = TO_FM('-2.0892439131810030556730824779643382797767198269736235M-661') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 843 M_A = TO_FM('10.3') M_B = TO_FM('230.7') CALL FM_IGM1(M_A,M_B,M_C) M_D = TO_FM('7.1643068906237524454762965471616445342244699109269471M+5') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 844 M_A = TO_FM('1.2') M_B = TO_FM('2.3') M_C = INCOMPLETE_GAMMA1(M_A,M_B) M_D = TO_FM('7.9163089830797686672658085698101181778608009481363580M-1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 845 M_A = TO_FM('0') M_B = TO_FM('4.5') CALL FM_IGM2(M_A,M_B,M_C) M_D = TO_FM('2.0734007547146144328855938695797884889319725701443004M-3') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 846 M_A = TO_FM('4.5') M_B = TO_FM('0') CALL FM_IGM2(M_A,M_B,M_C) M_D = TO_FM('1.1631728396567448929144224109426265262108918305803166M+1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 847 M_A = TO_FM('1.2') M_B = TO_FM('2.3') CALL FM_IGM2(M_A,M_B,M_C) M_D = TO_FM('1.2653784409178374391437079820481858290074190484504480M-1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 848 M_A = TO_FM('3.4') M_B = TO_FM('456.7') CALL FM_IGM2(M_A,M_B,M_C) M_D = TO_FM('1.1043526800164195407100289367720949121507981651704628M-192') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 849 M_A = TO_FM('1.0E-30') M_B = TO_FM('40.7') CALL FM_IGM2(M_A,M_B,M_C) M_D = TO_FM('5.0619447546123889551107110735110897294460083487536391M-20') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 850 M_A = TO_FM('-8000.3') M_B = TO_FM('1.0e-10') CALL FM_IGM2(M_A,M_B,M_C) M_D = TO_FM('1.2499531266327356460522174653022492899665091451890036M+79999') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 851 M_A = TO_FM('1') M_B = TO_FM('-10.7') CALL FM_IGM2(M_A,M_B,M_C) M_D = TO_FM('4.4355855130297866938628363428602120081387560278336788M+4') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 852 M_A = TO_FM('1.2') M_B = TO_FM('2.3') M_C = INCOMPLETE_GAMMA2(M_A,M_B) M_D = TO_FM('1.2653784409178374391437079820481858290074190484504480M-1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 853 M_A = TO_FM('0.1') M_B = TO_FM('23.4') M_C = TO_FM('34.5') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('5.8731980918960730463350151650813268739874201571164800M-27') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 854 M_A = TO_FM('8.115640517330775M-1') M_B = TO_FM('2.00853601446773') M_C = TO_FM('1.59735792202923') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('2.0112520048150164306467955877563719782378767062440103M-1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 855 M_A = TO_FM('9.01737835258975M-1') M_B = TO_FM('2.00853601446773') M_C = TO_FM('1.59735792202923') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('2.2512248738228585976753517954889151150428002974819213M-1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 856 M_A = TO_FM('9.6097615596216720E-01') M_B = TO_FM('1.970425178583792') M_C = TO_FM('5.5680052333367') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('2.8619456987740165364092968281459448023932520843535423M-2') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 857 M_A = TO_FM('4.764360371097952E-01') M_B = TO_FM('1.161514683661584E+01') M_C = TO_FM('2.937801562768354E-01') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('2.3604503996731113868791517339909092506365724801689105M-5') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 858 M_A = TO_FM('0.9') M_B = TO_FM('23.4') M_C = TO_FM('34.5') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('7.3148127865937299821246829407023943740949130742928268M-18') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 859 M_A = TO_FM('9.99496253868099M-1') M_B = TO_FM('2.47067979368109M+6') M_C = TO_FM('6.09475681774953M-100') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('1.7681753021411259894614747665450637683755190050365931M-544') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 860 M_A = TO_FM('6.213433771653724M-1') M_B = TO_FM('8.854622686031200M-1') M_C = TO_FM('5.00000854049816M-121') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('1.1281271573737080091147788530326864610276172049831497M+0') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 861 M_A = TO_FM('5.304391676698501M-15') M_B = TO_FM('4.870186358377400M+2') M_C = TO_FM('4.999955247889730M-98') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('8.7892314482956847896604128106803662527479433068750459M-6956') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 862 M_A = TO_FM('1.882803169800314M-7') M_B = TO_FM('1.591547060066600M-169') M_C = TO_FM('3.521822614438970M+6') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('6.2831946669434576663925763649227277100409122269443137M+168') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 863 M_A = TO_FM('.9999999999999') M_B = TO_FM('8.591098092677430M+2') M_C = TO_FM('1.863210949748253M+1') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('3.9062929191651064065641350979581425238442928803700306M-40') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 864 M_A = TO_FM('2.531772074701081M-99') M_B = TO_FM('3.547571261801072M+2') M_C = TO_FM('1.974896958876250M+6') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('4.0957237103166196693191012056689839835950377114705018M-34981') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 865 M_A = TO_FM('.99999999999999') M_B = TO_FM('1.0E-123') M_C = TO_FM('1.0E-134') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('1.0M+123') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 866 M_A = TO_FM('1') M_B = TO_FM('2.65') M_C = TO_FM('4.88') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('1.5020204575152306127604878970920601604169827852591720M-2') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 867 M_A = TO_FM('0') M_B = TO_FM('2.65') M_C = TO_FM('4.88') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('0') M_D = ABS(M_C - M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 868 M_A = TO_FM('.998') M_B = TO_FM('759.6') M_C = TO_FM('4.95e-57') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('9.7133692099062434492386763673434080317019087637060970M-2') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 869 M_A = TO_FM('4.764360371097952E-01') M_B = TO_FM('1.161514683661584E+01') M_C = TO_FM('2.937801562768354E-01') M_C = INCOMPLETE_BETA(M_A,M_B,M_C) M_D = TO_FM('2.3604503996731113868791517339909092506365724801689105M-5') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST45 SUBROUTINE TEST46(NCASE,NERROR,KLOG) ! Test the Polygamma, Psi functions. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NCASE,NERROR WRITE (KW,"(/' Testing Polygamma, Psi.')") NCASE = 870 M_A = TO_FM('4.5') CALL FM_PGAM(0,M_A,M_C) M_D = TO_FM('1.3888709263595289015114046193821968137592213477205183M+0') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 871 M_A = TO_FM('1.0E-123') CALL FM_PGAM(1,M_A,M_C) M_D = TO_FM('1.0M+246') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 872 M_A = TO_FM('1.0E-123') CALL FM_PGAM(2,M_A,M_C) M_D = TO_FM('-2.0M+369') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 873 M_A = TO_FM('2.0706137739520290320140007735608464643737932737070189M-1') CALL FM_PGAM(1,M_A,M_C) M_D = TO_FM('2.4580954480899934124966756607870377560864828849100481M+1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 874 M_A = TO_FM('2.0706137739520290320140007735608464643737932737070189M-1') CALL FM_PGAM(6,M_A,M_C) M_D = TO_FM('-4.4120531379423056741117517146346730469682094212273241M+7') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 875 M_A = TO_FM('2.0706137739520290320140007735608464643737932737070189M-1') CALL FM_PGAM(23,M_A,M_C) M_D = TO_FM('6.7006365293376930742991440911935017694098601683947073M+38') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 876 M_A = TO_FM('1.0E+123') CALL FM_PGAM(4,M_A,M_C) M_D = TO_FM('-6.0M-492') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 877 M_A = TO_FM('-6.499999840238790109') CALL FM_PGAM(4,M_A,M_C) M_D = TO_FM('1.0135142464863270830609416082237513111216512170936928M-16') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 878 M_C = POLYGAMMA(2,TO_FM('1.0E-123')) M_D = TO_FM('-2.0M+369') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 879 M_A = TO_FM('1.0E-135') CALL FM_PSI(M_A,M_C) M_D = TO_FM('-1.0M+135') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 880 M_A = TO_FM('1.2') CALL FM_PSI(M_A,M_C) M_D = TO_FM('-2.8903989659218829554720796244995210482558827420664281M-1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 881 M_A = TO_FM('-3.4') CALL FM_PSI(M_A,M_C) M_D = TO_FM('2.3844508141180140670320531380285019520468887144980679M+0') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 882 M_A = TO_FM('57') CALL FM_PSI(M_A,M_C) M_D = TO_FM('4.0342536898816977739559850955847848905386809772893269M+0') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 883 M_A = TO_FM('1.0E+56') CALL FM_PSI(M_A,M_C) M_D = TO_FM('1.2894476520766655830500752146232439562566168336321129M+2') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 884 M_A = TO_FM('1.0') CALL FM_PSI(M_A,M_C) M_D = TO_FM('-5.7721566490153286060651209008240243104215933593992360M-1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 885 M_A = TO_FM('1.0E+23456') CALL FM_PSI(M_A,M_C) M_D = TO_FM('5.4009435941268335564326007561076446853491436517276499M+4') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 886 M_A = TO_FM('1.46163214496836234126266') CALL FM_PSI(M_A,M_C) M_D = TO_FM('4.4287869692570149446165609601581442013784186419176534M-25') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 887 M_C = PSI(TO_FM('1.2')) M_D = TO_FM('-2.8903989659218829554720796244995210482558827420664281M-1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST46 SUBROUTINE TEST47(NCASE,NERROR,KLOG) ! Test the different rounding modes. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE INTEGER KLOG,NCASE,NERROR INTEGER SEED(7) WRITE (KW,"(/' Testing the different rounding modes.')") CALL FMSETVAR(' MBASE = 10 ') CALL FMSETVAR(' NDIG = 20 ') M_A = 0 NCASE = 888 CALL FMSETVAR(' KROUND = 1 ') M_C = TO_FM('2')/TO_FM('3') M_D = TO_FM('.66666666666666666667') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 889 CALL FMSETVAR(' KROUND = -1 ') M_C = TO_FM('2')/TO_FM('3') M_D = TO_FM('.66666666666666666666') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 890 CALL FMSETVAR(' KROUND = 0 ') M_C = TO_FM('2')/TO_FM('3') M_D = TO_FM('.66666666666666666666') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 891 CALL FMSETVAR(' KROUND = 2 ') M_C = TO_FM('2')/TO_FM('3') M_D = TO_FM('.66666666666666666667') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 892 CALL FMSETVAR(' KROUND = 1 ') M_C = TO_FM('1')/TO_FM('3') M_D = TO_FM('.33333333333333333333') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 893 CALL FMSETVAR(' KROUND = -1 ') M_C = TO_FM('1')/TO_FM('3') M_D = TO_FM('.33333333333333333333') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 894 CALL FMSETVAR(' KROUND = 0 ') M_C = TO_FM('1')/TO_FM('3') M_D = TO_FM('.33333333333333333333') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 895 CALL FMSETVAR(' KROUND = 2 ') M_C = TO_FM('1')/TO_FM('3') M_D = TO_FM('.33333333333333333334') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 896 CALL FMSETVAR(' KROUND = 1 ') M_C = TO_FM('-1')/TO_FM('3') M_D = TO_FM('-.33333333333333333333') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 897 CALL FMSETVAR(' KROUND = -1 ') M_C = TO_FM('-1')/TO_FM('3') M_D = TO_FM('-.33333333333333333334') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 898 CALL FMSETVAR(' KROUND = 0 ') M_C = TO_FM('-1')/TO_FM('3') M_D = TO_FM('-.33333333333333333333') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 899 CALL FMSETVAR(' KROUND = 2 ') M_C = TO_FM('-1')/TO_FM('3') M_D = TO_FM('-.33333333333333333333') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 900 CALL FMSETVAR(' KROUND = 1 ') M_C = TO_FM('-2')/TO_FM('3') M_D = TO_FM('-.66666666666666666667') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 901 CALL FMSETVAR(' KROUND = -1 ') M_C = TO_FM('-2')/TO_FM('3') M_D = TO_FM('-.66666666666666666667') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 902 CALL FMSETVAR(' KROUND = 0 ') M_C = TO_FM('-2')/TO_FM('3') M_D = TO_FM('-.66666666666666666666') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 903 CALL FMSETVAR(' KROUND = 2 ') M_C = TO_FM('-2')/TO_FM('3') M_D = TO_FM('-.66666666666666666666') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 904 CALL FMSETVAR(' KROUND = 1 ') M_C = TO_FM('1') + TO_FM('3E-555') M_D = TO_FM('1.0000000000000000000') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 905 CALL FMSETVAR(' KROUND = -1 ') M_C = TO_FM('1') + TO_FM('3E-555') M_D = TO_FM('1.0000000000000000000') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 906 CALL FMSETVAR(' KROUND = 0 ') M_C = TO_FM('1') + TO_FM('3E-555') M_D = TO_FM('1.0000000000000000000') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 907 CALL FMSETVAR(' KROUND = 2 ') M_C = TO_FM('1') + TO_FM('3E-555') M_D = TO_FM('1.0000000000000000001') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 908 CALL FMSETVAR(' KROUND = 1 ') M_C = TO_FM('1') - TO_FM('3E-555') M_D = TO_FM('1.0000000000000000000') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 909 CALL FMSETVAR(' KROUND = -1 ') M_C = TO_FM('1') - TO_FM('3E-555') M_D = TO_FM('.99999999999999999999') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 910 CALL FMSETVAR(' KROUND = 0 ') M_C = TO_FM('1') - TO_FM('3E-555') M_D = TO_FM('.99999999999999999999') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 911 CALL FMSETVAR(' KROUND = 2 ') M_C = TO_FM('1') - TO_FM('3E-555') M_D = TO_FM('1.0000000000000000000') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 912 CALL FMSETVAR(' KROUND = 1 ') M_C = TO_FM('-1') + TO_FM('3E-555') M_D = TO_FM('-1.0000000000000000000') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 913 CALL FMSETVAR(' KROUND = -1 ') M_C = TO_FM('-1') + TO_FM('3E-555') M_D = TO_FM('-1.0000000000000000000') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 914 CALL FMSETVAR(' KROUND = 0 ') M_C = TO_FM('-1') + TO_FM('3E-555') M_D = TO_FM('-.99999999999999999999') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 915 CALL FMSETVAR(' KROUND = 2 ') M_C = TO_FM('-1') + TO_FM('3E-555') M_D = TO_FM('-.99999999999999999999') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 916 CALL FMSETVAR(' KROUND = 1 ') M_C = TO_FM('-1') - TO_FM('3E-555') M_D = TO_FM('-1.0000000000000000000') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 917 CALL FMSETVAR(' KROUND = -1 ') M_C = TO_FM('-1') - TO_FM('3E-555') M_D = TO_FM('-1.0000000000000000001') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 918 CALL FMSETVAR(' KROUND = 0 ') M_C = TO_FM('-1') - TO_FM('3E-555') M_D = TO_FM('-1.0000000000000000000') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 919 CALL FMSETVAR(' KROUND = 2 ') M_C = TO_FM('-1') - TO_FM('3E-555') M_D = TO_FM('-1.0000000000000000000') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF CALL FMSETVAR(' MBASE = 2 ') CALL FMSETVAR(' NDIG = 53 ') NCASE = 920 M_A = TO_FM('0.125') M_B = TO_FM('23.25') M_C = TO_FM('34.5') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('6.1345805065305141873M-25') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 921 M_A = TO_FM('0.52') M_B = TO_FM('2.01') M_C = TO_FM('1.6') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('1.0304844627978347604M-1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 922 M_A = TO_FM('9.01737835258975M-1') M_B = TO_FM('2.00853601446773') M_C = TO_FM('1.59735792202923') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('2.2512248738228585986M-1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 923 M_A = TO_FM('9.6097615596216720E-01') M_B = TO_FM('1.970425178583792') M_C = TO_FM('5.5680052333367') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('2.8619456987740165927M-2') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 924 M_A = TO_FM('4.764360371097952E-01') M_B = TO_FM('1.161514683661584E+01') M_C = TO_FM('2.937801562768354E-01') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('2.3604503996731113869M-5') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 925 M_A = TO_FM('0.9') M_B = TO_FM('23.4') M_C = TO_FM('34.5') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('7.3148127865937395334M-18') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF CALL FMSETVAR(' MBASE = 3 ') CALL FMSETVAR(' NDIG = 55 ') NCASE = 926 M_A = TO_FM('0.1') M_B = TO_FM('23.4') M_C = TO_FM('34.5') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('5.87319809189607304633501593392681M-27') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 927 M_A = TO_FM('0.52') M_B = TO_FM('2.1') M_C = TO_FM('1.6') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('9.25745341552810210762563659429375M-2') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 928 M_A = TO_FM('9.01737835258975M-1') M_B = TO_FM('2.00853601446773') M_C = TO_FM('1.59735792202923') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('2.25122487382285859767535178829535M-1') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 929 M_A = TO_FM('9.6097615596216720E-01') M_B = TO_FM('1.970425178583792') M_C = TO_FM('5.5680052333367') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('2.861945698774016536409296855493M-2') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 930 M_A = TO_FM('4.764360371097952E-01') M_B = TO_FM('1.161514683661584E+01') M_C = TO_FM('2.937801562768354E-01') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('2.36045039967311138687915158221269M-5') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 931 M_A = TO_FM('0.9') M_B = TO_FM('23.4') M_C = TO_FM('34.5') CALL FM_IBTA(M_A,M_B,M_C,MFM6) CALL FM_EQ(MFM6,M_C) M_D = TO_FM('7.31481278659372998212468424608367M-18') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 932 CALL FPST2M('1.67',MP1) CALL FPST2M('2.64',MP2) CALL FPADD(MP1,MP2,MP3) CALL FPEQ(MP3,MP1) CALL FPST2M('-3.91',MP2) CALL FPSUB(MP1,MP2,MP3) CALL FPEQ(MP3,MP1) CALL FPST2M('4.58',MP2) CALL FPMPY(MP1,MP2,MP3) CALL FPEQ(MP3,MP1) CALL FPST2M('0.27',MP2) CALL FPDIV(MP1,MP2,MP3) CALL FPEQ(MP3,MP1) CALL FPADDI(MP1,2) CALL FPMPYI(MP1,13,MP3) CALL FPEQ(MP3,MP1) CALL FPDIVI(MP1,11,MP3) CALL FPEQ(MP3,MP1) CALL FPLN(MP1,MP3) CALL FPEQ(MP3,MP1) CALL FPSIN(MP1,MP3) CALL FPEQ(MP3,MP1) CALL FPCOS(MP1,MP3) CALL FPEQ(MP3,MP1) CALL FPEXP(MP1,MP3) CALL FPEQ(MP3,MP1) CALL FPGAM(MP1,MP3) CALL FPEQ(MP3,MP1) CALL FMUNPK(MP1,M_C%MFM) M_D = TO_FM('0.941122001974472326543759839200398') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN CALL ERRPRT_FM(' Pack ',M_C,'M_C',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 933 SEED = (/ 2718281,8284590,4523536,0287471,3526624,9775724,7093699 /) CALL FM_RANDOM_SEED(PUT=SEED) DO J1 = 1, 10 CALL FM_RANDOM_NUMBER(D1) ENDDO M_C = D1 M_D = TO_FM('0.945608442536777') M_D = ABS((M_C - M_D)/M_D) IF (.NOT.(M_D <= TO_FM('1.0E-10'))) THEN CALL ERRPRT_FM(' Rand ',M_C,'M_C',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF CALL FMSETVAR(' MBASE = 10000 ') CALL FMSETVAR(' NDIG = 5 ') NCASE = 934 CALL FMSETVAR(' KROUND = 1 ') CALL FMSETVAR(' KRPERF = 1 ') M_C = SQRT( TO_FM('.49841718043038996023') ) M_D = TO_FM('.70598667156709832621') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF NCASE = 935 CALL FMSETVAR(' KROUND = 1 ') CALL FMSETVAR(' KRPERF = 0 ') M_C = SQRT( TO_FM('.49841718043038996023') ) M_D = TO_FM('.70598667156709832622') IF (.NOT.(M_D == M_C)) THEN CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', & NCASE,NERROR,KLOG) ENDIF RETURN END SUBROUTINE TEST47 SUBROUTINE ERRPRTFM(NROUT,M1,NAME1,M2,NAME2,M3,NAME3, & NCASE,NERROR,KLOG) ! Print error messages for testing of real (FM) routines. ! M1 is the value to be tested, as computed by the routine named NROUT. ! M2 is the reference value, usually converted using FMST2M. ! M3 is ABS(M1-M2), and ERRPRT is called if this is too big. ! NAME1,NAME2,NAME3 are strings identifying which variables in the ! calling routine correspond to M1,M2,M3. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE REAL (KIND(1.0D0)) :: M1(-1:LUNPCK),M2(-1:LUNPCK),M3(-1:LUNPCK) CHARACTER(2) :: NAME1,NAME2,NAME3 CHARACTER(6) :: NROUT INTEGER KLOG,KWSAVE,NCASE,NERROR NERROR = NERROR + 1 WRITE (KW, & "(//' Error in case',I4,'. The routine',' being tested was ',A6)" & ) NCASE,NROUT WRITE (KLOG, & "(//' Error in case',I4,'. The routine',' being tested was ',A6)" & ) NCASE,NROUT ! Temporarily change KW to KLOG so FMPRNT ! will write to the log file. KWSAVE = KW KW = KLOG WRITE (KLOG,"(1X,A,' =')") NAME1 CALL FMPRNT(M1) WRITE (KLOG,"(1X,A,' =')") NAME2 CALL FMPRNT(M2) WRITE (KLOG,"(1X,A,' =')") NAME3 CALL FMPRNT(M3) KW = KWSAVE RETURN END SUBROUTINE ERRPRTFM SUBROUTINE ERRPRTIM(NROUT,M1,NAME1,M2,NAME2, & NCASE,NERROR,KLOG) ! Print error messages for testing of integer (IM) routines. ! M1 is the value to be tested, as computed by the routine named NROUT. ! M2 is the reference value, usually converted using IMST2M. ! NAME1,NAME2 are strings identifying which variables in the calling routine ! correspond to M1,M2. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE REAL (KIND(1.0D0)) :: M1(-1:LUNPCK),M2(-1:LUNPCK) CHARACTER(2) :: NAME1,NAME2 CHARACTER(6) :: NROUT INTEGER KLOG,KWSAVE,NCASE,NERROR NERROR = NERROR + 1 WRITE (KW, & "(//' Error in case',I4,'. The routine',' being tested was ',A6)" & ) NCASE,NROUT WRITE (KLOG, & "(//' Error in case',I4,'. The routine',' being tested was ',A6)" & ) NCASE,NROUT ! Temporarily change KW to KLOG so IMPRNT ! will write to the log file. KWSAVE = KW KW = KLOG WRITE (KLOG,"(1X,A,' =')") NAME1 CALL IMPRNT(M1) WRITE (KLOG,"(1X,A,' =')") NAME2 CALL IMPRNT(M2) KW = KWSAVE END SUBROUTINE ERRPRTIM SUBROUTINE ERRPRTZM(NROUT,M1,NAME1,M2,NAME2,M3,NAME3, & NCASE,NERROR,KLOG) ! Print error messages. ! M1 is the value to be tested, as computed by the routine named NROUT. ! M2 is the reference value, usually converted using ZMST2M. ! M3 is ABS(M1-M2), and ERRPRTZM is called if this is too big. ! NAME1,NAME2,NAME3 are strings identifying which variables in the ! calling routine correspond to M1,M2,M3. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE REAL (KIND(1.0D0)) :: M1(-1:LUNPKZ),M2(-1:LUNPKZ),M3(-1:LUNPKZ) CHARACTER(2) :: NAME1,NAME2,NAME3 CHARACTER(6) :: NROUT INTEGER KLOG,KWSAVE,NCASE,NERROR NERROR = NERROR + 1 WRITE (KW, & "(//' Error in case',I4,'. The routine',' being tested was ',A6)" & ) NCASE,NROUT WRITE (KLOG, & "(//' Error in case',I4,'. The routine',' being tested was ',A6)" & ) NCASE,NROUT ! Temporarily change KW to KLOG so ZMPRNT ! will write to the log file. KWSAVE = KW KW = KLOG WRITE (KLOG,"(1X,A,' =')") NAME1 CALL ZMPRNT(M1) WRITE (KLOG,"(1X,A,' =')") NAME2 CALL ZMPRNT(M2) WRITE (KLOG,"(1X,A,' =')") NAME3 CALL ZMPRNT(M3) KW = KWSAVE END SUBROUTINE ERRPRTZM SUBROUTINE ERRPRT_FM(NROUT,M1,NAME1,M2,NAME2,M3,NAME3, & NCASE,NERROR,KLOG) ! Print error messages for testing of TYPE (FM) interface routines. ! M1 is the value to be tested, as computed by the routine named NROUT. ! M2 is the reference value, usually converted using FMST2M. ! M3 is ABS(M1-M2), and ERRPRT_FM is called if this is too big. ! NAME1,NAME2,NAME3 are strings identifying which variables in the ! calling routine correspond to M1,M2,M3. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE TYPE (FM) M1,M2,M3 CHARACTER(3) :: NAME1,NAME2,NAME3 CHARACTER(6) :: NROUT INTEGER KLOG,KWSAVE,NCASE,NERROR NERROR = NERROR + 1 WRITE (KW, & "(//' Error in case',I4,'. The interface',' being tested was ',A6)" & ) NCASE,NROUT WRITE (KLOG, & "(//' Error in case',I4,'. The interface',' being tested was ',A6)" & ) NCASE,NROUT ! Temporarily change KW to KLOG so FMPRNT ! will write to the log file. KWSAVE = KW KW = KLOG WRITE (KLOG,"(1X,A,' =')") NAME1 CALL FM_PRNT(M1) WRITE (KLOG,"(1X,A,' =')") NAME2 CALL FM_PRNT(M2) WRITE (KLOG,"(1X,A,' =')") NAME3 CALL FM_PRNT(M3) KW = KWSAVE END SUBROUTINE ERRPRT_FM SUBROUTINE ERRPRT_IM(NROUT,M1,NAME1,M2,NAME2, & NCASE,NERROR,KLOG) ! Print error messages for testing of TYPE (IM) interface routines. ! M1 is the value to be tested, as computed by the routine named NROUT. ! M2 is the reference value, usually converted using IMST2M. ! NAME1,NAME2 are strings identifying which variables in the calling routine ! correspond to M1,M2. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE TYPE (IM) M1,M2 CHARACTER(3) :: NAME1,NAME2 CHARACTER(6) :: NROUT INTEGER KLOG,KWSAVE,NCASE,NERROR NERROR = NERROR + 1 WRITE (KW, & "(//' Error in case',I4,'. The interface',' being tested was ',A6)" & ) NCASE,NROUT WRITE (KLOG, & "(//' Error in case',I4,'. The interface',' being tested was ',A6)" & ) NCASE,NROUT ! Temporarily change KW to KLOG so IMPRNT ! will write to the log file. KWSAVE = KW KW = KLOG WRITE (KLOG,"(1X,A,' =')") NAME1 CALL IM_PRNT(M1) WRITE (KLOG,"(1X,A,' =')") NAME2 CALL IM_PRNT(M2) KW = KWSAVE END SUBROUTINE ERRPRT_IM SUBROUTINE ERRPRT_ZM(NROUT,M1,NAME1,M2,NAME2,M3,NAME3, & NCASE,NERROR,KLOG) ! Print error messages for testing of TYPE (ZM) interface routines. ! M1 is the value to be tested, as computed by the routine named NROUT. ! M2 is the reference value, usually converted using ZMST2M. ! M3 is ABS(M1-M2), and ERRPRT_ZM is called if this is too big. ! NAME1,NAME2,NAME3 are strings identifying which variables in the calling routine ! correspond to M1,M2,M3. USE FMVALS USE FMZM USE TEST_VARS IMPLICIT NONE TYPE (ZM) M1,M2,M3 CHARACTER(3) :: NAME1,NAME2,NAME3 CHARACTER(6) :: NROUT INTEGER KLOG,KWSAVE,NCASE,NERROR NERROR = NERROR + 1 WRITE (KW, & "(//' Error in case',I4,'. The interface',' being tested was ',A6)" & ) NCASE,NROUT WRITE (KLOG, & "(//' Error in case',I4,'. The interface',' being tested was ',A6)" & ) NCASE,NROUT ! Temporarily change KW to KLOG so ZMPRNT ! will write to the log file. KWSAVE = KW KW = KLOG WRITE (KLOG,"(1X,A,' =')") NAME1 CALL ZM_PRNT(M1) WRITE (KLOG,"(1X,A,' =')") NAME2 CALL ZM_PRNT(M2) WRITE (KLOG,"(1X,A,' =')") NAME3 CALL ZM_PRNT(M3) KW = KWSAVE END SUBROUTINE ERRPRT_ZM SUBROUTINE PRTERR(KW,KLOG,NCASE,NERROR) IMPLICIT NONE INTEGER KW,KLOG,NCASE,NERROR WRITE (KW,*) ' Error in case ',NCASE WRITE (KLOG,*) ' ' WRITE (KLOG,*) ' Error in case ',NCASE NERROR = NERROR + 1 END SUBROUTINE PRTERR SUBROUTINE TIMEIT(TIME) INTEGER JTIME,JRATE REAL TIME ! Return the system time. f90 version. CALL SYSTEM_CLOCK(JTIME,JRATE) TIME = REAL(JTIME)/REAL(JRATE) RETURN END SUBROUTINE TIMEIT SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'Src' then mkdir 'Src' fi cd 'Src' if test -f 'FM.f90' then echo shar: will not over-write existing file "'FM.f90'" else cat << "SHAR_EOF" > 'FM.f90' ! FM 1.2 David M. Smith 8-17-01 ! The routines in this package perform multiple precision arithmetic and ! functions on three kinds of numbers. ! FM routines handle floating-point real multiple precision numbers, ! IM routines handle integer multiple precision numbers, and ! ZM routines handle floating-point complex multiple precision numbers. ! 1. INITIALIZING THE PACKAGE ! The variables that contain values to be shared by the different routines are ! located in module FMVALS in file FMSAVE.f90. Variables that are described ! below for controlling various features of the FM package are found in this ! module. They are initialized to default values assuming 32-bit integers and ! 64-bit double precision representation of the arrays holding multiple ! precision numbers. The base and number of digits to be used are initialized ! to give slightly more than 50 decimal digits. Subroutine FMVARS can be used ! to get a list of these variables and their values. ! The intent of module FMVALS is to hide the FM internal variables from the ! user's program, so that no name conflicts can occur. Subroutine FMSETVAR can ! be used to change the variables listed below to new values. It is not always ! safe to try to change these variables directly by putting USE FMVALS into the ! calling program and then changing them by hand. Some of the saved constants ! depend upon others, so that changing one variable may cause errors if others ! depending on that one are not also changed. FMSETVAR automatically updates ! any others that depend upon the one being changed. ! Subroutine FMSET also initializes these variables. It tries to compute the ! best value for each, and it checks several of the values set in FMVALS to see ! that they are reasonable for a given machine. FMSET can also be called to ! set or change the current precision level for the multiple precision numbers. ! Calling FMSET is optional in version 1.2 of the FM package. In previous ! versions one call was required before any other routine in the package could ! be used. ! The routine ZMSET from version 1.1 is no longer needed, and the complex ! operations are automatically initialized in FMVALS. It has been left in the ! package for compatibility with version 1.1. ! 2. REPRESENTATION OF FM NUMBERS ! MBASE is the base in which the arithmetic is done. MBASE must be ! bigger than one, and less than or equal to the square root of ! the largest representable integer. For best efficiency MBASE ! should be large, but no more than about 1/4 of the square root ! of the largest representable integer. Input and output ! conversions are much faster when MBASE is a power of ten. ! NDIG is the number of base MBASE digits that are carried in the ! multiple precision numbers. NDIG must be at least two. The ! upper limit for NDIG is defined in FMVALS and is restricted ! only by the amount of memory available. ! Sometimes it is useful to dynamically vary NDIG during the program. Routine ! FMEQU should be used to round numbers to lower precision or zero-pad them to ! higher precision when changing NDIG. ! The default value of MBASE is a large power of ten. FMSET also sets MBASE to ! a large power of ten. For an application where another base is used, such as ! simulating a given machine's base two arithmetic, use subroutine FMSETVAR to ! change MBASE, so that the other internal values depending on MBASE will be ! changed accordingly. ! There are two representations for a floating point multiple precision number. ! The unpacked representation used by the routines while doing the computations ! is base MBASE and is stored in NDIG+3 words. A packed representation is ! available to store the numbers in the user's program in compressed form. In ! this format, the NDIG (base MBASE) digits of the mantissa are packed two per ! word to conserve storage. Thus the external, packed form of a number ! requires (NDIG+1)/2+3 words. ! This version uses double precision arrays to hold the numbers. Version 1.0 ! of FM used integer arrays, which are faster on some machines. The package ! can be changed to use integer arrays --- see section 11 on EFFICIENCY below. ! The unpacked format of a floating multiple precision number is as follows. ! A number MA is kept in an array with MA(1) containing the exponent, and ! MA(2) through MA(NDIG+1) each containing one digit of the mantissa, expressed ! in base MBASE. The array is dimensioned to start at MA(-1), with the ! sign of the number (+1 or -1) held in MA(-1), and the approximate number ! of bits of precision stored in MA(0). This precision value is intended to ! be used by FM functions that need to monitor cancellation error in addition ! and subtraction. The cancellation monitor code is usually disabled for user ! calls, and FM functions only check for cancellation when they must. Tracking ! cancellation causes most routines to run slower, with addition and ! subtraction being affected the most. The exponent is a power of MBASE and ! the implied radix point is immediately before the first digit of the ! mantissa. Every nonzero number is normalized so that the second array ! element (the first digit of the mantissa) is nonzero. ! In both representations the sign of the number is carried on the second array ! element only. Elements 3,4,... are always nonnegative. The exponent is a ! signed integer and may be as large in magnitude as MXEXP. ! For MBASE = 10,000 and NDIG = 4, if array MA holds the number -pi, it would ! have these representations: ! Word 1 2 3 4 5 ! Unpacked: 1 3 1415 9265 3590 ! Packed: 1 31415 92653590 ! In both formats MA(0) would be 42, indicating that the mantissa has about 42 ! bits of precision, and MA(-1) = -1 since the number is negative. ! Because of normalization in a large base, the equivalent number of base 10 ! significant digits for an FM number may be as small as ! LOG10(MBASE)*(NDIG-1) + 1. ! The integer routines use the FM format to represent numbers, without the ! number of digits (NDIG) being fixed. Integers in IM format are essentially ! variable precision, using the minimum number of words to represent each ! value. ! For programs using both FM and IM numbers, FM routines should not be called ! with IM numbers, and IM routines should not be called with FM numbers, since ! the implied value of NDIG used for an IM number may not match the explicit ! NDIG expected by an FM routine. Use the conversion routines IMFM2I and ! IMI2FM to change between the FM and IM formats. ! The format for complex FM numbers (called ZM numbers below) is very similar ! to that for real FM numbers. Each ZM array holds two FM numbers to represent ! the real and imaginary parts of a complex number. Each ZM array is twice as ! long as a corresponding FM array, with the imaginary part starting at the ! midpoint of the array. As with FM, there are packed and unpacked formats for ! the numbers. ! 3. INPUT/OUTPUT ROUTINES ! All versions of the input routines perform free-format conversion from ! characters to FM numbers. ! a. Conversion to or from a character array ! FMINP converts from a character*1 array to an FM number. ! FMOUT converts an FM number to base 10 and formats it for output as an ! array of type character*1. The output is left justified in the ! array, and the format is defined by two variables in module FMVALS, ! so that a separate format definition does not have to be provided ! for each output call. ! JFORM1 and JFORM2 define a default output format. ! JFORM1 = 0 E format ( .314159M+6 ) ! = 1 1PE format ( 3.14159M+5 ) ! = 2 F format ( 314159.000 ) ! JFORM2 is the number of significant digits to display (if JFORM1 = ! 0 or 1). If JFORM2 = 0 then a default number of digits is chosen. ! The default is roughly the full precision of the number. ! JFORM2 is the number of digits after the decimal point (if JFORM1 = 2). ! See the FMOUT documentation for more details. ! b. Conversion to or from a character string ! FMST2M converts from a character string to an FM number. ! FMFORM converts an FM number to a character string according to a format ! provided in each call. The format description is more like that of ! a Fortran FORMAT statement, and integer or fixed-point output is ! right justified. ! c. Direct read or write ! FMPRNT uses FMOUT to print one FM number. ! FMFPRT uses FMFORM to print one FM number. ! FMWRIT writes FM numbers for later input using FMREAD. ! FMREAD reads FM numbers written by FMWRIT. ! The values given to JFORM1 and JFORM2 can be used to define a default output ! format when FMOUT or FMPRNT are called. The explicit format used in a call ! to FMFORM or FMFPRT overrides the settings of JFORM1 and JFORM2. ! KW is the unit number to be used for standard output from the package, ! including error and warning messages, and trace output. ! For multiple precision integers, the corresponding routines IMINP, IMOUT, ! IMST2M, IMFORM, IMPRNT, IMFPRT, IMWRIT, and IMREAD provide similar input and ! output conversions. For output of IM numbers, JFORM1 and JFORM2 are ignored ! and integer format (JFORM1=2, JFORM2=0) is used. ! For ZM numbers, the corresponding routines ZMINP, ZMOUT, ZMST2M, ZMFORM, ! ZMPRNT, ZMFPRT, ZMWRIT, and ZMREAD provide similar input and output ! conversions. ! For the output format of ZM numbers, JFORM1 and JFORM2 determine the default ! format for the individual parts of a complex number as with FM numbers. ! JFORMZ determines the combined output format of the real and ! imaginary parts. ! JFORMZ = 1 normal setting : 1.23 - 4.56 i ! = 2 use capital I : 1.23 - 4.56 I ! = 3 parenthesis format: ( 1.23 , -4.56 ) ! JPRNTZ controls whether to print real and imaginary parts ! on one line whenever possible. ! JPRNTZ = 1 print both parts as a single string : ! 1.23456789M+321 - 9.87654321M-123 i ! = 2 print on separate lines without the 'i' : ! 1.23456789M+321 ! -9.87654321M-123 ! For further description of these routines, see sections 9 and 10 below. ! 4. ARITHMETIC TRACING ! NTRACE and LVLTRC control trace printout from the package. ! NTRACE = 0 No output except warnings and errors. (Default) ! = 1 The result of each call to one of the routines ! is printed in base 10, using FMOUT. ! = -1 The result of each call to one of the routines ! is printed in internal base MBASE format. ! = 2 The input arguments and result of each call to one ! of the routines is printed in base 10, using FMOUT. ! = -2 The input arguments and result of each call to one ! of the routines is printed in base MBASE format. ! LVLTRC defines the call level to which the trace is done. LVLTRC = 1 ! means only FM routines called directly by the user are traced, ! LVLTRC = 2 also prints traces for FM routines called by other ! FM routines called directly by the user, etc. Default is 1. ! In the above description, internal MBASE format means the number is ! printed as it appears in the array --- an exponent followed by NDIG ! base MBASE digits. ! 5. ERROR CONDITIONS ! KFLAG is a condition value returned by the package after each call to one of ! the routines. Negative values indicate conditions for which a warning ! message will be printed unless KWARN = 0. ! Positive values indicate conditions that may be of interest but are not ! errors. No warning message is printed if KFLAG is nonnegative. ! Subroutine FMFLAG is provided to give the user access to the current ! condition code. For example, to set the user's local variable LFLAG ! to FM's internal KFLAG value: CALL FMFLAG(LFLAG) ! KFLAG = 0 Normal operation. ! = 1 One of the operands in FMADD or FMSUB was insignificant with ! respect to the other, so that the result was equal to ! the argument of larger magnitude. ! = 2 In converting an FM number to a one word integer in FMM2I, ! the FM number was not exactly an integer. The next ! integer toward zero was returned. ! = -1 NDIG was less than 2 or more than NDIGMX. ! = -2 MBASE was less than 2 or more than MXBASE. ! = -3 An exponent was out of range. ! = -4 Invalid input argument(s) to an FM routine. ! UNKNOWN was returned. ! = -5 + or - OVERFLOW was generated as a result from an ! FM routine. ! = -6 + or - UNDERFLOW was generated as a result from an ! FM routine. ! = -7 The input string (array) to FMINP was not legal. ! = -8 The character array was not large enough in an ! input or output routine. ! = -9 Precision could not be raised enough to provide all ! requested guard digits. Increasing the value ! of NDIGMX in file FMSAVE.f90 may fix this. ! UNKNOWN was returned. ! = -10 An FM input argument was too small in magnitude to ! convert to the machine's single or double ! precision in FMM2SP or FMM2DP. Check that the ! definitions of SPMAX and DPMAX in file FMSAVE.f90 ! are correct for the current machine. ! Zero was returned. ! = -11 Array MBERN is not dimensioned large enough for the ! requested number of Bernoulli numbers. ! = -12 Array MJSUMS is not dimensioned large enough for ! the number of coefficients needed in the ! reflection formula in FMPGAM. ! When a negative KFLAG condition is encountered, the value of KWARN ! determines the action to be taken. ! KWARN = 0 Execution continues and no message is printed. ! = 1 A warning message is printed and execution continues. ! = 2 A warning message is printed and execution stops. ! The default setting is KWARN = 1. ! When an overflow or underflow is generated for an operation in which an input ! argument was already an overflow or underflow, no additional message is ! printed. When an unknown result is generated and an input argument was ! already unknown, no additional message is printed. In these cases the ! negative KFLAG value is still returned. ! IM routines handle exceptions like OVERFLOW or UNKNOWN in the same way as FM ! routines. When using IMMPY, the product of two large positive integers will ! return +OVERFLOW. The routines IMMPYM and IMPMOD can be used to obtain a ! modular result without overflow. The largest representable IM integer is ! MBASE**NDIGMX - 1. For example, if MBASE is 10**7 and NDIGMX is set to 256, ! integers less than 10**1792 can be used. ! 6. OTHER OPTIONS ! KRAD = 0 All angles in the trigonometric functions and inverse functions ! are measured in degrees. ! = 1 All angles are measured in radians. (Default) ! KROUND = -1 All results are rounded toward minus infinity. ! = 0 All results are rounded toward zero (chopped). ! = 1 All results are rounded to the nearest FM number, or to the ! value with an even last digit if the result is halfway ! between two FM numbers. (Default) ! = 2 All results are rounded toward plus infinity. ! In all cases, while a function is being computed all intermediate ! results are rounded to nearest, with only the final result being ! rounded according to KROUND. ! KRPERF = 0 A smaller number of guard digits used, to give nearly perfect ! rounding. This number is chosen so that the last intermediate ! result should have error less than 0.001 unit in the last place ! of the final rounded result. (Default) ! = 1 Causes more guard digits to be used, to get perfect rounding in ! the mode set by KROUND. This slows execution speed. ! If a small base is used for the arithmetic, like MBASE = 2, 10, or 16, ! FM assumes that the arithmetic hardware for some machine is being ! simulated, so perfect rounding is done without regard for the value ! of KRPERF. ! If KROUND = 1, then KRPERF = 1 means returned results are no more than ! 0.500 units in the last place from the exact mathematical result, ! versus 0.501 for KRPERF = 0. ! If KROUND is not 1, then KRPERF = 1 means returned results are no more ! than 1.000 units in the last place from the exact mathematical result, ! versus 1.001 for KRPERF = 0. ! KSWIDE defines the maximum screen width to be used for all unit KW output. ! Default is 80. ! KESWCH controls the action taken in FMINP and other input routines for ! strings like 'E7' that have no digits before the exponent field. ! This is sometimes a convenient abbreviation when doing interactive ! keyboard input. ! KESWCH = 1 causes 'E7' to translate like '1.0E+7'. (Default) ! KESWCH = 0 causes 'E7' to translate like '0.0E+7' and give 0. ! CMCHAR defines the exponent letter to be used for FM variable output. ! Default is 'M', as in 1.2345M+678. ! Change it to 'E' for output to be read by a non-FM program. ! KDEBUG = 0 No error checking is done to see if input arguments are valid ! and parameters like NDIG and MBASE are correct upon entry to ! each routine. (Default) ! = 1 Some error checking is done. (Slower speed) ! See module FMVALS in file FMSAVE.f90 for additional description of these and ! other variables defining various FM conditions. ! 7. ARRAY DIMENSIONS ! The dimensions of the arrays in the FM package are defined using parameters ! NDIGMX and NBITS. ! NDIGMX is the maximum value the user may set for NDIG. ! NBITS is the number of bits used to represent integers for a given machine. ! See the EFFICIENCY discussion below. ! The standard version of FM sets NDIGMX = 55, so on a 32-bit machine using ! MBASE = 10**7 the maximum precision is about 7*54+1 = 379 significant ! digits. Previous versions of FM set NDIGMX = 256. Two reasons for making ! this change are: ! (a) Almost all applications using FM use only 30 to 50 significant digits ! for checking double or quadruple precision results, and the larger ! arrays are wasted space. ! (b) Most FM applications use the derived type interface so that the number ! of changes to existing code is minimized. Many compilers implement the ! FM interface by doing copy in / copy out argument passing of the derived ! types. Copying the entire large array when only a small part of it is ! being used causes the derived type arithmetic to be slow compared to ! making direct calls to the subroutines. Setting NDIGMX to be only ! slightly higher than a program actually uses minimizes any performance ! penalty for the derived type arithmetic. ! To change dimensions so that 10,000 significant digit calculation can be ! done, NDIGMX needs to be at least 10**4/7 + 5 = 1434. This allows for a ! few user guard digits to be defined when the precision is changed using ! CALL FMSET(10000). Changing 'NDIGMX = 55' to 'NDIGMX = 1434' in FMSAVE.f90 ! will define all the new array sizes. ! If NDIG much greater than 256 is to be used and elementary functions will ! be needed, they will be faster if array MJSUMS is larger. The parameter ! defining the size of MJSUMS is set in the standard version by ! LJSUMS = 8*(LUNPCK+3) ! The 8 means that up to eight concurrent sums can be used by the elementary ! functions. The approximate number needed for best speed is given by ! 0.051*Log(MBASE)*NDIG**0.333 + 1.85 ! For example, with MBASE=10**7 and NDIG=1434 this gives 11. Changing ! 'LJSUMS = 8*(LUNPCK+3)' to 'LJSUMS = 11*(LUNPCK+3)' in FMSAVE.f90 will give ! slightly better speed. ! FM numbers in packed format have dimension -1:LPACK, and those in unpacked ! format have dimension -1:LUNPCK. ! The parameters LPACKZ and LUNPKZ define the size of the packed and unpacked ! ZM arrays. The real part starts at the beginning of the array, and the ! imaginary part starts at word KPTIMP for packed format or at word KPTIMU for ! unpacked format. ! 8. PORTABILITY ! In FMSET several variables are set to machine-dependent values, and many of ! the variables initialized in module FMVALS in file FMSAVE.f90 are checked to ! see that they have reasonable values. FMSET will print warning messages on ! unit KW for any of the FMVALS variables that seem to be poorly initialized. ! If an FM run fails, call FMVARS to get a list of all the FMVALS variables ! printed on unit KW. Setting KDEBUG = 1 at the start may also identify some ! errors. ! Some compilers object to a function like FMCOMP with side effects such as ! changing KFLAG or other module variables. Blocks of code in FMCOMP and ! IMCOMP that modify these variables are identified so they may be removed or ! commented out to produce a function without side effects. This disables ! trace printing in FMCOMP and IMCOMP, and error codes are not returned in ! KFLAG. See FMCOMP and IMCOMP for further details. ! In FMBER2 and FMPGAM several constants are used that require the machine's ! integer word size to be at least 32 bits. ! 9. LIST OF ROUTINES ! These are the FM routines that are designed to be called by the user. ! All are subroutines except logical function FMCOMP. ! MA, MB, MC refer to FM format numbers. ! In Fortran-90 and later versions of the Fortran standard, it is potentially ! unsafe to use the same array more than once in the calling sequence. The ! operation MA = MA + MB should not be written as ! CALL FMADD(MA,MB,MA) ! since the compiler is allowed to pass the three arguments with a copy in / ! copy out mechanism. This means the third argument, containing the result, ! might not be copied out last, and then a later copy out of the original ! input MA could destroy the computed result. ! One solution is to use a third array and then put the result back in MA: ! CALL FMADD(MA,MB,MC) ! CALL FMEQ(MC,MA) ! When the first call is doing one of the "fast" operations like addition, ! the extra call to move the result back to MA can cause a noticeable loss in ! efficiency. To avoid this, separate routines are provided for the basic ! arithmetic operations when the result is to be returned in the same array ! as one of the inputs. ! A routine name with a suffix of "_R1" returns the result in the first ! input array, and a suffix of "_R2" returns the result in the second input ! array. The example above would then be: ! CALL FMADD_R1(MA,MB) ! These routines each have one less argument than the original version, since ! the output is re-directed to one of the inputs. The result array should ! not be the same as any input array when the original version of the routine ! is used. ! The routines that can be used this way are listed below. For others, like ! CALL FMEXP(MA,MA) ! the relative cost of doing an extra copy is small. This one should become ! CALL FMEXP(MA,MB) ! CALL FMEQ(MB,MA) ! If the derived-type interface is used, as in ! TYPE (FM) A,B ! ... ! A = A + B ! there is no problem putting the result back into A, since the interface ! routine creates a temporary scratch array for the result of A + B, allowing ! copy in / copy out to work. ! For each of these routines there is also a version available for which the ! argument list is the same but all FM numbers are in packed format. The ! routines using packed numbers have the same names except 'FM' is replaced by ! 'FP' at the start of each name. ! FMABS(MA,MB) MB = ABS(MA) ! FMACOS(MA,MB) MB = ACOS(MA) ! FMADD(MA,MB,MC) MC = MA + MB ! FMADD_R1(MA,MB) MA = MA + MB ! FMADD_R2(MA,MB) MB = MA + MB ! FMADDI(MA,IVAL) MA = MA + IVAL Increment an FM number by a one word ! integer. Note this call does not have ! an "MB" result like FMDIVI and FMMPYI. ! FMASIN(MA,MB) MB = ASIN(MA) ! FMATAN(MA,MB) MB = ATAN(MA) ! FMATN2(MA,MB,MC) MC = ATAN2(MA,MB) ! FMBIG(MA) MA = Biggest FM number less than overflow. ! FMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA). ! Faster than making two separate calls. ! FMCOMP(MA,LREL,MB) Logical comparison of MA and MB. ! LREL is a CHARACTER*2 value identifying ! which of the six comparisons is to be made. ! Example: IF (FMCOMP(MA,'GE',MB)) ... ! Also can be: IF (FMCOMP(MA,'>=',MB)) ... ! CHARACTER*1 is ok: IF (FMCOMP(MA,'>',MB)) ... ! FMCONS Set several saved constants that depend on MBASE, ! the base being used. FMCONS should be called ! immediately after changing MBASE. ! FMCOS(MA,MB) MB = COS(MA) ! FMCOSH(MA,MB) MB = COSH(MA) ! FMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA). ! Faster than making two separate calls. ! FMDIG(NSTACK,KST) Find a set of precisions to use during Newton ! iteration for finding a simple root starting with ! about double precision accuracy. ! FMDIM(MA,MB,MC) MC = DIM(MA,MB) ! FMDIV(MA,MB,MC) MC = MA / MB ! FMDIV_R1(MA,MB) MA = MA / MB ! FMDIV_R2(MA,MB) MB = MA / MB ! FMDIVI(MA,IVAL,MB) MB = MA/IVAL IVAL is a one word integer. ! FMDIVI_R1(MA,IVAL) MA = MA/IVAL ! FMDP2M(X,MA) MA = X Convert from double precision to FM. ! FMDPM(X,MA) MA = X Convert from double precision to FM. ! Faster than FMDP2M, but MA agrees with X only ! to D.P. accuracy. See the comments in the ! two routines. ! FMEQ(MA,MB) MB = MA Both have precision NDIG. ! This is the version to use for standard ! B = A statements. ! FMEQU(MA,MB,NA,NB) MB = MA Version for changing precision. ! MA has NA digits (i.e., MA was computed ! using NDIG = NA), and MB will be defined ! having NB digits. ! MB is rounded if NB < NA ! MB is zero-padded if NB > NA ! FMEXP(MA,MB) MB = EXP(MA) ! FMFLAG(K) K = KFLAG get the value of the FM condition ! flag -- stored in the internal FM ! variable KFLAG in module FMVALS. ! FMFORM(FORM,MA,STRING) MA is converted to a character string using format ! FORM and returned in STRING. FORM can represent ! I, F, E, or 1PE formats. Example: ! CALL FMFORM('F60.40',MA,STRING) ! FMFPRT(FORM,MA) Print MA on unit KW using FORM format. ! FMI2M(IVAL,MA) MA = IVAL Convert from one word integer to FM. ! FMINP(LINE,MA,LA,LB) MA = LINE Input conversion. ! Convert LINE(LA) through LINE(LB) ! from characters to FM. ! FMINT(MA,MB) MB = INT(MA) Integer part of MA. ! FMIPWR(MA,IVAL,MB) MB = MA**IVAL Raise an FM number to a one word ! integer power. ! FMLG10(MA,MB) MB = LOG10(MA) ! FMLN(MA,MB) MB = LOG(MA) ! FMLNI(IVAL,MA) MA = LOG(IVAL) Natural log of a one word integer. ! FMM2DP(MA,X) X = MA Convert from FM to double precision. ! FMM2I(MA,IVAL) IVAL = MA Convert from FM to integer. ! FMM2SP(MA,X) X = MA Convert from FM to single precision. ! FMMAX(MA,MB,MC) MC = MAX(MA,MB) ! FMMIN(MA,MB,MC) MC = MIN(MA,MB) ! FMMOD(MA,MB,MC) MC = MA mod MB ! FMMPY(MA,MB,MC) MC = MA * MB ! FMMPY_R1(MA,MB) MA = MA * MB ! FMMPY_R2(MA,MB) MB = MA * MB ! FMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer. ! FMMPYI_R1(MA,IVAL) MA = MA*IVAL ! FMNINT(MA,MB) MB = NINT(MA) Nearest FM integer. ! FMOUT(MA,LINE,LB) LINE = MA Convert from FM to character. ! LINE is a character array of length LB. ! FMPI(MA) MA = pi ! FMPRNT(MA) Print MA on unit KW using current format. ! FMPWR(MA,MB,MC) MC = MA**MB ! FM_RANDOM_NUMBER(X) X is returned as a double precision random number, ! uniform on (0,1). High-quality, long-period ! generator. ! Note that X is double precision, unlike the similar ! Fortran intrinsic random number routine, which ! returns a single-precision result. ! See the comments in section 10 below and also those ! in the routine for more details. ! FMREAD(KREAD,MA) MA is returned after reading one (possibly multi-line) ! FM number on unit KREAD. This routine reads ! numbers written by FMWRIT. ! FMRPWR(MA,K,J,MB) MB = MA**(K/J) Rational power. ! Faster than FMPWR for functions like the cube root. ! FMSET(NPREC) Set the internal FM variables so that the precision ! is at least NPREC base 10 digits plus three base 10 ! guard digits. ! FMSETVAR(STRING) Define a new value for one of the internal FM ! variables in module FMVALS that controls one of the ! FM options. STRING has the form variable = value. ! Example: To change the screen width for FM output: ! CALL FMSETVAR(' KSWIDE = 120 ') ! The variables that can be changed and the options ! they control are listed in sections 2 through 6 ! above. Only one variable can be set per call. ! The variable name in STRING must have no embedded ! blanks. The value part of STRING can be in any ! numerical format, except in the case of variable ! CMCHAR, which is character type. To set CMCHAR to ! 'E', don't use any quotes in STRING: ! CALL FMSETVAR(' CMCHAR = E ') ! FMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer. ! FMSIN(MA,MB) MB = SIN(MA) ! FMSINH(MA,MB) MB = SINH(MA) ! FMSP2M(X,MA) MA = X Convert from single precision to FM. ! FMSQR(MA,MB) MB = MA * MA Faster than FMMPY. ! FMSQR_R1(MA) MA = MA * MA ! FMSQRT(MA,MB) MB = SQRT(MA) ! FMSQRT_R1(MA) MA = SQRT(MA) ! FMST2M(STRING,MA) MA = STRING ! Convert from character string to FM. ! STRING may be in any numerical format. ! Often more convenient than FMINP, which converts ! an array of CHARACTER*1 values. Example: ! CALL FMST2M('123.4',MA) ! FMSUB(MA,MB,MC) MC = MA - MB ! FMSUB_R1(MA,MB) MA = MA - MB ! FMSUB_R2(MA,MB) MB = MA - MB ! FMTAN(MA,MB) MB = TAN(MA) ! FMTANH(MA,MB) MB = TANH(MA) ! FMULP(MA,MB) MB = One Unit in the Last Place of MA. ! FMVARS Write the current values of the internal FM ! variables on unit KW. ! FMWRIT(KWRITE,MA) Write MA on unit KWRITE. ! Multi-line numbers will have '&' as the last ! nonblank character on all but the last line. These ! numbers can then be read easily using FMREAD. ! These are the Gamma and Related Functions. ! FMBERN(N,MA,MB) MB = MA*B(N) Multiply by Nth Bernoulli number ! FMBETA(MA,MB,MC) MC = Beta(MA,MB) ! FMCOMB(MA,MB,MC) MC = Combination MA choose MB (Binomial coeff.) ! FMEULR(MA) MA = Euler's constant ( 0.5772156649... ) ! FMFACT(MA,MB) MB = MA Factorial (Gamma(MA+1)) ! FMGAM(MA,MB) MB = Gamma(MA) ! FMIBTA(MX,MA,MB,MC) MC = Incomplete Beta(MX,MA,MB) ! FMIGM1(MA,MB,MC) MC = Incomplete Gamma(MA,MB). Lower case Gamma(a,x) ! FMIGM2(MA,MB,MC) MC = Incomplete Gamma(MA,MB). Upper case Gamma(a,x) ! FMLNGM(MA,MB) MB = Ln(Gamma(MA)) ! FMPGAM(N,MA,MB) MB = Polygamma(N,MA) (Nth derivative of Psi) ! FMPOCH(MA,N,MB) MB = MA*(MA+1)*(MA+2)*...*(MA+N-1) (Pochhammer) ! FMPSI(MA,MB) MB = Psi(MA) (Derivative of Ln(Gamma(MA)) ! These are the integer routines that are designed to be called by the user. ! All are subroutines except logical function IMCOMP. MA, MB, MC refer to IM ! format numbers. In each case the version of the routine to handle packed IM ! numbers has the same name, with 'IM' replaced by 'IP'. ! IMABS(MA,MB) MB = ABS(MA) ! IMADD(MA,MB,MC) MC = MA + MB ! IMBIG(MA) MA = Biggest IM number less than overflow. ! IMCOMP(MA,LREL,MB) Logical comparison of MA and MB. ! LREL is a CHARACTER*2 value identifying which of ! the six comparisons is to be made. ! Example: IF (IMCOMP(MA,'GE',MB)) ... ! Also can be: IF (IMCOMP(MA,'>=',MB)) ! CHARACTER*1 is ok: IF (IMCOMP(MA,'>',MB)) ... ! IMDIM(MA,MB,MC) MC = DIM(MA,MB) ! IMDIV(MA,MB,MC) MC = int(MA/MB) ! Use IMDIVR if the remainder is also needed. ! IMDIVI(MA,IVAL,MB) MB = int(MA/IVAL) ! IVAL is a one word integer. ! Use IMDVIR to get the remainder also. ! IMDIVR(MA,MB,MC,MD) MC = int(MA/MB), MD = MA mod MB ! When both the quotient and remainder are needed, ! this routine is twice as fast as calling both ! IMDIV and IMMOD. ! IMDVIR(MA,IVAL,MB,IREM) MB = int(MA/IVAL), IREM = MA mod IVAL ! IVAL and IREM are one word integers. ! IMEQ(MA,MB) MB = MA ! IMFM2I(MAFM,MB) MB = MAFM Convert from real (FM) format to ! integer (IM) format. ! IMFORM(FORM,MA,STRING) MA is converted to a character string using format ! FORM and returned in STRING. FORM can represent ! I, F, E, or 1PE formats. Example: ! CALL IMFORM('I70',MA,STRING) ! IMFPRT(FORM,MA) Print MA on unit KW using FORM format. ! IMGCD(MA,MB,MC) MC = greatest common divisor of MA and MB. ! IMI2FM(MA,MBFM) MBFM = MA Convert from integer (IM) format to ! real (FM) format. ! IMI2M(IVAL,MA) MA = IVAL Convert from one word integer to IM. ! IMINP(LINE,MA,LA,LB) MA = LINE Input conversion. ! Convert LINE(LA) through LINE(LB) ! from characters to IM. ! IMM2DP(MA,X) X = MA Convert from IM to double precision. ! IMM2I(MA,IVAL) IVAL = MA Convert from IM to one word integer. ! IMMAX(MA,MB,MC) MC = MAX(MA,MB) ! IMMIN(MA,MB,MC) MC = MIN(MA,MB) ! IMMOD(MA,MB,MC) MC = MA mod MB ! IMMPY(MA,MB,MC) MC = MA*MB ! IMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer. ! IMMPYM(MA,MB,MC,MD) MD = MA*MB mod MC ! Slightly faster than calling IMMPY and IMMOD ! separately, and it works for cases where IMMPY ! would return OVERFLOW. ! IMOUT(MA,LINE,LB) LINE = MA Convert from IM to character. ! LINE is a character array of length LB. ! IMPMOD(MA,MB,MC,MD) MD = MA**MB mod MC ! IMPRNT(MA) Print MA on unit KW. ! IMPWR(MA,MB,MC) MC = MA**MB ! IMREAD(KREAD,MA) MA is returned after reading one (possibly multi-line) ! IM number on unit KREAD. ! This routine reads numbers written by IMWRIT. ! IMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer. ! IMSQR(MA,MB) MB = MA*MA Faster than IMMPY. ! IMST2M(STRING,MA) MA = STRING ! Convert from character string to IM. ! Often more convenient than IMINP, which converts an ! array of CHARACTER*1 values. Example: ! CALL IMST2M('12345678901',MA) ! IMSUB(MA,MB,MC) MC = MA - MB ! IMWRIT(KWRITE,MA) Write MA on unit KWRITE. ! Multi-line numbers will have '&' as the last ! nonblank character on all but the last line. ! These numbers can then be read easily using IMREAD. ! These are the complex routines that are designed to be called by the user. ! All are subroutines, and in each case the version of the routine to handle ! packed ZM numbers has the same name, with 'ZM' replaced by 'ZP'. ! MA, MB, MC refer to ZM format complex numbers. ! MAFM, MBFM, MCFM refer to FM format real numbers. ! INTEG is a Fortran INTEGER variable. ! ZVAL is a Fortran COMPLEX variable. ! ZMABS(MA,MBFM) MBFM = ABS(MA) Result is real. ! ZMACOS(MA,MB) MB = ACOS(MA) ! ZMADD(MA,MB,MC) MC = MA + MB ! ZMADDI(MA,INTEG) MA = MA + INTEG Increment an ZM number by a one word ! integer. Note this call does not have ! an "MB" result like ZMDIVI and ZMMPYI. ! ZMARG(MA,MBFM) MBFM = Argument(MA) Result is real. ! ZMASIN(MA,MB) MB = ASIN(MA) ! ZMATAN(MA,MB) MB = ATAN(MA) ! ZMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA). ! Faster than 2 calls. ! ZMCMPX(MAFM,MBFM,MC) MC = CMPLX(MAFM,MBFM) ! ZMCONJ(MA,MB) MB = CONJG(MA) ! ZMCOS(MA,MB) MB = COS(MA) ! ZMCOSH(MA,MB) MB = COSH(MA) ! ZMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA). ! Faster than 2 calls. ! ZMDIV(MA,MB,MC) MC = MA / MB ! ZMDIVI(MA,INTEG,MB) MB = MA / INTEG ! ZMEQ(MA,MB) MB = MA ! ZMEQU(MA,MB,NDA,NDB) MB = MA Version for changing precision. ! (NDA and NDB are as in FMEQU) ! ZMEXP(MA,MB) MB = EXP(MA) ! ZMFORM(FORM1,FORM2,MA,STRING) STRING = MA ! MA is converted to a character string using format ! FORM1 for the real part and FORM2 for the imaginary ! part. The result is returned in STRING. FORM1 and ! FORM2 can represent I, F, E, or 1PE formats. Example: ! CALL ZMFORM('F20.10','F15.10',MA,STRING) ! A 1PE in the first format does not carry over to the ! other format descriptor, as it would in an ordinary ! FORMAT statement. ! ZMFPRT(FORM1,FORM2,MA) Print MA on unit KW using formats FORM1 and FORM2. ! ZMI2M(INTEG,MA) MA = CMPLX(INTEG,0) ! ZM2I2M(INTEG1,INTEG2,MA) MA = CMPLX(INTEG1,INTEG2) ! ZMIMAG(MA,MBFM) MBFM = IMAG(MA) Imaginary part. ! ZMINP(LINE,MA,LA,LB) MA = LINE Input conversion. ! Convert LINE(LA) through LINE(LB) from ! characters to ZM. LINE is a character array ! of length at least LB. ! ZMINT(MA,MB) MB = INT(MA) Integer part of both Real ! and Imaginary parts of MA. ! ZMIPWR(MA,INTEG,MB) MB = MA ** INTEG Integer power function. ! ZMLG10(MA,MB) MB = LOG10(MA) ! ZMLN(MA,MB) MB = LOG(MA) ! ZMM2I(MA,INTEG) INTEG = INT(REAL(MA)) ! ZMM2Z(MA,ZVAL) ZVAL = MA ! ZMMPY(MA,MB,MC) MC = MA * MB ! ZMMPYI(MA,INTEG,MB) MB = MA * INTEG ! ZMNINT(MA,MB) MB = NINT(MA) Nearest integer of both Real ! and Imaginary. ! ZMOUT(MA,LINE,LB,LAST1,LAST2) LINE = MA ! Convert from FM to character. ! LINE is the returned character*1 array. ! LB is the dimensioned size of LINE. ! LAST1 is returned as the position in LINE of ! the last character of REAL(MA). ! LAST2 is returned as the position in LINE ! of the last character of AIMAG(MA). ! ZMPRNT(MA) Print MA on unit KW using current format. ! ZMPWR(MA,MB,MC) MC = MA ** MB ! ZMREAD(KREAD,MA) MA is returned after reading one (possibly multi-line) ! ZM number on unit KREAD. ! This routine reads numbers written by ZMWRIT. ! ZMREAL(MA,MBFM) MBFM = REAL(MA) Real part. ! ZMRPWR(MA,IVAL,JVAL,MB) MB = MA ** (IVAL/JVAL) ! ZMSET(NPREC) Set precision to the equivalent of a few more than NPREC ! base 10 digits. This is now the same as FMSET, but is ! retained for compatibility with earlier versions of the ! package. ! ZMSIN(MA,MB) MB = SIN(MA) ! ZMSINH(MA,MB) MB = SINH(MA) ! ZMSQR(MA,MB) MB = MA*MA Faster than ZMMPY. ! ZMSQRT(MA,MB) MB = SQRT(MA) ! ZMST2M(STRING,MA) MA = STRING ! Convert from character string to ZM. ! Often more convenient than ZMINP, which ! converts an array of CHARACTER*1 values. ! Example: CALL ZMST2M('123.4+5.67i',MA). ! ZMSUB(MA,MB,MC) MC = MA - MB ! ZMTAN(MA,MB) MB = TAN(MA) ! ZMTANH(MA,MB) MB = TANH(MA) ! ZMWRIT(KWRITE,MA) Write MA on unit KWRITE. Multi-line numbers are ! formatted for automatic reading with ZMREAD. ! ZMZ2M(ZVAL,MA) MA = ZVAL ! 10. NEW FOR VERSION 1.2 ! Version 1.2 is written in Fortran-90 free source format. ! The routines for the Gamma function and related mathematical special ! functions are new in version 1.2. ! Several new derived-type function interfaces are included in module FMZM in ! file FMZM90.f90, such as integer multiple precision operations GCD, modular ! multiplication, and modular powers. There are also formatting functions and ! function interfaces for the Gamma and related special functions. ! Two new rounding modes have been added, round toward -infinity and round ! toward +infinity. See the description of KROUND above. ! An option has been added to force more guard digits to be used, so that basic ! arithmetic operations will always round perfectly. See the description of ! KRPERF above. ! These options are included for applications that use FM to check IEEE ! hardware arithmetic. They are not normally useful for most multiple ! precision calculations. ! The random number routine FM_RANDOM_NUMBER uses 49-digit prime numbers in a ! shuffled multiplicative congruential generator. Historically, some popular ! random number routines tried so hard for maximum speed that they were later ! found to fail some tests for randomness. FM_RANDOM_NUMBER tries to return ! high-quality random values. It is much slower than other generators, but can ! return about 60,000 numbers per second on a 400 MHz single-processor machine. ! This is usually fast enough to be used as a check for suspicious monte carlo ! results from other generators. ! For more details, see the comments in the routine. ! The arrays for multiple precision numbers were dimensioned starting at 0 in ! version 1.1, and now begin at -1. Array(-1) now holds the sign of the number ! instead of combining the sign with Array(2) as before. The reason for moving ! the sign bit is that many of the original routines, written before Fortran-90 ! existed, simplified the logic by temporarily making input arguments positive, ! working with positive values, then restoring the signs to the input arguments ! upon return. This became illegal under Fortran-90 when used with the derived ! type interface, which demands the inputs to functions for arithmetic operator ! overloading be declared with INTENT(IN). ! The common blocks of earlier versions have been replaced by module FMVALS. ! This makes it easier to hide the FM internal variable names from the calling ! program, and these variables can be initialized in the module so the ! initializing call to FMSET is no longer mandatory. Several new routines are ! provided to set or return the values for some of these variables. See the ! descriptions for FMSETVAR, FMFLAG, and FMVARS above. ! Version 1.0 used integer arrays and integer arithmetic internally to perform ! the multiple precision operations. Later versions use double precision ! arithmetic and arrays internally. This is usually faster at higher ! precisions, and on many machines it is also faster at lower precisions. ! Version 1.2 is written so that the arithmetic used can easily be changed from ! double precision to integer, or any other available arithmetic type. This ! permits the user to make the best use of a given machine's arithmetic ! hardware. See the EFFICIENCY discussion below. ! 11. EFFICIENCY ! When the derived type interface is used to access the FM routines, there may ! be a loss of speed if the arrays used to define the multiple precision data ! types are larger than necessary. See comment (b) in the section above on ! array dimensions. ! To take advantage of hardware architecture on different machines, the package ! has been designed so that the arithmetic used to perform the multiple ! precision operations can easily be changed. All variables that must be ! changed to get a different arithmetic have names beginning with 'M' and are ! declared using REAL (KIND(1.0D0)) ... ! For example, to change the package to use integer arithmetic internally, make ! these two changes everywhere in the FM.f90 file. ! Change 'REAL (KIND(1.0D0))' to 'INTEGER'. ! Change 'AINT (' to 'INT('. Note the blank between AINT and (. ! On some systems, changing 'AINT (' to '(' may give better speed. ! In most places in FM, an AINT function is not supposed to be changed. These ! are written 'AINT(', with no embedded blank, so they will not be changed by ! the global change above. ! The first of these changes must also be made throughout the files FMZM90.f90 ! and FMSAVE.f90. ! Change 'REAL (KIND(1.0D0))' to 'INTEGER'. ! Many of the variables in FMSAVE.f90 are initialized when they are declared, ! so the initialization values should be changed to integer values. ! Find the lines beginning '! Integer initialization' in file FMSAVE.f90 and ! change the values. The values needed for 32-bit integer arithmetic are next ! to the double precision values, but commented out. In every case, the line ! before the '! Integer initialization' should have '!' inserted in column 1 ! and the line after should have the '!' removed from column 1. If a different ! wordsize is used, the first call to FMSET will check the values defined in ! file FMSAVE.f90 and write messages (on unit KW) if any need to be changed. ! When changing to a different type of arithmetic, any FM arrays in the user's ! program must be changed to agree. If derived types are used instead of ! direct calls, no changes should be needed in the calling program. ! For example, in the test program TestFM.f90, change all ! 'REAL (KIND(1.0D0))' to 'INTEGER', as with the other files. ! This version of FM restricts the base used to be also representable in ! integer variables, so using precision above double usually does not save much ! time unless integers can also be declared at a higher precision. Using IEEE ! Extended would allow a base of around 10**9 to be chosen, but the delayed ! digit-normalization method used for multiplication and division means that a ! slightly smaller base like 10**8 would probably run faster. This would ! usually not be much faster than using the usual base 10**7 with double ! precision. ! The value of NBITS defined as a parameter in FMVALS refers to the number of ! bits used to represent integers in an M-variable word. Typical values for ! NBITS are: 24 for IEEE single precision, 32 for integer, 53 for IEEE double ! precision. NBITS controls only array size, so setting it too high is ok, but ! then the program will use slightly more memory than necessary. ! For cases where special compiler directives or minor re-writing of the code ! may improve speed, several of the most important loops in FM are identified ! by comments containing the string '(Inner Loop)'. ! ------------------------------------------------------------------------------ ! ------------------------------------------------------------------------------ SUBROUTINE FMSET(NPREC) ! Initialize the global FM variables that must be set before calling ! other FM routines. These variables are initialized to fairly standard ! values in the FMSAVE.f90 file (MODULE FMVALS), so calling FMSET at the ! beginning of a program is now optional. FMSET is a convenient way to set ! or change the precision being used, and it also checks to see that the ! generic values chosen for several machine-dependent variables are valid. ! Base and precision will be set to give at least NPREC+3 decimal ! digits of precision (giving the user three base ten guard digits). ! MBASE (base for FM arithmetic) is set to a large power of ten. ! JFORM1 and JFORM2 (default output format controls) are set to 1PE format ! displaying NPREC significant digits. ! Several FM options were set here in previous versions of the package, ! and are now initialized to their default values in module FMVALS. ! Here are the initial settings: ! The trace option is set off. ! The mode for angles in trig functions is set to radians. ! The rounding mode is set to symmetric rounding. ! Warning error message level is set to 1. ! Cancellation error monitor is set off. ! Screen width for output is set to 80 columns. ! The exponent character for FM output is set to 'M'. ! Debug error checking is set off. USE FMVALS IMPLICIT NONE INTEGER NPREC REAL (KIND(1.0D0)) :: MAXINT_CHK,MXEXP2_CHK,MEXPOV_CHK,MEXPUN_CHK, & MUNKNO_CHK DOUBLE PRECISION DPEPS_CHK,DPMAX_CHK,SPMAX_CHK,TEMP INTEGER INTMAX_CHK,K,NPSAVE IF (NBITS < DIGITS(MAXINT)) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' NBITS was set to ',NBITS,' in file FMSAVE.f90' WRITE (KW,*) ' For this machine it should be at least ',DIGITS(MAXINT) WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' ' WRITE (KW,*) ' NBITS is a parameter that controls array size, so its' WRITE (KW,*) ' value cannot be changed for this run, and this might' WRITE (KW,*) ' cause some FM operations to get incorrect results.' WRITE (KW,*) ' ' ENDIF ! MAXINT should be set to a very large integer, possibly ! the largest representable integer for the current ! machine. For most 32-bit machines, MAXINT is set ! to 2**53 - 1 = 9.007D+15 when double precision ! arithmetic is used for M-variables. Using integer ! M-variables usually gives MAXINT = 2**31 - 1 = ! 2147483647. ! Setting MAXINT to a smaller number is ok, but this ! unnecessarily restricts the permissible range of ! MBASE and MXEXP. MAXINT_CHK = RADIX(MAXINT_CHK) MAXINT_CHK = ((MAXINT_CHK**(DIGITS(MAXINT_CHK)-1)-1)*MAXINT_CHK - 1) + & MAXINT_CHK IF (MAXINT > MAXINT_CHK) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' MAXINT was set to ',MAXINT,' in file FMSAVE.f90' WRITE (KW,*) ' For this machine it should be no more than ',MAXINT_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, MAXINT has been changed to ',MAXINT_CHK WRITE (KW,*) ' ' MAXINT = MAXINT_CHK ELSE IF (MAXINT < MAXINT_CHK/2) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' MAXINT was set to ',MAXINT,' in file FMSAVE.f90' WRITE (KW,*) ' For better performance set it to ',MAXINT_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, MAXINT has been changed to ',MAXINT_CHK WRITE (KW,*) ' ' MAXINT = MAXINT_CHK ENDIF ! INTMAX is a large value close to the overflow threshold ! for integer variables. It is usually 2**31 - 1 ! for machines with 32-bit integer arithmetic. ! The following code sets INTMAX_CHK to the ! largest representable integer. ! Then INTMAX is checked against this value. INTMAX_CHK = HUGE(1) IF (INTMAX > INTMAX_CHK) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' INTMAX was set to ',INTMAX,' in file FMSAVE.f90' WRITE (KW,*) ' For this machine it should be no more than ',INTMAX_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, INTMAX has been changed to ',INTMAX_CHK WRITE (KW,*) ' ' INTMAX = INTMAX_CHK ELSE IF (INTMAX < INTMAX_CHK/2) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' INTMAX was set to ',INTMAX,' in file FMSAVE.f90' WRITE (KW,*) ' For better performance set it to ',INTMAX_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, INTMAX has been changed to ',INTMAX_CHK WRITE (KW,*) ' ' INTMAX = INTMAX_CHK ENDIF ! DPMAX should be set to a value near the machine's double ! precision overflow threshold, so that DPMAX and ! 1.0D0/DPMAX are both representable in double ! precision. DPMAX_CHK = HUGE(1.0D0)/5 IF (DPMAX > DPMAX_CHK) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' DPMAX was set to ',DPMAX,' in file FMSAVE.f90' WRITE (KW,*) ' For this machine it should be no more than ',DPMAX_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, DPMAX has been changed to ',DPMAX_CHK WRITE (KW,*) ' ' DPMAX = DPMAX_CHK ELSE IF (DPMAX < DPMAX_CHK/1.0D2) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' DPMAX was set to ',DPMAX,' in file FMSAVE.f90' WRITE (KW,*) ' For better performance set it to ',DPMAX_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, DPMAX has been changed to ',DPMAX_CHK WRITE (KW,*) ' ' DPMAX = DPMAX_CHK ENDIF ! SPMAX should be set to a value near the machine's single ! precision overflow threshold, so that 1.01*SPMAX ! and 1.0/SPMAX are both representable in single ! precision. SPMAX_CHK = HUGE(1.0)/5 IF (SPMAX > SPMAX_CHK) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' SPMAX was set to ',SPMAX,' in file FMSAVE.f90' WRITE (KW,*) ' For this machine it should be no more than ',SPMAX_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, SPMAX has been changed to ',SPMAX_CHK WRITE (KW,*) ' ' SPMAX = SPMAX_CHK ELSE IF (SPMAX < SPMAX_CHK/1.0D2) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' SPMAX was set to ',SPMAX,' in file FMSAVE.f90' WRITE (KW,*) ' For better performance set it to ',SPMAX_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, SPMAX has been changed to ',SPMAX_CHK WRITE (KW,*) ' ' SPMAX = SPMAX_CHK ENDIF ! MXBASE is the maximum value for MBASE. TEMP = MAXINT TEMP = INT(MIN(DBLE(INTMAX),SQRT(TEMP))) IF (MXBASE > TEMP) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' MXBASE was set to ',MXBASE,' in file FMSAVE.f90' WRITE (KW,*) ' For this machine it should be no more than ',TEMP WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, MXBASE has been changed to ',TEMP WRITE (KW,*) ' ' MXBASE = TEMP ELSE IF (MXBASE < TEMP/2) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' MXBASE was set to ',MXBASE,' in file FMSAVE.f90' WRITE (KW,*) ' For better performance set it to ',TEMP WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, MXBASE has been changed to ',TEMP WRITE (KW,*) ' ' MXBASE = TEMP ENDIF ! MBASE is the currently used base for arithmetic. K = INT(LOG10(DBLE(MXBASE)/4)) MBASE = 10**K ! NDIG is the number of digits currently being carried. NPSAVE = NPREC NDIG = 2 + (NPREC+2)/K IF (NDIG < 2 .OR. NDIG > NDIGMX) THEN NDIG = MAX(2,NDIG) NDIG = MIN(NDIGMX,NDIG) WRITE (KW, & "(//' Precision out of range when calling FMSET.'," // & "' NPREC =',I20/' The nearest valid NDIG will be'," // & "' used instead: NDIG =',I6//)" & ) NPREC,NDIG NPSAVE = 0 ENDIF ! NCALL is the call stack pointer. NCALL = 0 ! MXEXP is the current maximum exponent. ! MXEXP2 is the internal maximum exponent. This is used to ! define the overflow and underflow thresholds. ! These values are chosen so that FM routines can raise the ! overflow/underflow limit temporarily while computing ! intermediate results, and so that EXP(INTMAX) is greater ! than MXBASE**(MXEXP2+1). ! The overflow threshold is MBASE**(MXEXP+1), and the ! underflow threshold is MBASE**(-MXEXP-1). ! This means the valid exponents in the first word of an FM ! number can range from -MXEXP to MXEXP+1 (inclusive). MXEXP = INT((DBLE(INTMAX))/(2.0D0*LOG(DBLE(MXBASE))) - 1.0D0) MXEXP2_CHK = INT(2*MXEXP + MXEXP/100) IF (MXEXP2 > MXEXP2_CHK*1.01) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' MXEXP2 was set to ',MXEXP2,' in file FMSAVE.f90' WRITE (KW,*) ' For this machine it should be no more than ',MXEXP2_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, MXEXP2 has been changed to ',MXEXP2_CHK WRITE (KW,*) ' ' MXEXP2 = MXEXP2_CHK ELSE IF (MXEXP2 < MXEXP2_CHK*0.99) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' MXEXP2 was set to ',MXEXP2,' in file FMSAVE.f90' WRITE (KW,*) ' For this machine it should be no less than ',MXEXP2_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, MXEXP2 has been changed to ',MXEXP2_CHK WRITE (KW,*) ' ' MXEXP2 = MXEXP2_CHK ENDIF ! KACCSW is a switch used to enable cancellation error ! monitoring. Routines where cancellation is ! not a problem run faster by skipping the ! cancellation monitor calculations. ! KACCSW = 0 means no error monitoring, ! = 1 means error monitoring is done. KACCSW = 0 ! MEXPUN is the exponent used as a special symbol for ! underflowed results. MEXPUN_CHK = -AINT(MXEXP2*1.01D0) IF (MEXPUN < MEXPUN_CHK*1.01) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' MEXPUN was set to ',MEXPUN,' in file FMSAVE.f90' WRITE (KW,*) ' For this machine it should be no less than ',MEXPUN_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, MEXPUN has been changed to ',MEXPUN_CHK WRITE (KW,*) ' ' MEXPUN = MEXPUN_CHK ELSE IF (MEXPUN > MEXPUN_CHK) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' MEXPUN was set to ',MEXPUN,' in file FMSAVE.f90' WRITE (KW,*) ' For this machine it should be no more than ',MEXPUN_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, MEXPUN has been changed to ',MEXPUN_CHK WRITE (KW,*) ' ' MEXPUN = MEXPUN_CHK ENDIF ! MEXPOV is the exponent used as a special symbol for ! overflowed results. MEXPOV_CHK = -MEXPUN IF (MEXPOV /= MEXPOV_CHK) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' MEXPOV was set to ',MEXPOV,' in file FMSAVE.f90' WRITE (KW,*) ' For this machine it should be ',MEXPOV_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, MEXPOV has been changed to ',MEXPOV_CHK WRITE (KW,*) ' ' MEXPOV = MEXPOV_CHK ENDIF ! MUNKNO is the exponent used as a special symbol for ! unknown FM results (1/0, SQRT(-3.0), ...). MUNKNO_CHK = AINT(MEXPOV*1.01D0) IF (MUNKNO > MUNKNO_CHK*1.01) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' MUNKNO was set to ',MUNKNO,' in file FMSAVE.f90' WRITE (KW,*) ' For this machine it should be no more than ',MUNKNO_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, MUNKNO has been changed to ',MUNKNO_CHK WRITE (KW,*) ' ' MUNKNO = MUNKNO_CHK ELSE IF (MUNKNO < MUNKNO_CHK) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' MUNKNO was set to ',MUNKNO,' in file FMSAVE.f90' WRITE (KW,*) ' For this machine it should be no less than ',MUNKNO_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, MUNKNO has been changed to ',MUNKNO_CHK WRITE (KW,*) ' ' MUNKNO = MUNKNO_CHK ENDIF ! RUNKNO is returned from FM to real or double conversion ! routines when no valid result can be expressed in ! real or double precision. On systems that provide ! a value for undefined results (e.g., Not A Number) ! setting RUNKNO to that value is reasonable. On ! other systems set it to a value that is likely to ! make any subsequent results obviously wrong that ! use it. In either case a KFLAG = -4 condition is ! also returned. RUNKNO = -1.01*SPMAX ! IUNKNO is returned from FM to integer conversion routines ! when no valid result can be expressed as a one word ! integer. KFLAG = -4 is also set. IUNKNO = -INT(MXEXP2) ! DPEPS is the approximate machine precision. DPEPS_CHK = EPSILON(1.0D0) IF (DPEPS > DPEPS_CHK*1.01) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' DPEPS was set to ',DPEPS,' in file FMSAVE.f90' WRITE (KW,*) ' For this machine it should be no more than ',DPEPS_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, DPEPS has been changed to ',DPEPS_CHK WRITE (KW,*) ' ' DPEPS = DPEPS_CHK ELSE IF (DPEPS < DPEPS_CHK*0.99) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' In routine FMSET it appears that FM internal variable' WRITE (KW,*) ' DPEPS was set to ',DPEPS,' in file FMSAVE.f90' WRITE (KW,*) ' For this machine it should be no less than ',DPEPS_CHK WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.' WRITE (KW,*) ' For this run, DPEPS has been changed to ',DPEPS_CHK WRITE (KW,*) ' ' DPEPS = DPEPS_CHK ENDIF ! JFORM1 indicates the format used by FMOUT. JFORM1 = 1 ! JFORM2 indicates the number of digits used in FMOUT. JFORM2 = NPSAVE ! Set JFORMZ to ' 1.23 + 4.56 i ' format. JFORMZ = 1 ! Set JPRNTZ to print real and imaginary parts on one ! line whenever possible. JPRNTZ = 1 ! Initialize two hash tables that are used for character ! look-up during input conversion. CALL FMHTBL ! FMCONS sets several real and double precision constants. CALL FMCONS RETURN END SUBROUTINE FMSET SUBROUTINE FMABS(MA,MB) ! MB = ABS(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MD2B INTEGER KWRNSV NCALL = NCALL + 1 NAMEST(NCALL) = 'FMABS ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KFLAG = 0 KWRNSV = KWARN KWARN = 0 CALL FMEQ(MA,MB) MB(-1) = 1 KWARN = KWRNSV IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MD2B) ENDIF IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMABS SUBROUTINE FMACOS(MA,MB) ! MB = ACOS(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE INTEGER J,K,KASAVE,KOVUN,KRESLT,NDSAVE IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB .OR. MA(1) > 0 .OR. MA(2) == 0) THEN CALL FMENTR('FMACOS',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMACOS' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF MAS = MA(-1) MACCA = MA(0) CALL FMEQ2(MA,MB,NDSAVE,NDIG) MB(0) = NINT(NDIG*ALOGM2) ! Use ACOS(X) = ATAN(SQRT(1-X*X)/X) MB(-1) = 1 CALL FMI2M(1,M05) CALL FMSUB(M05,MB,M03) CALL FMADD(M05,MB,M04) CALL FMMPY_R2(M03,M04) CALL FMSQRT_R1(M04) CALL FMDIV_R2(M04,MB) CALL FMATAN(MB,M13) CALL FMEQ(M13,MB) IF (MAS < 0) THEN IF (KRAD == 1) THEN CALL FMPI(M05) ELSE CALL FMI2M(180,M05) ENDIF CALL FMSUB_R2(M05,MB) ENDIF ! Round the result and return. MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MACCA,MACMAX) DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMACOS SUBROUTINE FMADD(MA,MB,MC) ! MC = MA + MB ! This routine performs the trace printing for addition. ! FMADD2 is used to do the arithmetic. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMADD ' CALL FMNTR(2,MA,MB,2,1) CALL FMADD2(MA,MB,MC) CALL FMNTR(1,MC,MC,1,1) ELSE CALL FMADD2(MA,MB,MC) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMADD SUBROUTINE FMADD2(MA,MB,MC) ! Internal addition routine. MC = MA + MB USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) REAL (KIND(1.0D0)) :: MA0,MA1,MA2,MAS,MB0,MB1,MB2,MB2RD,MBS INTEGER J,JCOMP,JRSSAV,JSIGN,KRESLT,N1,NGUARD,NMWA REAL B2RDA,B2RDB IF (MBLOGS /= MBASE) CALL FMCONS JRSSAV = JRSIGN MA2 = MA(2) MB2 = MB(2) IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. & KDEBUG == 1) THEN IF (KSUB == 1) THEN CALL FMARGS('FMSUB ',2,MA,MB,KRESLT) ELSE CALL FMARGS('FMADD ',2,MA,MB,KRESLT) ENDIF IF (KRESLT /= 0) THEN IF ((KRESLT /= 1 .AND. KRESLT /= 2) .OR. MA(2) == 0 .OR. & MB(2) == 0) THEN NCALL = NCALL + 1 IF (KSUB == 1) THEN NAMEST(NCALL) = 'FMSUB ' ELSE NAMEST(NCALL) = 'FMADD ' ENDIF CALL FMRSLT(MA,MB,MC,KRESLT) JRSIGN = JRSSAV NCALL = NCALL - 1 RETURN ENDIF ENDIF ELSE IF (MA(2) == 0) THEN MA0 = MIN(MA(0),MB(0)) CALL FMEQ(MB,MC) MC(0) = MA0 KFLAG = 1 IF (KSUB == 1) THEN IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1) KFLAG = 0 ENDIF JRSIGN = JRSSAV RETURN ENDIF IF (MB(2) == 0) THEN MA0 = MIN(MA(0),MB(0)) CALL FMEQ(MA,MC) MC(0) = MA0 KFLAG = 1 JRSIGN = JRSSAV RETURN ENDIF ENDIF MA0 = MA(0) IF (KACCSW == 1) THEN MB0 = MB(0) MA1 = MA(1) MB1 = MB(1) ENDIF KFLAG = 0 N1 = NDIG + 1 ! NGUARD is the number of guard digits used. IF (NCALL > 1) THEN NGUARD = NGRD21 IF (NGUARD > NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 IF (NGUARD > NDIG) NGUARD = NDIG IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 10 ENDIF ENDIF NMWA = N1 + NGUARD ! Save the signs of MA and MB and then work with ! positive numbers. ! JSIGN is the sign of the result of MA + MB. JSIGN = 1 MAS = MA(-1) MBS = MB(-1) IF (KSUB == 1) MBS = -MBS ! See which one is larger in absolute value. JCOMP = 2 IF (MA(1) > MB(1)) THEN JCOMP = 1 ELSE IF (MB(1) > MA(1)) THEN JCOMP = 3 ELSE DO J = 2, N1 IF (MA(J) > MB(J)) THEN JCOMP = 1 EXIT ENDIF IF (MB(J) > MA(J)) THEN JCOMP = 3 EXIT ENDIF ENDDO ENDIF IF (JCOMP < 3) THEN IF (MAS < 0) JSIGN = -1 JRSIGN = JSIGN IF (MAS*MBS > 0) THEN CALL FMADDP(MA,MB,NGUARD,NMWA) ELSE CALL FMADDN(MA,MB,NGUARD,NMWA) ENDIF ELSE IF (MBS < 0) JSIGN = -1 JRSIGN = JSIGN IF (MAS*MBS > 0) THEN CALL FMADDP(MB,MA,NGUARD,NMWA) ELSE CALL FMADDN(MB,MA,NGUARD,NMWA) ENDIF ENDIF ! Transfer to MC and fix the sign of the result. CALL FMMOVE(MWA,MC) MC(-1) = 1 IF (JSIGN < 0 .AND. MC(2) /= 0) MC(-1) = -1 IF (KFLAG < 0) THEN IF (KSUB == 1) THEN NAMEST(NCALL) = 'FMSUB ' ELSE NAMEST(NCALL) = 'FMADD ' ENDIF CALL FMWARN ENDIF IF (KACCSW == 1) THEN B2RDA = LOG(REAL(ABS(MC(2))+1)/REAL(ABS(MA2)+1))/0.69315 + & REAL(MC(1)-MA1)*ALOGM2 + REAL(MA0) B2RDB = LOG(REAL(ABS(MC(2))+1)/REAL(ABS(MB2)+1))/0.69315 + & REAL(MC(1)-MB1)*ALOGM2 + REAL(MB0) MB2RD = NINT(MAX(0.0,MIN(B2RDA,B2RDB, & (NDIG-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315))) IF (MC(2) == 0) THEN MC(0) = 0 ELSE MC(0) = MIN(MAX(MA0,MB0),MB2RD) ENDIF ELSE MC(0) = MA0 ENDIF JRSIGN = JRSSAV RETURN END SUBROUTINE FMADD2 SUBROUTINE FMADD_R1(MA,MB) ! MA = MA + MB ! This routine performs the trace printing for addition. ! FMADD2_R1 is used to do the arithmetic. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMADD ' CALL FMNTR(2,MA,MB,2,1) CALL FMADD2_R1(MA,MB) CALL FMNTR(1,MA,MA,1,1) ELSE CALL FMADD2_R1(MA,MB) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMADD_R1 SUBROUTINE FMADD2_R1(MA,MB) ! Internal addition routine. MA = MA + MB USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MA0,MA1,MA2,MAS,MB0,MB1,MB2,MB2RD,MBS INTEGER J,JCOMP,JRSSAV,JSIGN,KRESLT,N1,NGUARD,NMWA REAL B2RDA,B2RDB IF (MBLOGS /= MBASE) CALL FMCONS JRSSAV = JRSIGN MA2 = MA(2) MB2 = MB(2) IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. & KDEBUG == 1) THEN IF (KSUB == 1) THEN CALL FMARGS('FMSUB ',2,MA,MB,KRESLT) ELSE CALL FMARGS('FMADD ',2,MA,MB,KRESLT) ENDIF IF (KRESLT /= 0) THEN IF ((KRESLT /= 1 .AND. KRESLT /= 2) .OR. MA(2) == 0 .OR. & MB(2) == 0) THEN NCALL = NCALL + 1 IF (KSUB == 1) THEN NAMEST(NCALL) = 'FMSUB ' ELSE NAMEST(NCALL) = 'FMADD ' ENDIF CALL FMRSLT(MA,MB,M07,KRESLT) CALL FMEQ(M07,MA) JRSIGN = JRSSAV NCALL = NCALL - 1 RETURN ENDIF ENDIF ELSE IF (MA(2) == 0) THEN MA0 = MIN(MA(0),MB(0)) CALL FMEQ(MB,MA) MA(0) = MA0 KFLAG = 1 IF (KSUB == 1) THEN IF (MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -MA(-1) KFLAG = 0 ENDIF JRSIGN = JRSSAV RETURN ENDIF IF (MB(2) == 0) THEN MA0 = MIN(MA(0),MB(0)) MA(0) = MA0 KFLAG = 1 JRSIGN = JRSSAV RETURN ENDIF ENDIF MA0 = MA(0) IF (KACCSW == 1) THEN MB0 = MB(0) MA1 = MA(1) MB1 = MB(1) ENDIF KFLAG = 0 N1 = NDIG + 1 ! NGUARD is the number of guard digits used. IF (NCALL > 1) THEN NGUARD = NGRD21 IF (NGUARD > NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 IF (NGUARD > NDIG) NGUARD = NDIG IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 10 ENDIF ENDIF NMWA = N1 + NGUARD ! Save the signs of MA and MB and then work with ! positive numbers. ! JSIGN is the sign of the result of MA + MB. JSIGN = 1 MAS = MA(-1) MBS = MB(-1) IF (KSUB == 1) MBS = -MBS ! See which one is larger in absolute value. JCOMP = 2 IF (MA(1) > MB(1)) THEN JCOMP = 1 ELSE IF (MB(1) > MA(1)) THEN JCOMP = 3 ELSE DO J = 2, N1 IF (MA(J) > MB(J)) THEN JCOMP = 1 EXIT ENDIF IF (MB(J) > MA(J)) THEN JCOMP = 3 EXIT ENDIF ENDDO ENDIF IF (JCOMP < 3) THEN IF (MAS < 0) JSIGN = -1 JRSIGN = JSIGN IF (MAS*MBS > 0) THEN CALL FMADDP(MA,MB,NGUARD,NMWA) ELSE CALL FMADDN(MA,MB,NGUARD,NMWA) ENDIF ELSE IF (MBS < 0) JSIGN = -1 JRSIGN = JSIGN IF (MAS*MBS > 0) THEN CALL FMADDP(MB,MA,NGUARD,NMWA) ELSE CALL FMADDN(MB,MA,NGUARD,NMWA) ENDIF ENDIF ! Transfer to MA and fix the sign of the result. CALL FMMOVE(MWA,MA) MA(-1) = 1 IF (JSIGN < 0 .AND. MA(2) /= 0) MA(-1) = -1 IF (KFLAG < 0) THEN IF (KSUB == 1) THEN NAMEST(NCALL) = 'FMSUB ' ELSE NAMEST(NCALL) = 'FMADD ' ENDIF CALL FMWARN ENDIF IF (KACCSW == 1) THEN B2RDA = LOG(REAL(ABS(MA(2))+1)/REAL(ABS(MA2)+1))/0.69315 + & REAL(MA(1)-MA1)*ALOGM2 + REAL(MA0) B2RDB = LOG(REAL(ABS(MA(2))+1)/REAL(ABS(MB2)+1))/0.69315 + & REAL(MA(1)-MB1)*ALOGM2 + REAL(MB0) MB2RD = NINT(MAX(0.0,MIN(B2RDA,B2RDB, & (NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315))) IF (MA(2) == 0) THEN MA(0) = 0 ELSE MA(0) = MIN(MAX(MA0,MB0),MB2RD) ENDIF ELSE MA(0) = MA0 ENDIF JRSIGN = JRSSAV RETURN END SUBROUTINE FMADD2_R1 SUBROUTINE FMADD_R2(MA,MB) ! MB = MA + MB ! This routine performs the trace printing for addition. ! FMADD2_R2 is used to do the arithmetic. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMADD ' CALL FMNTR(2,MA,MB,2,1) CALL FMADD2_R2(MA,MB) CALL FMNTR(1,MB,MB,1,1) ELSE CALL FMADD2_R2(MA,MB) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMADD_R2 SUBROUTINE FMADD2_R2(MA,MB) ! Internal addition routine. MB = MA + MB USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MA0,MA1,MA2,MAS,MB0,MB1,MB2,MB2RD,MBS INTEGER J,JCOMP,JRSSAV,JSIGN,KRESLT,N1,NGUARD,NMWA REAL B2RDA,B2RDB IF (MBLOGS /= MBASE) CALL FMCONS JRSSAV = JRSIGN MA2 = MA(2) MB2 = MB(2) IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. & KDEBUG == 1) THEN IF (KSUB == 1) THEN CALL FMARGS('FMSUB ',2,MA,MB,KRESLT) ELSE CALL FMARGS('FMADD ',2,MA,MB,KRESLT) ENDIF IF (KRESLT /= 0) THEN IF ((KRESLT /= 1 .AND. KRESLT /= 2) .OR. MA(2) == 0 .OR. & MB(2) == 0) THEN NCALL = NCALL + 1 IF (KSUB == 1) THEN NAMEST(NCALL) = 'FMSUB ' ELSE NAMEST(NCALL) = 'FMADD ' ENDIF CALL FMRSLT(MA,MB,M07,KRESLT) CALL FMEQ(M07,MB) JRSIGN = JRSSAV NCALL = NCALL - 1 RETURN ENDIF ENDIF ELSE IF (MA(2) == 0) THEN MA0 = MIN(MA(0),MB(0)) MB(0) = MA0 KFLAG = 1 IF (KSUB == 1) THEN IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1) KFLAG = 0 ENDIF JRSIGN = JRSSAV RETURN ENDIF IF (MB(2) == 0) THEN MA0 = MIN(MA(0),MB(0)) CALL FMEQ(MA,MB) MB(0) = MA0 KFLAG = 1 JRSIGN = JRSSAV RETURN ENDIF ENDIF MA0 = MA(0) IF (KACCSW == 1) THEN MB0 = MB(0) MA1 = MA(1) MB1 = MB(1) ENDIF KFLAG = 0 N1 = NDIG + 1 ! NGUARD is the number of guard digits used. IF (NCALL > 1) THEN NGUARD = NGRD21 IF (NGUARD > NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 IF (NGUARD > NDIG) NGUARD = NDIG IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 10 ENDIF ENDIF NMWA = N1 + NGUARD ! Save the signs of MA and MB and then work with ! positive numbers. ! JSIGN is the sign of the result of MA + MB. JSIGN = 1 MAS = MA(-1) MBS = MB(-1) IF (KSUB == 1) MBS = -MBS ! See which one is larger in absolute value. JCOMP = 2 IF (MA(1) > MB(1)) THEN JCOMP = 1 ELSE IF (MB(1) > MA(1)) THEN JCOMP = 3 ELSE DO J = 2, N1 IF (MA(J) > MB(J)) THEN JCOMP = 1 EXIT ENDIF IF (MB(J) > MA(J)) THEN JCOMP = 3 EXIT ENDIF ENDDO ENDIF IF (JCOMP < 3) THEN IF (MAS < 0) JSIGN = -1 JRSIGN = JSIGN IF (MAS*MBS > 0) THEN CALL FMADDP(MA,MB,NGUARD,NMWA) ELSE CALL FMADDN(MA,MB,NGUARD,NMWA) ENDIF ELSE IF (MBS < 0) JSIGN = -1 JRSIGN = JSIGN IF (MAS*MBS > 0) THEN CALL FMADDP(MB,MA,NGUARD,NMWA) ELSE CALL FMADDN(MB,MA,NGUARD,NMWA) ENDIF ENDIF ! Transfer to MB and fix the sign of the result. CALL FMMOVE(MWA,MB) MB(-1) = 1 IF (JSIGN < 0 .AND. MB(2) /= 0) MB(-1) = -1 IF (KFLAG < 0) THEN IF (KSUB == 1) THEN NAMEST(NCALL) = 'FMSUB ' ELSE NAMEST(NCALL) = 'FMADD ' ENDIF CALL FMWARN ENDIF IF (KACCSW == 1) THEN B2RDA = LOG(REAL(ABS(MB(2))+1)/REAL(ABS(MA2)+1))/0.69315 + & REAL(MB(1)-MA1)*ALOGM2 + REAL(MA0) B2RDB = LOG(REAL(ABS(MB(2))+1)/REAL(ABS(MB2)+1))/0.69315 + & REAL(MB(1)-MB1)*ALOGM2 + REAL(MB0) MB2RD = NINT(MAX(0.0,MIN(B2RDA,B2RDB, & (NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315))) IF (MB(2) == 0) THEN MB(0) = 0 ELSE MB(0) = MIN(MAX(MA0,MB0),MB2RD) ENDIF ELSE MB(0) = MA0 ENDIF JRSIGN = JRSSAV RETURN END SUBROUTINE FMADD2_R2 SUBROUTINE FMADDI(MA,IVAL) ! MA = MA + IVAL ! Increment MA by one word integer IVAL. ! This routine is faster than FMADD when IVAL is small enough so ! that it can be added to a single word of MA without often causing ! a carry. Otherwise FMI2M and FMADD are used. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER IVAL REAL (KIND(1.0D0)) :: MAEXP,MD2B,MKSUM INTEGER KPTMA NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMADDI' CALL FMNTR(2,MA,MA,1,1) CALL FMNTRI(2,IVAL,0) ENDIF KFLAG = 0 MAEXP = MA(1) IF (MAEXP <= 0 .OR. MAEXP > NDIG) GO TO 110 KPTMA = INT(MAEXP) + 1 IF (KPTMA > 2 .AND. MA(-1) < 0) THEN MKSUM = MA(KPTMA) - IVAL ELSE MKSUM = MA(KPTMA) + IVAL ENDIF IF (MKSUM >= MBASE .OR. MKSUM <= (-MBASE)) GO TO 110 IF (MA(-1) < 0) THEN IF (KPTMA > 2) THEN IF (MKSUM >= 0) THEN MA(KPTMA) = MKSUM GO TO 120 ELSE GO TO 110 ENDIF ELSE IF (MKSUM < 0) THEN MA(KPTMA) = MKSUM GO TO 120 ELSE GO TO 110 ENDIF ENDIF ELSE IF (KPTMA > 2) THEN IF (MKSUM >= 0) THEN MA(KPTMA) = MKSUM GO TO 120 ELSE GO TO 110 ENDIF ELSE IF (MKSUM > 0) THEN MA(KPTMA) = MKSUM GO TO 120 ELSE GO TO 110 ENDIF ENDIF ENDIF 110 CALL FMI2M(IVAL,M01) CALL FMADD2_R1(MA,M01) 120 IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315) MA(0) = MIN(MA(0),MD2B) ENDIF IF (NTRACE /= 0) THEN CALL FMNTR(1,MA,MA,1,1) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMADDI SUBROUTINE FMADDN(MA,MB,NGUARD,NMWA) ! Internal addition routine. MWA = MA - MB ! The arguments are such that MA >= MB >= 0. ! NGUARD is the number of guard digits being carried. ! NMWA is the number of words in MWA that will be used. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER NGUARD,NMWA REAL (KIND(1.0D0)) :: MK,MR INTEGER J,K,KL,KP1,KP2,KPT,KSH,N1,N2,NK,NK1 N1 = NDIG + 1 ! Check for an insignificant operand. MK = MA(1) - MB(1) IF (MK >= NDIG+2) THEN DO J = 1, N1 MWA(J) = MA(J) ENDDO MWA(N1+1) = 0 IF (KROUND == 0 .OR. (KROUND == 2 .AND. JRSIGN == -1) .OR. & (KROUND == -1 .AND. JRSIGN == 1)) THEN MWA(N1) = MWA(N1) - 1 GO TO 120 ENDIF KFLAG = 1 RETURN ENDIF K = INT(MK) IF (NGUARD <= 1) NMWA = N1 + 2 ! Subtract MB from MA. KP1 = MIN(N1,K+1) MWA(K+1) = 0 DO J = 1, KP1 MWA(J) = MA(J) ENDDO KP2 = K + 2 ! (Inner Loop) DO J = KP2, N1 MWA(J) = MA(J) - MB(J-K) ENDDO N2 = NDIG + 2 IF (N2-K <= 1) N2 = 2 + K NK = MIN(NMWA,N1+K) DO J = N2, NK MWA(J) = -MB(J-K) ENDDO NK1 = NK + 1 DO J = NK1, NMWA MWA(J) = 0 ENDDO ! Normalize. Fix the sign of any negative digit. IF (K > 0) THEN DO J = NMWA, KP2, -1 IF (MWA(J) < 0) THEN MWA(J) = MWA(J) + MBASE MWA(J-1) = MWA(J-1) - 1 ENDIF ENDDO KPT = KP2 - 1 110 IF (MWA(KPT) < 0 .AND. KPT >= 3) THEN MWA(KPT) = MWA(KPT) + MBASE MWA(KPT-1) = MWA(KPT-1) - 1 KPT = KPT - 1 GO TO 110 ENDIF GO TO 130 ENDIF 120 DO J = N1, 3, -1 IF (MWA(J) < 0) THEN MWA(J) = MWA(J) + MBASE MWA(J-1) = MWA(J-1) - 1 ENDIF ENDDO ! Shift left if there are any leading zeros in the mantissa. 130 DO J = 2, NMWA IF (MWA(J) > 0) THEN KSH = J - 2 GO TO 140 ENDIF ENDDO MWA(1) = 0 RETURN 140 IF (KSH > 0) THEN KL = NMWA - KSH DO J = 2, KL MWA(J) = MWA(J+KSH) ENDDO DO J = KL+1, NMWA MWA(J) = 0 ENDDO MWA(1) = MWA(1) - KSH IF (MK >= NDIG+2) THEN MWA(N1) = MBASE - 1 ENDIF ENDIF ! Round the result. MR = 2*MWA(NDIG+2) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,0) ELSE IF (MR >= MBASE) THEN IF (MR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1) = MWA(N1) + 1 MWA(N1+1) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,0) ENDIF ENDIF ! See if the result is equal to one of the input arguments. IF (ABS(MA(1)-MB(1)) < NDIG) GO TO 150 IF (ABS(MA(1)-MB(1)) > NDIG+1) THEN KFLAG = 1 GO TO 150 ENDIF N2 = NDIG + 4 DO J = 3, N1 IF (MWA(N2-J) /= MA(N2-J)) GO TO 150 ENDDO IF (MWA(1) /= MA(1)) GO TO 150 IF (MWA(2) /= ABS(MA(2))) GO TO 150 KFLAG = 1 150 RETURN END SUBROUTINE FMADDN SUBROUTINE FMADDP(MA,MB,NGUARD,NMWA) ! Internal addition routine. MWA = MA + MB ! The arguments are such that MA >= MB >= 0. ! NMWA is the number of words in MWA that will be used. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER NGUARD,NMWA REAL (KIND(1.0D0)) :: MK,MKT,MR INTEGER J,K,KP,KP2,KPT,KSHIFT,N1,N2,NK N1 = NDIG + 1 ! Check for an insignificant operand. MK = MA(1) - MB(1) IF (MK >= NDIG+1) THEN MWA(1) = MA(1) + 1 MWA(2) = 0 DO J = 2, N1 MWA(J+1) = MA(J) ENDDO MWA(N1+2) = 0 IF ((KROUND == 2 .AND. JRSIGN == 1) .OR. & (KROUND == -1 .AND. JRSIGN == -1)) THEN MWA(N1+2) = 1 GO TO 120 ENDIF KFLAG = 1 RETURN ENDIF K = INT(MK) ! Add MA and MB. MWA(1) = MA(1) + 1 MWA(2) = 0 DO J = 2, K+1 MWA(J+1) = MA(J) ENDDO KP2 = K + 2 ! (Inner Loop) DO J = KP2, N1 MWA(J+1) = MA(J) + MB(J-K) ENDDO N2 = NDIG + 2 NK = MIN(NMWA,N1+K) DO J = N2, NK MWA(J+1) = MB(J-K) ENDDO DO J = NK+1, NMWA MWA(J+1) = 0 ENDDO ! Normalize. Fix any digit not less than MBASE. IF (K == NDIG) GO TO 140 IF (K > 0) THEN DO J = N1+1, KP2, -1 IF (MWA(J) >= MBASE) THEN MWA(J) = MWA(J) - MBASE MWA(J-1) = MWA(J-1) + 1 ENDIF ENDDO KPT = KP2 - 1 110 IF (MWA(KPT) >= MBASE .AND. KPT >= 3) THEN MWA(KPT) = MWA(KPT) - MBASE MWA(KPT-1) = MWA(KPT-1) + 1 KPT = KPT - 1 GO TO 110 ENDIF GO TO 120 ENDIF DO J = N1+1, 3, -1 IF (MWA(J) >= MBASE) THEN MWA(J) = MWA(J) - MBASE MWA(J-1) = MWA(J-1) + 1 ENDIF ENDDO ! Shift right if the leading digit is not less than MBASE. 120 IF (MWA(2) >= MBASE) THEN 130 KP = NMWA + 4 DO J = 4, NMWA MWA(KP-J) = MWA(KP-J-1) ENDDO MKT = AINT (MWA(2)/MBASE) MWA(3) = MWA(2) - MKT*MBASE MWA(2) = MKT MWA(1) = MWA(1) + 1 IF (MWA(2) >= MBASE) GO TO 130 ENDIF ! Round the result. 140 KSHIFT = 0 IF (MWA(2) == 0) KSHIFT = 1 MR = 2*MWA(NDIG+2+KSHIFT) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ELSE IF (MR >= MBASE) THEN IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1 MWA(N1+1+KSHIFT) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ENDIF ENDIF ! See if the result is equal to one of the input arguments. IF (ABS(MA(1)-MB(1)) < NDIG) GO TO 150 IF (KSHIFT == 0) GO TO 150 IF (ABS(MA(1)-MB(1)) > NDIG+1) THEN KFLAG = 1 GO TO 150 ENDIF N2 = NDIG + 4 DO J = 3, N1 IF (MWA(N2-J+1) /= MA(N2-J)) GO TO 150 ENDDO IF (MWA(1) /= MA(1)+1) GO TO 150 IF (MWA(3) /= ABS(MA(2))) GO TO 150 KFLAG = 1 150 RETURN END SUBROUTINE FMADDP SUBROUTINE FMARGS(KROUTN,NARGS,MA,MB,KRESLT) ! Check the input arguments to a routine for special cases. ! KROUTN - Name of the subroutine that was called ! NARGS - The number of input arguments (1 or 2) ! MA - First input argument ! MB - Second input argument (if NARGS is 2) ! KRESLT - Result code returned to the calling routine. ! Result codes: ! 0 - Perform the normal operation ! 1 - The result is the first input argument ! 2 - The result is the second input argument ! 3 - The result is -OVERFLOW ! 4 - The result is +OVERFLOW ! 5 - The result is -UNDERFLOW ! 6 - The result is +UNDERFLOW ! 7 - The result is -1.0 ! 8 - The result is +1.0 ! 9 - The result is -pi/2 ! 10 - The result is +pi/2 ! 11 - The result is 0.0 ! 12 - The result is UNKNOWN ! 13 - The result is +pi ! 14 - The result is -pi/4 ! 15 - The result is +pi/4 USE FMVALS IMPLICIT NONE CHARACTER(6) :: KROUTN REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER NARGS,KRESLT REAL (KIND(1.0D0)) :: MBS INTEGER J,KWRNSV,NCATMA,NCATMB,NDS ! These tables define the result codes to be returned for ! given values of the input argument(s). ! For example, row 7 column 2 of this array initialization ! KADD(2,7) = 2 means that if the first argument in a call ! to FMADD is in category 7 ( -UNDERFLOW ) and the second ! argument is in category 2 ( near -OVERFLOW but ! representable ) then the result code is 2 ( the value ! of the sum is equal to the second input argument). ! See routine FMCAT for descriptions of the categories. INTEGER :: KADD(15,15) = RESHAPE( (/ & 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,12,12, & 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0,12, & 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, & 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, & 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, & 3, 0, 0, 0, 0, 0,12, 1,12, 0, 0, 0, 0, 0, 4, & 3, 2, 2, 2, 2,12,12, 5,12,12, 2, 2, 2, 2, 4, & 3, 2, 2, 2, 2, 2, 5, 2, 6, 2, 2, 2, 2, 2, 4, & 3, 2, 2, 2, 2,12,12, 6,12,12, 2, 2, 2, 2, 4, & 3, 0, 0, 0, 0, 0,12, 1,12, 0, 0, 0, 0, 0, 4, & 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, & 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, & 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, & 12, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, & 12,12, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 /) & , (/ 15,15 /) ) INTEGER :: KMPY(15,15) = RESHAPE( (/ & 4, 4, 4, 4,12,12,12,11,12,12,12, 3, 3, 3, 3, & 4, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 3, & 4, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 3, & 4, 0, 0, 0, 0, 0, 6,11, 5, 0, 0, 1, 0, 0, 3, & 12, 0, 0, 0, 0, 0, 6,11, 5, 0, 0, 1, 0, 0,12, & 12, 0, 0, 0, 0, 0, 6,11, 5, 0, 0, 1, 0, 0,12, & 12,12,12, 6, 6, 6, 6,11, 5, 5, 5, 5,12,12,12, & 11,11,11,11,11,11,11,11,11,11,11,11,11,11,11, & 12,12,12, 5, 5, 5, 5,11, 6, 6, 6, 6,12,12,12, & 12, 0, 0, 0, 0, 0, 5,11, 6, 0, 0, 1, 0, 0,12, & 12, 0, 0, 0, 0, 0, 5,11, 6, 0, 0, 1, 0, 0,12, & 3, 2, 2, 2, 2, 2, 5,11, 6, 2, 2, 2, 2, 2, 4, & 3, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 4, & 3, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 4, & 3, 3, 3, 3,12,12,12,11,12,12,12, 4, 4, 4, 4 /) & , (/ 15,15 /) ) INTEGER :: KDIV(15,15) = RESHAPE( (/ & 12,12,12, 4, 4, 4, 4,12, 3, 3, 3, 3,12,12,12, & 12, 0, 0, 0, 0, 0, 4,12, 3, 0, 0, 1, 0, 0,12, & 12, 0, 0, 0, 0, 0, 4,12, 3, 0, 0, 1, 0, 0,12, & 6, 0, 0, 0, 0, 0, 4,12, 3, 0, 0, 1, 0, 0, 5, & 6, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 5, & 6, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 5, & 6, 6, 6, 6,12,12,12,12,12,12,12, 5, 5, 5, 5, & 11,11,11,11,11,11,11,12,11,11,11,11,11,11,11, & 5, 5, 5, 5,12,12,12,12,12,12,12, 6, 6, 6, 6, & 5, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 6, & 5, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 6, & 5, 0, 0, 0, 0, 0, 3,12, 4, 0, 0, 1, 0, 0, 6, & 12, 0, 0, 0, 0, 0, 3,12, 4, 0, 0, 1, 0, 0,12, & 12, 0, 0, 0, 0, 0, 3,12, 4, 0, 0, 1, 0, 0,12, & 12,12,12, 3, 3, 3, 3,12, 4, 4, 4, 4,12,12,12 /) & , (/ 15,15 /) ) INTEGER :: KPWR(15,15) = RESHAPE( (/ & 12,12, 0, 5,12,12,12, 8,12,12,12, 3, 0,12,12, & 12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12, & 12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12, & 12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12, & 12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12, & 12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12, & 12,12, 0, 3,12,12,12, 8,12,12,12, 5, 0,12,12, & 12,12,12,12,12,12,12,12,11,11,11,11,11,11,11, & 4, 4, 4, 4,12,12,12, 8,12,12,12, 6, 6, 6, 6, & 4, 4, 0, 0, 0, 8, 8, 8, 8, 0, 0, 1, 0, 6, 6, & 4, 4, 0, 0, 0, 8, 8, 8, 8, 0, 0, 1, 0, 6, 6, & 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, & 6, 6, 0, 0, 0, 8, 8, 8, 8, 8, 0, 1, 0, 4, 4, & 6, 6, 0, 0, 0, 8, 8, 8, 8, 8, 0, 1, 0, 4, 4, & 6, 6, 6, 6,12,12,12, 8,12,12,12, 4, 4, 4, 4 /) & , (/ 15,15 /) ) INTEGER :: KSQRT(15) = (/ 12,12,12,12,12,12,12,11,12, 0, 0, 8, 0, 0,12 /) INTEGER :: KEXP(15) = (/ 6, 6, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0, 4, 4 /) INTEGER :: KLN(15) = (/ 12,12,12,12,12,12,12,12,12, 0, 0,11, 0, 0,12 /) INTEGER :: KSIN(15) = (/ 12,12, 0, 0, 0, 0, 5,11, 6, 0, 0, 0, 0,12,12 /) INTEGER :: KCOS(15) = (/ 12,12, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0,12,12 /) INTEGER :: KTAN(15) = (/ 12,12, 0, 0, 0, 0, 5,11, 6, 0, 0, 0, 0,12,12 /) INTEGER :: KASIN(15) = (/ 12,12,12, 9, 0, 0, 5,11, 6, 0, 0,10,12,12,12 /) INTEGER :: KACOS(15) = (/ 12,12,12,13, 0,10,10,10,10,10, 0,11,12,12,12 /) INTEGER :: KATAN(15) = (/ 9, 9, 0,14, 0, 0, 5,11, 6, 0, 0,15, 0,10,10 /) INTEGER :: KSINH(15) = (/ 3, 3, 0, 0, 0, 1, 5,11, 6, 1, 0, 0, 0, 4, 4 /) INTEGER :: KCOSH(15) = (/ 4, 4, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0, 4, 4 /) INTEGER :: KTANH(15) = (/ 7, 7, 0, 0, 0, 1, 5,11, 6, 1, 0, 0, 0, 8, 8 /) INTEGER :: KLG10(15) = (/ 12,12,12,12,12,12,12,12,12, 0, 0,11, 0, 0,12 /) KRESLT = 12 KFLAG = -4 IF (MA(1) == MUNKNO) RETURN IF (NARGS == 2) THEN IF (MB(1) == MUNKNO) RETURN ENDIF IF (MBLOGS /= MBASE) CALL FMCONS KFLAG = 0 NAMEST(NCALL) = KROUTN ! Check the validity of parameters if this is a user call. IF (NCALL > 1 .AND. KDEBUG == 0) GO TO 130 ! Check NDIG. IF (NDIG < 2 .OR. NDIG > NDIGMX) THEN KFLAG = -1 CALL FMWARN NDS = NDIG IF (NDIG < 2) NDIG = 2 IF (NDIG > NDIGMX) NDIG = NDIGMX WRITE (KW, & "(' NDIG was',I10,'. It has been changed to',I10,'.')" & ) NDS,NDIG RETURN ENDIF ! Check MBASE. IF (MBASE < 2 .OR. MBASE > MXBASE) THEN KFLAG = -2 CALL FMWARN MBS = MBASE IF (MBASE < 2) MBASE = 2 IF (MBASE > MXBASE) MBASE = MXBASE WRITE (KW, & "(' MBASE was',I10,'. It has been changed to',I10,'.')" & ) INT(MBS),INT(MBASE) CALL FMCONS RETURN ENDIF ! Check exponent range. IF (MA(1) > MXEXP+1 .OR. MA(1) < -MXEXP) THEN IF (ABS(MA(1)) /= MEXPOV .OR. ABS(MA(2)) /= 1) THEN KFLAG = -3 CALL FMWARN RETURN ENDIF ENDIF IF (NARGS == 2) THEN IF (MB(1) > MXEXP+1 .OR. MB(1) < -MXEXP) THEN IF (ABS(MB(1)) /= MEXPOV .OR. ABS(MB(2)) /= 1) THEN KFLAG = -3 CALL FMWARN RETURN ENDIF ENDIF ENDIF ! Check for properly normalized digits in the ! input arguments. IF (ABS(MA(1)-INT(MA(1))) /= 0) KFLAG = 1 IF (MA(2) <= (-1) .OR. MA(2) >= MBASE .OR. & ABS(MA(2)-INT(MA(2))) /= 0) KFLAG = 2 IF (KDEBUG == 0) GO TO 110 DO J = 3, NDIG+1 IF (MA(J) < 0 .OR. MA(J) >= MBASE .OR. & ABS(MA(J)-INT(MA(J))) /= 0) THEN KFLAG = J GO TO 110 ENDIF ENDDO 110 IF (KFLAG /= 0) THEN J = KFLAG KFLAG = -4 KWRNSV = KWARN IF (KWARN >= 2) KWARN = 1 CALL FMWARN KWARN = KWRNSV IF (KWARN >= 1) THEN WRITE (KW,*) ' First invalid array element: MA(', & J,') = ',MA(J) ENDIF KFLAG = -4 IF (KWARN >= 2) THEN STOP ENDIF RETURN ENDIF IF (NARGS == 2) THEN IF (ABS(MB(1)-INT(MB(1))) /= 0) KFLAG = 1 IF (MB(2) <= (-1) .OR. MB(2) >= MBASE .OR. & ABS(MB(2)-INT(MB(2))) /= 0) KFLAG = 2 IF (KDEBUG == 0) GO TO 120 DO J = 3, NDIG+1 IF (MB(J) < 0 .OR. MB(J) >= MBASE .OR. & ABS(MB(J)-INT(MB(J))) /= 0) THEN KFLAG = J GO TO 120 ENDIF ENDDO 120 IF (KFLAG /= 0) THEN J = KFLAG KFLAG = -4 KWRNSV = KWARN IF (KWARN >= 2) KWARN = 1 CALL FMWARN KWARN = KWRNSV IF (KWARN >= 1) THEN WRITE (KW,*) ' First invalid array element: MB(', & J,') = ',MB(J) ENDIF KFLAG = -4 IF (KWARN >= 2) THEN STOP ENDIF RETURN ENDIF ENDIF ! Check for special cases. 130 CALL FMCAT(MA,NCATMA) NCATMB = 0 IF (NARGS == 2) CALL FMCAT(MB,NCATMB) IF (KROUTN == 'FMADD ') THEN KRESLT = KADD(NCATMB,NCATMA) GO TO 140 ENDIF IF (KROUTN == 'FMSUB ') THEN IF (NCATMB < 16) NCATMB = 16 - NCATMB KRESLT = KADD(NCATMB,NCATMA) GO TO 140 ENDIF IF (KROUTN == 'FMMPY ') THEN KRESLT = KMPY(NCATMB,NCATMA) GO TO 140 ENDIF IF (KROUTN == 'FMDIV ') THEN KRESLT = KDIV(NCATMB,NCATMA) GO TO 140 ENDIF IF (KROUTN == 'FMPWR ') THEN KRESLT = KPWR(NCATMB,NCATMA) GO TO 140 ENDIF IF (KROUTN == 'FMSQRT') THEN KRESLT = KSQRT(NCATMA) GO TO 140 ENDIF IF (KROUTN == 'FMEXP ') THEN KRESLT = KEXP(NCATMA) GO TO 140 ENDIF IF (KROUTN == 'FMLN ') THEN KRESLT = KLN(NCATMA) GO TO 140 ENDIF IF (KROUTN == 'FMSIN ') THEN KRESLT = KSIN(NCATMA) GO TO 140 ENDIF IF (KROUTN == 'FMCOS ') THEN KRESLT = KCOS(NCATMA) GO TO 140 ENDIF IF (KROUTN == 'FMTAN ') THEN KRESLT = KTAN(NCATMA) GO TO 140 ENDIF IF (KROUTN == 'FMASIN') THEN KRESLT = KASIN(NCATMA) IF ((NCATMA == 7.OR.NCATMA == 9) .AND. KRAD == 0) KRESLT = 12 GO TO 140 ENDIF IF (KROUTN == 'FMACOS') THEN KRESLT = KACOS(NCATMA) GO TO 140 ENDIF IF (KROUTN == 'FMATAN') THEN KRESLT = KATAN(NCATMA) IF ((NCATMA == 7.OR.NCATMA == 9) .AND. KRAD == 0) KRESLT = 12 GO TO 140 ENDIF IF (KROUTN == 'FMSINH') THEN KRESLT = KSINH(NCATMA) GO TO 140 ENDIF IF (KROUTN == 'FMCOSH') THEN KRESLT = KCOSH(NCATMA) GO TO 140 ENDIF IF (KROUTN == 'FMTANH') THEN KRESLT = KTANH(NCATMA) GO TO 140 ENDIF IF (KROUTN == 'FMLG10') THEN KRESLT = KLG10(NCATMA) GO TO 140 ENDIF KRESLT = 0 RETURN 140 IF (KRESLT == 12) THEN KFLAG = -4 CALL FMWARN ENDIF IF (KRESLT == 3 .OR. KRESLT == 4) THEN IF (NCATMA == 1 .OR. NCATMA == 7 .OR. NCATMA == 9 .OR. & NCATMA == 15 .OR. NCATMB == 1 .OR. NCATMB == 7 .OR. & NCATMB == 9 .OR. NCATMB == 15) THEN KFLAG = -5 ELSE KFLAG = -5 CALL FMWARN ENDIF ENDIF IF (KRESLT == 5 .OR. KRESLT == 6) THEN IF (NCATMA == 1 .OR. NCATMA == 7 .OR. NCATMA == 9 .OR. & NCATMA == 15 .OR. NCATMB == 1 .OR. NCATMB == 7 .OR. & NCATMB == 9 .OR. NCATMB == 15) THEN KFLAG = -6 ELSE KFLAG = -6 CALL FMWARN ENDIF ENDIF RETURN END SUBROUTINE FMARGS SUBROUTINE FMASIN(MA,MB) ! MB = ARCSIN(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE INTEGER J,K,KASAVE,KOVUN,KRESLT,NDSAVE IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB .OR. MA(1) > 0 .OR. MA(2) == 0) THEN CALL FMENTR('FMASIN',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMASIN' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF MACCA = MA(0) CALL FMEQ2(MA,MB,NDSAVE,NDIG) MB(0) = NINT(NDIG*ALOGM2) ! Use ASIN(X) = ATAN(X/SQRT(1-X*X)) CALL FMI2M(1,M05) CALL FMSUB(M05,MB,M03) CALL FMADD(M05,MB,M04) CALL FMMPY_R2(M03,M04) CALL FMSQRT_R1(M04) CALL FMDIV_R1(MB,M04) CALL FMATAN(MB,M13) CALL FMEQ(M13,MB) ! Round the result and return. MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MACCA,MACMAX) DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMASIN SUBROUTINE FMATAN(MA,MB) ! MB = ARCTAN(MA) USE FMVALS IMPLICIT NONE DOUBLE PRECISION X,XM REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER NSTACK(19) REAL (KIND(1.0D0)) :: MA1,MACCA,MACMAX,MAS,MXSAVE INTEGER J,K,KASAVE,KOVUN,KRESLT,KRSAVE,KST,KWRNSV,NDSAV1,NDSAVE, & NDSV IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN CALL FMENTR('FMATAN',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMATAN' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF MACCA = MA(0) CALL FMEQ2(MA,M05,NDSAVE,NDIG) M05(0) = NINT(NDIG*ALOGM2) ! If MA >= 1 work with 1/MA. MA1 = MA(1) MAS = MA(-1) M05(-1) = 1 IF (MA1 >= 1) THEN CALL FMI2M(1,MB) CALL FMDIV_R2(MB,M05) ENDIF KRSAVE = KRAD KRAD = 1 KWRNSV = KWARN X = M05(1) XM = MXBASE ! In case pi has not been computed at the current precision ! and will be needed here, get it to full precision first ! to avoid repeated calls at increasing precision during ! Newton iteration. IF (MA1 >= 1 .OR. KRSAVE == 0) THEN IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN NDSV = NDIG NDIG = MIN(NDIG+2,NDG2MX) NCALL = NCALL + 1 NAMEST(NCALL) = 'NOEQ ' CALL FMPI(MPISAV) NCALL = NCALL - 1 NDIG = NDSV ENDIF ENDIF ! If the argument is small, use the Taylor series, ! otherwise use Newton iteration. IF (X*DLOGMB < -5.0D0*LOG(XM)) THEN KWARN = 0 CALL FMEQ(M05,MB) IF (MB(1) <= -NDIG) GO TO 120 CALL FMSQR(M05,M06) J = 3 NDSAV1 = NDIG 110 CALL FMMPY_R1(M05,M06) IF (M05(1) /= MUNKNO .AND. M05(2) /= 0) M05(-1) = -M05(-1) CALL FMDIVI(M05,J,M03) NDIG = NDSAV1 CALL FMADD_R1(MB,M03) IF (KFLAG /= 0) THEN KFLAG = 0 GO TO 120 ENDIF NDIG = NDSAV1 - INT((MB(1)-M03(1))) IF (NDIG < 2) NDIG = 2 J = J + 2 GO TO 110 ELSE CALL FMM2DP(M05,X) X = ATAN(X) CALL FMDPM(X,MB) CALL FMDIG(NSTACK,KST) ! Newton iteration. DO J = 1, KST NDIG = NSTACK(J) CALL FMSIN(MB,M06) CALL FMSQR(M06,M03) CALL FMI2M(1,M04) CALL FMSUB_R2(M04,M03) CALL FMSQRT(M03,M04) CALL FMDIV_R2(M06,M04) CALL FMSUB_R1(M04,M05) CALL FMMPY_R2(M03,M04) CALL FMSUB_R1(MB,M04) ENDDO MB(0) = NINT(NDIG*ALOGM2) ENDIF ! If MA >= 1 use pi/2 - ATAN(1/MA) 120 IF (MA1 >= 1) THEN CALL FMDIVI(MPISAV,2,M06) CALL FMSUB_R2(M06,MB) ENDIF ! Convert to degrees if necessary, round and return. KRAD = KRSAVE IF (KRAD == 0) THEN CALL FMMPYI_R1(MB,180) CALL FMDIV_R1(MB,MPISAV) ENDIF IF (MB(1) /= MUNKNO .AND. MB(2) /= 0 .AND. MAS < 0) MB(-1) = -MB(-1) IF (KFLAG == 1) KFLAG = 0 KWARN = KWRNSV MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MACCA,MACMAX) DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMATAN SUBROUTINE FMATN2(MA,MB,MC) ! MC = ATAN2(MA,MB) ! MC is returned as the angle between -pi and pi (or -180 and 180 if ! degree mode is selected) for which TAN(MC) = MA/MB. MC is an angle ! for the point (MB,MA) in polar coordinates. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MXEXP1,MXSAVE INTEGER J,JQUAD,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB) THEN CALL FMENTR('FMATN2',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMATN2' IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MB,MC,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF KWRNSV = KWARN KWARN = 0 MACCA = MA(0) MACCB = MB(0) CALL FMEQ2(MA,M01,NDSAVE,NDIG) M01(0) = NINT(NDIG*ALOGM2) CALL FMEQ2(MB,M02,NDSAVE,NDIG) M02(0) = NINT(NDIG*ALOGM2) ! Check for special cases. IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR. & (MA(2) == 0 .AND. MB(2) == 0)) THEN CALL FMST2M('UNKNOWN',MC) KFLAG = -4 GO TO 110 ENDIF IF (MB(2) == 0 .AND. MA(-1) > 0) THEN IF (KRAD == 0) THEN CALL FMI2M(90,MC) ELSE CALL FMPI(MC) CALL FMDIVI_R1(MC,2) ENDIF GO TO 110 ENDIF IF (MB(2) == 0 .AND. MA(-1) < 0) THEN IF (KRAD == 0) THEN CALL FMI2M(-90,MC) ELSE CALL FMPI(MC) CALL FMDIVI_R1(MC,-2) ENDIF GO TO 110 ENDIF MXEXP1 = INT(MXEXP2/2.01D0) IF (MA(1) == MEXPOV .AND. MB(1) < MXEXP1-NDIG-2) THEN IF (KRAD == 0) THEN CALL FMI2M(90,MC) ELSE CALL FMPI(MC) CALL FMDIVI_R1(MC,2) ENDIF IF (M01(-1) < 0) MC(-1) = -1 GO TO 110 ENDIF IF (MA(1) == MEXPUN .AND. (-MB(1)) < MXEXP1-NDIG-2 .AND. & MB(-1) < 0) THEN IF (KRAD == 0) THEN CALL FMI2M(180,MC) ELSE CALL FMPI(MC) ENDIF IF (M01(-1) < 0) MC(-1) = -1 GO TO 110 ENDIF IF (MB(1) == MEXPOV .AND. MA(1) < MXEXP1-NDIG-2 .AND. & MB(-1) < 0) THEN IF (KRAD == 0) THEN CALL FMI2M(180,MC) ELSE CALL FMPI(MC) ENDIF IF (M01(-1) < 0) MC(-1) = -1 GO TO 110 ENDIF IF (MB(1) == MEXPUN .AND. MA(2) == 0) THEN IF (MB(-1) < 0) THEN IF (KRAD == 0) THEN CALL FMI2M(180,MC) ELSE CALL FMPI(MC) ENDIF ELSE CALL FMI2M(0,MC) ENDIF GO TO 110 ENDIF IF (MB(1) == MEXPUN .AND. (-MA(1)) < MXEXP1-NDIG-2) THEN IF (KRAD == 0) THEN CALL FMI2M(90,MC) ELSE CALL FMPI(MC) CALL FMDIVI_R1(MC,2) ENDIF IF (M01(-1) < 0) MC(-1) = -1 GO TO 110 ENDIF ! Determine the quadrant for the result, then use FMATAN. IF (MA(-1) >= 0 .AND. MB(-1) > 0) JQUAD = 1 IF (MA(-1) >= 0 .AND. MB(-1) < 0) JQUAD = 2 IF (MA(-1) < 0 .AND. MB(-1) < 0) JQUAD = 3 IF (MA(-1) < 0 .AND. MB(-1) > 0) JQUAD = 4 CALL FMDIV(M01,M02,MC) MC(-1) = 1 CALL FMATAN(MC,M13) CALL FMEQ(M13,MC) IF (JQUAD == 2 .OR. JQUAD == 3) THEN IF (KRAD == 0) THEN CALL FMI2M(180,M05) CALL FMSUB_R2(M05,MC) ELSE CALL FMPI(M05) CALL FMSUB_R2(M05,MC) ENDIF ENDIF IF ((JQUAD == 3 .OR. JQUAD == 4) .AND. MC(1) /= MUNKNO .AND. & MC(2) /= 0) MC(-1) = -MC(-1) ! Round the result and return. 110 IF (KFLAG == 1) KFLAG = 0 KWARN = KWRNSV MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315) MC(0) = MIN(MC(0),MACCA,MACCB,MACMAX) DO J = -1, NDIG+1 M01(J) = MC(J) ENDDO CALL FMEXIT(M01,MC,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMATN2 SUBROUTINE FMBIG(MA) ! MA = The biggest representable FM number using the current base ! and precision. ! The smallest positive number is then 1.0/MA. ! Because of rounding, 1.0/(1.0/MA) will then overflow. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER J,N1 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMBIG ' IF (MBLOGS /= MBASE) CALL FMCONS KFLAG = 0 N1 = NDIG + 1 DO J = 2, N1 MA(J) = MBASE - 1 ENDDO MA(1) = MXEXP + 1 MA(0) = NINT(NDIG*ALOGM2) MA(-1) = 1 IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMBIG SUBROUTINE FMCAT(MA,NCAT) ! NCAT is returned as the category of MA. This is used by the various ! arithmetic routines to handle special cases such as: ! 'number greater than 1' + 'underflowed result' is the first argument, ! 'overflowed result' / 'overflowed result' is 'unknown'. ! NCAT range ! 1. -OV OV stands for overflowed results. ! 2. (-OV , -OVTH) ( MA(1) >= MAXEXP+2 ) ! 3. (-OVTH , -1) ! 4. -1 OVTH stands for a representable ! 5. (-1 , -UNTH) number near the overflow ! 6. (-UNTH , -UN) threshold. ! 7. -UN ( MA(1) >= MAXEXP-NDIG+1 ) ! 8. 0 ! 9. +UN UN stands for underflowed results. ! 10. (+UN , +UNTH) ( MA(1) <= -MAXEXP-1 ) ! 11. (+UNTH , +1) ! 12. +1 UNTH stands for a representable ! 13. (+1 , +OVTH) number near the underflow ! 14. (+OVTH , +OV) threshold. ! 15. +OV ( MA(1) <= -MAXEXP+NDIG-1 ) ! 16. UNKNOWN USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER NCAT REAL (KIND(1.0D0)) :: MA2,MXEXP1 INTEGER J,NLAST ! Check for special symbols. NCAT = 16 IF (MA(1) == MUNKNO) RETURN IF (MA(1) == MEXPOV) THEN NCAT = 15 IF (MA(-1) < 0) NCAT = 1 RETURN ENDIF IF (MA(1) == MEXPUN) THEN NCAT = 9 IF (MA(-1) < 0) NCAT = 7 RETURN ENDIF IF (MA(2) == 0) THEN NCAT = 8 RETURN ENDIF ! Check for +1 or -1. MA2 = ABS(MA(2)) IF (MA(1) == 1 .AND. MA2 == 1) THEN NLAST = NDIG + 1 IF (NLAST >= 3) THEN DO J = 3, NLAST IF (MA(J) /= 0) GO TO 110 ENDDO ENDIF NCAT = 12 IF (MA(-1) < 0) NCAT = 4 RETURN ENDIF 110 MXEXP1 = INT(MXEXP) IF (MA(1) >= MXEXP1-NDIG+2) THEN NCAT = 14 IF (MA(-1) < 0) NCAT = 2 RETURN ENDIF IF (MA(1) >= 1) THEN NCAT = 13 IF (MA(-1) < 0) NCAT = 3 RETURN ENDIF IF (MA(1) >= -MXEXP1+NDIG) THEN NCAT = 11 IF (MA(-1) < 0) NCAT = 5 RETURN ENDIF IF (MA(1) >= -MXEXP1) THEN NCAT = 10 IF (MA(-1) < 0) NCAT = 6 RETURN ENDIF RETURN END SUBROUTINE FMCAT SUBROUTINE FMCHSH(MA,MB,MC) ! MB = COSH(MA), MC = SINH(MA) ! If both the hyperbolic sine and cosine are needed, this routine ! is faster than calling both FMCOSH and FMSINH. ! MB and MC must be distinct arrays. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE INTEGER J,K,KASAVE,KOVUN,KRESLT,KWRNSV,NCSAVE,NDSAVE IF (MBLOGS /= MBASE) CALL FMCONS MACCA = MA(0) MAS = MA(-1) IF (ABS(MA(1)) > MEXPAB) THEN NCSAVE = NCALL CALL FMENTR('FMCHSH',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (MA(1) == MUNKNO) KOVUN = 2 NCALL = NCSAVE + 1 CALL FMEQ2(MA,M04,NDSAVE,NDIG) M04(0) = NINT(NDIG*ALOGM2) M04(-1) = 1 CALL FMCOSH(M04,MB) CALL FMSINH(M04,MC) GO TO 110 ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMCHSH' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN NCALL = NCALL - 1 NDIG = NDSAVE CALL FMEQ(MA,M04) CALL FMCOSH(M04,MB) CALL FMSINH(M04,MC) KFLAG = -9 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF CALL FMEQ2(MA,M04,NDSAVE,NDIG) M04(0) = NINT(NDIG*ALOGM2) M04(-1) = 1 K = 1 IF (M04(1) == 0 .AND. M04(2) /= 0) THEN IF (MBASE/M04(2) >= 100) K = 2 ENDIF IF (M04(1) >= 0 .AND. M04(2) /= 0 .AND. K == 1) THEN CALL FMCOSH(M04,MB) IF (MB(1) > NDIG) THEN CALL FMEQ(MB,MC) GO TO 110 ENDIF CALL FMSQR(MB,M03) CALL FMI2M(-1,M02) CALL FMADD_R1(M03,M02) CALL FMSQRT(M03,MC) ELSE CALL FMSINH(M04,MC) CALL FMSQR(MC,M03) CALL FMI2M(1,M02) CALL FMADD_R1(M03,M02) CALL FMSQRT(M03,MB) ENDIF ! Round and return. 110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315) MC(0) = MIN(MC(0),MACCA,MACMAX) IF (MAS < 0 .AND. MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1) CALL FMEQ2_R1(MC,NDIG,NDSAVE) MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MACCA,MACMAX) IF (KOVUN == 2) THEN KWRNSV = KWARN KWARN = 0 ENDIF DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) IF (KOVUN == 2) THEN KWARN = KWRNSV ENDIF IF (NTRACE /= 0) THEN IF (ABS(NTRACE) >= 1 .AND. NCALL+1 <= LVLTRC) THEN IF (NTRACE < 0) THEN CALL FMNTRJ(MC,NDIG) ELSE CALL FMPRNT(MC) ENDIF ENDIF ENDIF RETURN END SUBROUTINE FMCHSH FUNCTION FMCOMP(MA,LREL,MB) ! Logical comparison of FM numbers MA and MB. ! LREL is a CHARACTER description of the comparison to be done: ! LREL = 'EQ' returns FMCOMP = .TRUE. if MA == MB ! = 'NE', 'GE', 'GT', 'LE', 'LT' also work like a logical IF. ! = '==', '/=', '<', '<=', '>', '>=' may be used. ! For comparisons involving 'UNKNOWN' or two identical special symbols ! such as +OVERFLOW,'EQ',+OVERFLOW, FMCOMP is returned FALSE and a ! KFLAG = -4 error condition is returned. ! Some compilers object to functions with side effects such as ! changing KFLAG or other module FMVALS variables. Blocks of ! code that modify these variables are identified by: ! C DELETE START ! ... ! C DELETE STOP ! These may be removed or commented out to produce a function without ! side effects. This disables trace printing in FMCOMP, and error ! codes are not returned in KFLAG. USE FMVALS IMPLICIT NONE LOGICAL FMCOMP CHARACTER(*) :: LREL CHARACTER(2) :: JREL REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER J,JCOMP,NLAST ! DELETE START NCALL = NCALL + 1 NAMEST(NCALL) = 'FMCOMP' IF (NCALL <= LVLTRC .AND. ABS(NTRACE) >= 2) THEN WRITE (KW,"(' Input to FMCOMP')") IF (NTRACE > 0) THEN CALL FMPRNT(MA) IF (INDEX('=/<>',LREL(1:1)) > 0) THEN WRITE (KW,"(8X,A)") LREL ELSE WRITE (KW,"(7X,'.',A,'.')") LREL ENDIF CALL FMPRNT(MB) ELSE CALL FMNTRJ(MA,NDIG) IF (INDEX('=/<>',LREL(1:1)) > 0) THEN WRITE (KW,"(8X,A)") LREL ELSE WRITE (KW,"(7X,'.',A,'.')") LREL ENDIF CALL FMNTRJ(MB,NDIG) ENDIF ENDIF ! DELETE STOP ! JCOMP will be 1 if MA > MB ! 2 if MA == MB ! 3 if MA < MB ! Check for special cases. JREL = LREL IF (LREL /= 'EQ' .AND. LREL /= 'NE' .AND. LREL /= 'LT' .AND. & LREL /= 'GT' .AND. LREL /= 'LE' .AND. LREL /= 'GE') THEN IF (LREL == 'eq' .OR. LREL == '==') THEN JREL = 'EQ' ELSE IF (LREL == 'ne' .OR. LREL == '/=') THEN JREL = 'NE' ELSE IF (LREL == 'lt' .OR. LREL == '<') THEN JREL = 'LT' ELSE IF (LREL == 'gt' .OR. LREL == '>') THEN JREL = 'GT' ELSE IF (LREL == 'le' .OR. LREL == '<=') THEN JREL = 'LE' ELSE IF (LREL == 'ge' .OR. LREL == '>=') THEN JREL = 'GE' ELSE FMCOMP = .FALSE. ! DELETE START KFLAG = -4 IF (NCALL /= 1 .OR. KWARN <= 0) GO TO 120 ! DELETE STOP IF (KWARN <= 0) GO TO 120 WRITE (KW, & "(/' Error of type KFLAG = -4 in FM package in'," // & "' routine FMCOMP'//1X,A,' is not one of the six'," // & "' recognized comparisons.'//' .FALSE. has been'," // & "' returned.'/)" & ) LREL IF (KWARN >= 2) THEN STOP ENDIF GO TO 120 ENDIF ENDIF IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN FMCOMP = .FALSE. ! DELETE START KFLAG = -4 ! DELETE STOP GO TO 120 ENDIF IF (ABS(MA(1)) == MEXPOV .AND. MA(1) == MB(1) .AND. & MA(2) == MB(2) .AND. MA(-1) == MB(-1)) THEN FMCOMP = .FALSE. ! DELETE START KFLAG = -4 IF (NCALL /= 1 .OR. KWARN <= 0) GO TO 120 ! DELETE STOP IF (KWARN <= 0) GO TO 120 WRITE (KW, & "(/' Error of type KFLAG = -4 in FM package in routine'," // & "' FMCOMP'//' Two numbers in the same overflow or'," // & "' underflow category cannot be compared.'//" // & "' .FALSE. has been returned.'/)" & ) IF (KWARN >= 2) THEN STOP ENDIF GO TO 120 ENDIF ! Check for zero. ! DELETE START KFLAG = 0 ! DELETE STOP IF (MA(2) == 0) THEN JCOMP = 2 IF (MB(2) == 0) GO TO 110 IF (MB(-1) < 0) JCOMP = 1 IF (MB(-1) > 0) JCOMP = 3 GO TO 110 ENDIF IF (MB(2) == 0) THEN JCOMP = 1 IF (MA(-1) < 0) JCOMP = 3 GO TO 110 ENDIF ! Check for opposite signs. IF (MA(-1) > 0 .AND. MB(-1) < 0) THEN JCOMP = 1 GO TO 110 ENDIF IF (MB(-1) > 0 .AND. MA(-1) < 0) THEN JCOMP = 3 GO TO 110 ENDIF ! See which one is larger in absolute value. IF (MA(1) > MB(1)) THEN JCOMP = 1 GO TO 110 ENDIF IF (MB(1) > MA(1)) THEN JCOMP = 3 GO TO 110 ENDIF NLAST = NDIG + 1 DO J = 2, NLAST IF (ABS(MA(J)) > ABS(MB(J))) THEN JCOMP = 1 GO TO 110 ENDIF IF (ABS(MB(J)) > ABS(MA(J))) THEN JCOMP = 3 GO TO 110 ENDIF ENDDO JCOMP = 2 ! Now match the JCOMP value to the requested comparison. 110 IF (JCOMP == 1 .AND. MA(-1) < 0) THEN JCOMP = 3 ELSE IF (JCOMP == 3 .AND. MB(-1) < 0) THEN JCOMP = 1 ENDIF FMCOMP = .FALSE. IF (JCOMP == 1 .AND. (JREL == 'GT' .OR. JREL == 'GE' .OR. & JREL == 'NE')) FMCOMP = .TRUE. IF (JCOMP == 2 .AND. (JREL == 'EQ' .OR. JREL == 'GE' .OR. & JREL == 'LE')) FMCOMP = .TRUE. IF (JCOMP == 3 .AND. (JREL == 'NE' .OR. JREL == 'LT' .OR. & JREL == 'LE')) FMCOMP = .TRUE. 120 CONTINUE ! DELETE START IF (NTRACE /= 0) THEN IF (NCALL <= LVLTRC .AND. ABS(NTRACE) >= 1) THEN IF (KFLAG == 0) THEN WRITE (KW, & "(' FMCOMP',15X,'Call level =',I2,5X,'MBASE ='," // & "I10,5X,'NDIG =',I6)" & ) NCALL,INT(MBASE),NDIG ELSE WRITE (KW, & "(' FMCOMP',6X,'Call level =',I2,4X,'MBASE ='," // & "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)" & ) NCALL,INT(MBASE),NDIG,KFLAG ENDIF IF (FMCOMP) THEN WRITE (KW,"(7X,'.TRUE.')") ELSE WRITE (KW,"(7X,'.FALSE.')") ENDIF ENDIF ENDIF NCALL = NCALL - 1 ! DELETE STOP RETURN END FUNCTION FMCOMP SUBROUTINE FMCONS ! Set several saved machine precision constants. USE FMVALS IMPLICIT NONE MBLOGS = MBASE ALOGMB = LOG(REAL(MBASE)) ALOGM2 = ALOGMB/LOG(2.0) ALOGMX = LOG(REAL(MAXINT)) ALOGMT = ALOGMB/LOG(10.0) NGRD21 = INT(2.0/ALOGMT + 1.0) NGRD52 = INT(5.0/ALOGMT + 2.0) NGRD22 = INT(2.0/ALOGMT + 2.0) IF (MBASE < 1000 .OR. KRPERF /= 0) THEN NGRD21 = 2*NGRD21 NGRD52 = 4*NGRD52 NGRD22 = 2*NGRD22 ENDIF MEXPAB = AINT (MXEXP2/5) DLOGMB = LOG(DBLE(MBASE)) DLOGTN = LOG(10.0D0) DLOGTW = LOG(2.0D0) DPPI = 4.0D0*ATAN(1.0D0) DLOGTP = LOG(2.0D0*DPPI) DLOGPI = LOG(DPPI) DLOGEB = -LOG(DPEPS)/DLOGMB RETURN END SUBROUTINE FMCONS SUBROUTINE FMCOS(MA,MB) ! MB = COS(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE INTEGER J,JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NDSV IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN CALL FMENTR('FMCOS ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMCOS ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF MACCA = MA(0) CALL FMEQ2(MA,MB,NDSAVE,NDIG) MB(0) = NINT(NDIG*ALOGM2) MB(-1) = 1 CALL FMEQ(MB,MWE) KWRNSV = KWARN KWARN = 0 ! Reduce the argument, convert to radians if the input is ! in degrees, and evaluate the function. CALL FMRDC(MB,JSIN,JCOS,JSWAP) KWARN = KWRNSV IF (MB(1) == MUNKNO) THEN IF (KRAD /= 1 .OR. JSWAP == 1) THEN CALL FMEQ(MWE,MB) CALL FMRDC(MB,JSIN,JCOS,JSWAP) GO TO 110 ENDIF IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN NDSV = NDIG NDIG = MIN(NDIG+2,NDG2MX) NCALL = NCALL + 1 NAMEST(NCALL) = 'NOEQ ' CALL FMPI(MPISAV) NCALL = NCALL - 1 NDIG = NDSV ENDIF CALL FMDIV(MWE,MPISAV,M04) CALL FMNINT(M04,M03) CALL FMMPY(M03,MPISAV,M02) CALL FMSUB_R2(MWE,M02) IF (M02(2) == 0) CALL FMULP(MWE,M02) CALL FMI2M(1,M04) CALL FMSQR_R1(M02) CALL FMDIVI_R1(M02,2) CALL FMSUB_R2(M04,M02) CALL FMSUB_R1(M02,M04) IF (M02(2) == 0) THEN CALL FMI2M(JCOS,MB) ELSE CALL FMEQ(MWE,MB) CALL FMRDC(MB,JSIN,JCOS,JSWAP) ENDIF GO TO 110 ENDIF IF (KRAD == 0) THEN IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN NDSV = NDIG NDIG = MIN(NDIG+2,NDG2MX) NCALL = NCALL + 1 NAMEST(NCALL) = 'NOEQ ' CALL FMPI(MPISAV) NCALL = NCALL - 1 NDIG = NDSV ENDIF CALL FMMPY_R1(MB,MPISAV) CALL FMDIVI_R1(MB,180) ENDIF IF (MB(1) /= MUNKNO) THEN IF (JSWAP == 0) THEN CALL FMCOS2(MB,M09) CALL FMEQ(M09,MB) ELSE IF (MB(1) < 0 .OR. NDIG <= 50) THEN CALL FMSIN2(MB,M09) CALL FMEQ(M09,MB) ELSE CALL FMCOS2(MB,M09) CALL FMEQ(M09,MB) CALL FMI2M(1,M03) CALL FMSQR_R1(MB) CALL FMSUB_R2(M03,MB) CALL FMSQRT_R1(MB) ENDIF ENDIF ENDIF ! Append the sign, round, and return. IF (MB(1) /= MUNKNO .AND. MB(2) /= 0 .AND. JCOS == -1) MB(-1) = -MB(-1) 110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MACCA,MACMAX) DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMCOS SUBROUTINE FMCOS2(MA,MB) ! Internal subroutine for MB = COS(MA) where 0 <= MA <= 1. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) ! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent ! sums. Increasing this value will begin to improve the ! speed of COS when the base is large and precision exceeds ! about 1,500 decimal digits. REAL (KIND(1.0D0)) :: MAXVAL INTEGER J,J2,K,K2,KPT,KTWO,KWRNSV,L,L2,LARGE,N2,NBOT,NDSAV1, & NDSAVE,NTERM REAL ALOG2,ALOGT,B,T,TJ IF (MBLOGS /= MBASE) CALL FMCONS IF (MA(2) == 0) THEN CALL FMI2M(1,MB) RETURN ENDIF NDSAVE = NDIG KWRNSV = KWARN KWARN = 0 ! Use the direct series ! COS(X) = 1 - X**2/2! + X**4/4! - ... ! The argument will be divided by 2**K2 before the series ! is summed. The series will be added as J2 concurrent ! series. The approximately optimal values of K2 and J2 ! are now computed to try to minimize the time required. ! N2/2 is the approximate number of terms of the series ! that will be needed, and L2 guard digits will be carried. ! Since X is small when the series is summed, COS(X) - 1 ! is computed. Then a version of the recovery formula can ! be used that does not suffer from severe cancellation. B = REAL(MBASE) K = NGRD52 T = MAX(NDIG-K,2) ALOG2 = LOG(2.0) ALOGT = LOG(T) TJ = 0.03*ALOGMB*T**0.3333 + 1.85 J2 = INT(TJ) J2 = MAX(1,MIN(J2,LJSUMS/NDG2MX)) K2 = INT(0.5*SQRT(T*ALOGMB/TJ) + 2.8) L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B + & REAL(MA(3))/(B*B)))/ALOG2 - 0.3) K2 = K2 - L IF (L < 0) L = 0 IF (K2 < 0) THEN K2 = 0 J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) + .33) ENDIF IF (J2 <= 1) J2 = 1 N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) L2 = INT(LOG(REAL(N2)+2.0**K2)/ALOGMB) NDIG = NDIG + L2 IF (NDIG > NDG2MX) THEN IF (NCALL == 1) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MB) KWARN = KWRNSV RETURN ELSE NDIG = NDG2MX ENDIF ENDIF NDSAV1 = NDIG ! Divide the argument by 2**K2. CALL FMEQ2(MA,M02,NDSAVE,NDIG) KTWO = 1 MAXVAL = MXBASE/2 IF (K2 > 0) THEN DO J = 1, K2 KTWO = 2*KTWO IF (KTWO > MAXVAL) THEN CALL FMDIVI_R1(M02,KTWO) KTWO = 1 ENDIF ENDDO IF (KTWO > 1) CALL FMDIVI_R1(M02,KTWO) ENDIF ! Split into J2 concurrent sums and reduce NDIG while ! computing each term in the sum as the terms get smaller. CALL FMSQR_R1(M02) CALL FMEQ(M02,M03) IF (M03(1) /= MUNKNO .AND. M03(2) /= 0) M03(-1) = -M03(-1) NTERM = 2 DO J = 1, J2 NBOT = NTERM*(NTERM-1) CALL FMDIVI_R1(M03,NBOT) NTERM = NTERM + 2 KPT = (J-1)*(NDIG+3) CALL FMEQ(M03,MJSUMS(KPT-1)) IF (M03(1) /= MUNKNO .AND. M03(2) /= 0) M03(-1) = -M03(-1) ENDDO IF (M02(1) < -NDIG) GO TO 120 CALL FMIPWR(M02,J2,MB) 110 CALL FMMPY_R1(M03,MB) LARGE = INT(INTMAX/NTERM) DO J = 1, J2 NBOT = NTERM*(NTERM-1) IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN CALL FMDIVI_R1(M03,NTERM) NBOT = NTERM - 1 CALL FMDIVI_R1(M03,NBOT) ELSE CALL FMDIVI_R1(M03,NBOT) ENDIF KPT = (J-1)*(NDSAV1+3) NDIG = NDSAV1 CALL FMADD_R1(MJSUMS(KPT-1),M03) IF (KFLAG /= 0) GO TO 120 NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1)) IF (NDIG < 2) NDIG = 2 IF (M03(1) /= MUNKNO .AND. M03(2) /= 0) M03(-1) = -M03(-1) NTERM = NTERM + 2 ENDDO GO TO 110 ! Next put the J2 separate sums back together. 120 KFLAG = 0 KPT = (J2-1)*(NDIG+3) CALL FMEQ(MJSUMS(KPT-1),MB) IF (J2 >= 2) THEN DO J = 2, J2 CALL FMMPY_R2(M02,MB) KPT = (J2-J)*(NDIG+3) CALL FMADD_R1(MB,MJSUMS(KPT-1)) ENDDO ENDIF ! Reverse the effect of reducing the argument to ! compute COS(MA). NDIG = NDSAV1 IF (K2 > 0) THEN IF (NDSAVE <= 20) THEN CALL FMI2M(2,M02) DO J = 1, K2 CALL FMADD(MB,M02,M03) CALL FMMPY_R2(MB,M03) CALL FMADD(M03,M03,MB) ENDDO ELSE DO J = 1, K2 CALL FMSQR(MB,M03) CALL FMADD(MB,MB,M02) CALL FMADD_R1(M03,M02) CALL FMADD(M03,M03,MB) ENDDO ENDIF ENDIF CALL FMI2M(1,M03) CALL FMADD_R2(M03,MB) CALL FMEQ2_R1(MB,NDSAV1,NDSAVE) NDIG = NDSAVE KWARN = KWRNSV RETURN END SUBROUTINE FMCOS2 SUBROUTINE FMCOSH(MA,MB) ! MB = COSH(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE INTEGER J,K,KASAVE,KOVUN,KRESLT,NDSAVE,NMETHD IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB) THEN CALL FMENTR('FMCOSH',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMCOSH' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF MACCA = MA(0) CALL FMEQ2(MA,MB,NDSAVE,NDIG) MB(0) = NINT(NDIG*ALOGM2) MB(-1) = 1 IF (MA(2) == 0) THEN CALL FMI2M(1,MB) GO TO 120 ENDIF ! Use a series for small arguments, FMEXP for large ones. IF (MB(1) == MUNKNO) GO TO 120 IF (MBASE > 99) THEN IF (MB(1) <= 0) THEN NMETHD = 1 ELSE IF (MB(1) >= 2) THEN NMETHD = 2 ELSE IF (ABS(MB(2)) < 10) THEN NMETHD = 1 ELSE NMETHD = 2 ENDIF ELSE IF (MB(1) <= 0) THEN NMETHD = 1 ELSE NMETHD = 2 ENDIF ENDIF IF (NMETHD == 2) GO TO 110 CALL FMCSH2(MB,M09) CALL FMEQ(M09,MB) GO TO 120 110 CALL FMEXP(MB,M12) CALL FMEQ(M12,MB) IF (MB(1) == MEXPOV) THEN GO TO 120 ELSE IF (MB(1) == MEXPUN) THEN MB(1) = MEXPOV GO TO 120 ENDIF IF (INT(MB(1)) <= (NDIG+1)/2) THEN CALL FMI2M(1,M01) CALL FMDIV_R1(M01,MB) CALL FMADD_R1(MB,M01) ENDIF CALL FMDIVI_R1(MB,2) ! Round and return. 120 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MACCA,MACMAX) DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMCOSH SUBROUTINE FMCSH2(MA,MB) ! Internal subroutine for MB = COSH(MA). USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) ! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent ! sums. Increasing this value will begin to improve the ! speed of COSH when the base is large and precision exceeds ! about 1,500 decimal digits. REAL (KIND(1.0D0)) :: MAXVAL INTEGER J,J2,K,K2,KPT,KTWO,KWRNSV,L,L2,LARGE,N2,NBOT,NDSAV1, & NDSAVE,NTERM REAL ALOG2,ALOGT,B,T,TJ IF (MBLOGS /= MBASE) CALL FMCONS IF (MA(2) == 0) THEN CALL FMI2M(1,MB) RETURN ENDIF NDSAVE = NDIG KWRNSV = KWARN KWARN = 0 ! Use the direct series ! COSH(X) = 1 + X**2/2! + X**4/4! - ... ! The argument will be divided by 2**K2 before the series ! is summed. The series will be added as J2 concurrent ! series. The approximately optimal values of K2 and J2 ! are now computed to try to minimize the time required. ! N2/2 is the approximate number of terms of the series ! that will be needed, and L2 guard digits will be carried. ! Since X is small when the series is summed, COSH(X) - 1 ! is computed. Then a version of the recovery formula can ! be used that does not suffer from severe cancellation. B = REAL(MBASE) K = NGRD52 T = MAX(NDIG-K,2) ALOG2 = LOG(2.0) ALOGT = LOG(T) TJ = 0.03*ALOGMB*T**0.3333 + 1.85 J2 = INT(TJ) J2 = MAX(1,MIN(J2,LJSUMS/NDG2MX)) K2 = INT(0.5*SQRT(T*ALOGMB/TJ) + 2.8) L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B + & REAL(MA(3))/(B*B)))/ALOG2 - 0.3) K2 = K2 - L IF (L < 0) L = 0 IF (K2 < 0) THEN K2 = 0 J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) + .33) ENDIF IF (J2 <= 1) J2 = 1 N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) L2 = INT(LOG(REAL(N2)+2.0**K2)/ALOGMB) NDIG = NDIG + L2 IF (NDIG > NDG2MX) THEN IF (NCALL == 1) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MB) KWARN = KWRNSV RETURN ELSE NDIG = NDG2MX ENDIF ENDIF NDSAV1 = NDIG CALL FMEQ2(MA,M02,NDSAVE,NDIG) ! Divide the argument by 2**K2. KTWO = 1 MAXVAL = MXBASE/2 IF (K2 > 0) THEN DO J = 1, K2 KTWO = 2*KTWO IF (KTWO > MAXVAL) THEN CALL FMDIVI_R1(M02,KTWO) KTWO = 1 ENDIF ENDDO IF (KTWO > 1) CALL FMDIVI_R1(M02,KTWO) ENDIF ! Split into J2 concurrent sums and reduce NDIG while ! computing each term in the sum as the terms get smaller. CALL FMSQR_R1(M02) CALL FMEQ(M02,M03) NTERM = 2 DO J = 1, J2 NBOT = NTERM*(NTERM-1) CALL FMDIVI_R1(M03,NBOT) NTERM = NTERM + 2 KPT = (J-1)*(NDIG+3) CALL FMEQ(M03,MJSUMS(KPT-1)) ENDDO IF (M02(1) < -NDIG) GO TO 120 CALL FMIPWR(M02,J2,MB) 110 CALL FMMPY_R1(M03,MB) LARGE = INT(INTMAX/NTERM) DO J = 1, J2 NBOT = NTERM*(NTERM-1) IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN CALL FMDIVI_R1(M03,NTERM) NBOT = NTERM - 1 CALL FMDIVI_R1(M03,NBOT) ELSE CALL FMDIVI_R1(M03,NBOT) ENDIF KPT = (J-1)*(NDSAV1+3) NDIG = NDSAV1 CALL FMADD_R1(MJSUMS(KPT-1),M03) IF (KFLAG /= 0) GO TO 120 NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1)) IF (NDIG < 2) NDIG = 2 NTERM = NTERM + 2 ENDDO GO TO 110 ! Next put the J2 separate sums back together. 120 KFLAG = 0 KPT = (J2-1)*(NDIG+3) CALL FMEQ(MJSUMS(KPT-1),MB) IF (J2 >= 2) THEN DO J = 2, J2 CALL FMMPY_R2(M02,MB) KPT = (J2-J)*(NDIG+3) CALL FMADD_R1(MB,MJSUMS(KPT-1)) ENDDO ENDIF ! Reverse the effect of reducing the argument to ! compute COSH(MA). NDIG = NDSAV1 IF (K2 > 0) THEN IF (NDSAVE <= 20) THEN CALL FMI2M(2,M02) DO J = 1, K2 CALL FMADD(MB,M02,M03) CALL FMMPY_R2(MB,M03) CALL FMADD(M03,M03,MB) ENDDO ELSE DO J = 1, K2 CALL FMSQR(MB,M03) CALL FMADD(MB,MB,M02) CALL FMADD_R1(M03,M02) CALL FMADD(M03,M03,MB) ENDDO ENDIF ENDIF CALL FMI2M(1,M03) CALL FMADD_R2(M03,MB) CALL FMEQ2_R1(MB,NDSAV1,NDSAVE) NDIG = NDSAVE KWARN = KWRNSV RETURN END SUBROUTINE FMCSH2 SUBROUTINE FMCSSN(MA,MB,MC) ! MB = COS(MA), MC = SIN(MA) ! If both the sine and cosine are needed, this routine is faster ! than calling both FMCOS and FMSIN. ! MB and MC must be distinct arrays. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE INTEGER J,JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,KWRNSV,NCSAVE, & NDSAVE,NDSV IF (MBLOGS /= MBASE) CALL FMCONS MACCA = MA(0) MAS = MA(-1) IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN NCSAVE = NCALL CALL FMENTR('FMCSSN',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (MA(1) == MUNKNO) KOVUN = 2 NCALL = NCSAVE + 1 CALL FMEQ2(MA,M05,NDSAVE,NDIG) M05(0) = NINT(NDIG*ALOGM2) M05(-1) = 1 CALL FMCOS(M05,MB) CALL FMSIN(M05,MC) GO TO 110 ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMCSSN' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN NCALL = NCALL - 1 NDIG = NDSAVE CALL FMEQ(MA,M05) CALL FMCOS(M05,MB) CALL FMSIN(M05,MC) KFLAG = -9 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF IF (MA(2) == 0) THEN CALL FMI2M(1,MB) CALL FMI2M(0,MC) GO TO 110 ENDIF CALL FMEQ2(MA,MB,NDSAVE,NDIG) MB(0) = NINT(NDIG*ALOGM2) MB(-1) = 1 CALL FMEQ(MB,MWE) ! Reduce the argument, convert to radians if the input is ! in degrees, and evaluate the functions. CALL FMRDC(MB,JSIN,JCOS,JSWAP) IF (MB(1) == MUNKNO) THEN CALL FMCOS(MWE,MB) CALL FMSIN(MWE,MC) GO TO 110 ENDIF IF (KRAD == 0) THEN IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN NDSV = NDIG NDIG = MIN(NDIG+2,NDG2MX) NCALL = NCALL + 1 NAMEST(NCALL) = 'NOEQ ' CALL FMPI(MPISAV) NCALL = NCALL - 1 NDIG = NDSV ENDIF CALL FMMPY_R1(MB,MPISAV) CALL FMDIVI_R1(MB,180) ENDIF IF (MB(1) /= MUNKNO) THEN IF (JSWAP == 0) THEN IF (MB(1) < 0) THEN CALL FMSIN2(MB,MC) MC(-1) = JSIN*MC(-1) CALL FMSQR(MC,M03) CALL FMI2M(1,M02) CALL FMSUB_R2(M02,M03) CALL FMSQRT(M03,MB) MB(-1) = JCOS*MB(-1) ELSE CALL FMCOS2(MB,M09) CALL FMEQ(M09,MB) MB(-1) = JCOS*MB(-1) CALL FMSQR(MB,M03) CALL FMI2M(1,M02) CALL FMSUB_R2(M02,M03) CALL FMSQRT(M03,MC) MC(-1) = JSIN*MC(-1) ENDIF ELSE IF (MB(1) < 0) THEN CALL FMSIN2(MB,M09) CALL FMEQ(M09,MB) MB(-1) = JCOS*MB(-1) CALL FMSQR(MB,M03) CALL FMI2M(1,M02) CALL FMSUB_R2(M02,M03) CALL FMSQRT(M03,MC) MC(-1) = JSIN*MC(-1) ELSE CALL FMCOS2(MB,MC) MC(-1) = JSIN*MC(-1) CALL FMSQR(MC,M03) CALL FMI2M(1,M02) CALL FMSUB_R2(M02,M03) CALL FMSQRT(M03,MB) MB(-1) = JCOS*MB(-1) ENDIF ENDIF ELSE CALL FMEQ(MB,MC) ENDIF ! Round and return. 110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315) MC(0) = MIN(MC(0),MACCA,MACMAX) IF (MAS < 0 .AND. MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1) CALL FMEQ2_R1(MC,NDIG,NDSAVE) MB(0) = MIN(MB(0),MACCA,MACMAX) IF (KOVUN == 2) THEN KWRNSV = KWARN KWARN = 0 ENDIF DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) IF (KOVUN == 2) THEN KWARN = KWRNSV ENDIF IF (NTRACE /= 0) THEN IF (ABS(NTRACE) >= 1 .AND. NCALL+1 <= LVLTRC) THEN IF (NTRACE < 0) THEN CALL FMNTRJ(MC,NDIG) ELSE CALL FMPRNT(MC) ENDIF ENDIF ENDIF RETURN END SUBROUTINE FMCSSN SUBROUTINE FMDBL(A,B,C) ! C = A + B. All are double precision. This routine tries to ! force the compiler to round C to double precision accuracy. ! Some compilers allow double precision loops like the ones in ! FMSET and FMDM to be done in extended precision, which defeats ! the routine's attempt to determine double precision accuracy. ! This can lead to doing too few Newton steps and failing to ! get sufficient accuracy in several FM routines. USE FMVALS IMPLICIT NONE DOUBLE PRECISION A,B,C C = A + B RETURN END SUBROUTINE FMDBL SUBROUTINE FMDIG(NSTACK,KST) ! Compute the number of intermediate digits to be used in Newton ! iteration. This assumes that a starting approximation that is ! accurate to double precision is used, and the root is simple. ! KST is the number of iterations needed for final accuracy NDIG. ! NSTACK(J) holds the value of NDIG to be used for the ! Jth iteration. USE FMVALS IMPLICIT NONE INTEGER NSTACK(19),KST DOUBLE PRECISION Y INTEGER J,JT,L,ND,NDT,NE IF (MBLOGS /= MBASE) CALL FMCONS ! NE is the maximum number of base MBASE digits that ! can be used in the first Newton iteration. NE = INT(1.9D0*DLOGEB) ! Fill the intermediate digit stack (backwards). KST = 1 ND = NDIG NSTACK(1) = ND IF (ND < NE .OR. ND <= 2) RETURN 110 Y = ND ! The 1.9 accounts for the fact that the number of correct ! digits approximately doubles at each iteration. NDT = INT(Y/1.9D0) IF (2*NDT <= ND) NDT = NDT + 1 ND = NDT KST = KST + 1 NSTACK(KST) = ND IF (ND > NE .AND. ND > 2) GO TO 110 ! Reverse the stack. L = KST/2 DO J = 1, L JT = NSTACK(J) NSTACK(J) = NSTACK(KST+1-J) NSTACK(KST+1-J) = JT ENDDO RETURN END SUBROUTINE FMDIG SUBROUTINE FMDIM(MA,MB,MC) ! MC = DIM(MA,MB) ! Positive difference. MC = MA - MB if MA >= MB, ! = 0 otherwise. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MXSAVE INTEGER J,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE LOGICAL FMCOMP IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB) THEN CALL FMENTR('FMDIM ',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMDIM ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MB,MC,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF KWRNSV = KWARN KWARN = 0 MXEXP = MXSAVE MACCA = MA(0) MACCB = MB(0) CALL FMEQ2(MA,M01,NDSAVE,NDIG) M01(0) = NINT(NDIG*ALOGM2) CALL FMEQ2(MB,M02,NDSAVE,NDIG) M02(0) = NINT(NDIG*ALOGM2) IF (FMCOMP(M01,'LT',M02)) THEN CALL FMI2M(0,MC) ELSE CALL FMSUB(M01,M02,MC) ENDIF IF (KFLAG == 1) KFLAG = 0 KWARN = KWRNSV MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315) MC(0) = MIN(MC(0),MACCA,MACCB,MACMAX) DO J = -1, NDIG+1 M01(J) = MC(J) ENDDO CALL FMEXIT(M01,MC,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMDIM SUBROUTINE FMDIV(MA,MB,MC) ! MC = MA / MB ! This routine performs the trace printing for division. ! FMDIV2 is used to do the arithmetic. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMDIV ' CALL FMNTR(2,MA,MB,2,1) CALL FMDIV2(MA,MB,MC) CALL FMNTR(1,MC,MC,1,1) ELSE CALL FMDIV2(MA,MB,MC) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMDIV SUBROUTINE FMDIV2(MA,MB,MC) ! Internal division routine. MC = MA / MB USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MLR,MR,MS,MT1,MT2 INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KT3,L,N1,NG,NGUARD,NL IF (MBLOGS /= MBASE) CALL FMCONS JRSSAV = JRSIGN MACCA = MA(0) MACCB = MB(0) IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. & KDEBUG == 1) THEN CALL FMARGS('FMDIV ',2,MA,MB,KRESLT) IF (KRESLT /= 0) THEN NCALL = NCALL + 1 NAMEST(NCALL) = 'FMDIV ' CALL FMRSLT(MA,MB,MC,KRESLT) JRSIGN = JRSSAV NCALL = NCALL - 1 RETURN ENDIF ELSE IF (MB(2) == 0) THEN NAMEST(NCALL) = 'FMDIV ' CALL FMIM(0,MC) KFLAG = -4 CALL FMWARN MC(1) = MUNKNO MC(2) = 1 MC(0) = NINT(NDIG*ALOGM2) JRSIGN = JRSSAV RETURN ENDIF IF (MA(2) == 0) THEN CALL FMIM(0,MC) MC(0) = MIN(MACCA,MACCB) JRSIGN = JRSSAV RETURN ENDIF ENDIF KFLAG = 0 ! NGUARD is the number of guard digits used. IF (NCALL > 1) THEN NGUARD = NGRD21 IF (NGUARD > NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 - 1 IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 10 ENDIF ENDIF N1 = NDIG + 1 NG = NDIG + NGUARD ! Save the sign of MA and MB and then work only with ! positive numbers. MAS = MA(-1) MBS = MB(-1) IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF MWA(1) = MA(1) - MB(1) + 1 IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN MBASEL = MBASE NDIGL = NDIG NGUARL = NGUARD DO J = 2, 1000 MR = MBASE*MBASEL IF (4*MR > MXBASE) THEN N21 = J - 1 NDIG = (NDIGL-1)/N21 + 1 IF (NDIG < 2) NDIG = 2 NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG IF (NGRDN < 1) NGRDN = 1 EXIT ENDIF MBASE = MR ENDDO MBASEN = MBASE NDIGN = NDIG ELSE MBASE = MBASEN NDIG = NDIGN ENDIF MPMA(1) = 0 MPMB(1) = 0 L = 2 - N21 DO J = 2, NDIGL+2-N21, N21 MT1 = MA(J) MT2 = MB(J) DO K = J+1, J+N21-1 MT1 = MT1*MBASEL + MA(K) MT2 = MT2*MBASEL + MB(K) ENDDO MPMA(2+J/N21) = MT1 MPMB(2+J/N21) = MT2 L = J ENDDO DO J = 3+L/N21, NDIG+NGRDN+2 MPMA(J) = 0 MPMB(J) = 0 ENDDO IF (L+N21 <= NDIGL+1) THEN MT1 = 0 MT2 = 0 DO J = L+N21, L+2*N21-1 IF (J <= NDIGL+1) THEN MT1 = MT1*MBASEL + MA(J) MT2 = MT2*MBASEL + MB(J) ELSE MT1 = MT1*MBASEL MT2 = MT2*MBASEL ENDIF ENDDO MPMA(2+(L+N21)/N21) = MT1 MPMB(2+(L+N21)/N21) = MT2 ENDIF NG = NDIG + NGRDN + 1 IF (MPMA(2) >= MPMB(2)) NG = NG + 1 ! Copy MA into the working array. DO J = 2, NDIG+1 MWA(J+1) = MPMA(J) ENDDO MWA(2) = 0 DO J = NDIG+3, NG+4 MWA(J) = 0 ENDDO CALL FMDIV3(MPMB,NG) KT3 = N21 - 1 IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN DO J = 2+NDIG+NGRDN, 3, -1 KT1 = MWA(J) KT = 2 + (J-2)*N21 KT2 = N21 + KT - 1 DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3) MWA(K-KT3) = IBITS(KT1,KT2-K,1) ENDDO ENDDO ELSE MS = MBASEL**(N21-1) DO J = 2+NDIG+NGRDN, 3, -1 MR = MS MT1 = MWA(J) DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3) MWA(K-KT3) = AINT (MT1/MR) MT1 = MT1 - MWA(K-KT3)*MR MR = AINT (MR/MBASEL) ENDDO ENDDO ENDIF NDIG = NDIGL MBASE = MBASEL ELSE ! Copy MA into the working array. DO J = 2, N1 MWA(J+1) = MA(J) ENDDO MWA(2) = 0 NL = N1 + NGUARD + 3 DO J = NDIG+3, NL MWA(J) = 0 ENDDO CALL FMDIV3(MB,NG) ENDIF ! Round, affix the sign, and return. IF (MWA(2) == 0) THEN MLR = 2*MWA(NDIG+3) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,1) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1+1) = MWA(N1+1) + 1 MWA(N1+2) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,1) ENDIF ENDIF ELSE MLR = 2*MWA(NDIG+2) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,0) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1) = MWA(N1) + 1 MWA(N1+1) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,0) ENDIF ENDIF ENDIF CALL FMMOVE(MWA,MC) IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMDIV ' CALL FMWARN ENDIF MC(-1) = 1 IF (MAS*MBS < 0 .AND. MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1 IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315) MC(0) = MIN(MACCA,MACCB,MD2B) ELSE MC(0) = MIN(MACCA,MACCB) ENDIF JRSIGN = JRSSAV RETURN END SUBROUTINE FMDIV2 SUBROUTINE FMDIV_R1(MA,MB) ! MA = MA / MB ! This routine performs the trace printing for division. ! FMDIV2_R1 is used to do the arithmetic. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMDIV ' CALL FMNTR(2,MA,MB,2,1) CALL FMDIV2_R1(MA,MB) CALL FMNTR(1,MA,MA,1,1) ELSE CALL FMDIV2_R1(MA,MB) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMDIV_R1 SUBROUTINE FMDIV2_R1(MA,MB) ! Internal division routine. MA = MA / MB USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MLR,MR,MS,MT1,MT2 INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KT3,L,N1,NG,NGUARD,NL IF (MBLOGS /= MBASE) CALL FMCONS JRSSAV = JRSIGN MACCA = MA(0) MACCB = MB(0) IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. & KDEBUG == 1) THEN CALL FMARGS('FMDIV ',2,MA,MB,KRESLT) IF (KRESLT /= 0) THEN NCALL = NCALL + 1 NAMEST(NCALL) = 'FMDIV ' CALL FMRSLT(MA,MB,M07,KRESLT) CALL FMEQ(M07,MA) JRSIGN = JRSSAV NCALL = NCALL - 1 RETURN ENDIF ELSE IF (MB(2) == 0) THEN NAMEST(NCALL) = 'FMDIV ' CALL FMIM(0,MA) KFLAG = -4 CALL FMWARN MA(1) = MUNKNO MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) JRSIGN = JRSSAV RETURN ENDIF IF (MA(2) == 0) THEN CALL FMIM(0,MA) MA(0) = MIN(MACCA,MACCB) JRSIGN = JRSSAV RETURN ENDIF ENDIF KFLAG = 0 ! NGUARD is the number of guard digits used. IF (NCALL > 1) THEN NGUARD = NGRD21 IF (NGUARD > NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 - 1 IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 10 ENDIF ENDIF N1 = NDIG + 1 NG = NDIG + NGUARD ! Save the sign of MA and MB and then work only with ! positive numbers. MAS = MA(-1) MBS = MB(-1) IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF MWA(1) = MA(1) - MB(1) + 1 IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN MBASEL = MBASE NDIGL = NDIG NGUARL = NGUARD DO J = 2, 1000 MR = MBASE*MBASEL IF (4*MR > MXBASE) THEN N21 = J - 1 NDIG = (NDIGL-1)/N21 + 1 IF (NDIG < 2) NDIG = 2 NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG IF (NGRDN < 1) NGRDN = 1 EXIT ENDIF MBASE = MR ENDDO MBASEN = MBASE NDIGN = NDIG ELSE MBASE = MBASEN NDIG = NDIGN ENDIF MPMA(1) = 0 MPMB(1) = 0 L = 2 - N21 DO J = 2, NDIGL+2-N21, N21 MT1 = MA(J) MT2 = MB(J) DO K = J+1, J+N21-1 MT1 = MT1*MBASEL + MA(K) MT2 = MT2*MBASEL + MB(K) ENDDO MPMA(2+J/N21) = MT1 MPMB(2+J/N21) = MT2 L = J ENDDO DO J = 3+L/N21, NDIG+NGRDN+2 MPMA(J) = 0 MPMB(J) = 0 ENDDO IF (L+N21 <= NDIGL+1) THEN MT1 = 0 MT2 = 0 DO J = L+N21, L+2*N21-1 IF (J <= NDIGL+1) THEN MT1 = MT1*MBASEL + MA(J) MT2 = MT2*MBASEL + MB(J) ELSE MT1 = MT1*MBASEL MT2 = MT2*MBASEL ENDIF ENDDO MPMA(2+(L+N21)/N21) = MT1 MPMB(2+(L+N21)/N21) = MT2 ENDIF NG = NDIG + NGRDN + 1 IF (MPMA(2) >= MPMB(2)) NG = NG + 1 ! Copy MA into the working array. DO J = 2, NDIG+1 MWA(J+1) = MPMA(J) ENDDO MWA(2) = 0 DO J = NDIG+3, NG+4 MWA(J) = 0 ENDDO CALL FMDIV3(MPMB,NG) KT3 = N21 - 1 IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN DO J = 2+NDIG+NGRDN, 3, -1 KT1 = MWA(J) KT = 2 + (J-2)*N21 KT2 = N21 + KT - 1 DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3) MWA(K-KT3) = IBITS(KT1,KT2-K,1) ENDDO ENDDO ELSE MS = MBASEL**(N21-1) DO J = 2+NDIG+NGRDN, 3, -1 MR = MS MT1 = MWA(J) DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3) MWA(K-KT3) = AINT (MT1/MR) MT1 = MT1 - MWA(K-KT3)*MR MR = AINT (MR/MBASEL) ENDDO ENDDO ENDIF NDIG = NDIGL MBASE = MBASEL ELSE ! Copy MA into the working array. DO J = 2, N1 MWA(J+1) = MA(J) ENDDO MWA(2) = 0 NL = N1 + NGUARD + 3 DO J = NDIG+3, NL MWA(J) = 0 ENDDO CALL FMDIV3(MB,NG) ENDIF ! Round, affix the sign, and return. IF (MWA(2) == 0) THEN MLR = 2*MWA(NDIG+3) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,1) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1+1) = MWA(N1+1) + 1 MWA(N1+2) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,1) ENDIF ENDIF ELSE MLR = 2*MWA(NDIG+2) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,0) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1) = MWA(N1) + 1 MWA(N1+1) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,0) ENDIF ENDIF ENDIF CALL FMMOVE(MWA,MA) IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMDIV ' CALL FMWARN ENDIF MA(-1) = 1 IF (MAS*MBS < 0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1 IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315) MA(0) = MIN(MACCA,MACCB,MD2B) ELSE MA(0) = MIN(MACCA,MACCB) ENDIF JRSIGN = JRSSAV RETURN END SUBROUTINE FMDIV2_R1 SUBROUTINE FMDIV_R2(MA,MB) ! MB = MA / MB ! This routine performs the trace printing for division. ! FMDIV2_R2 is used to do the arithmetic. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMDIV ' CALL FMNTR(2,MA,MB,2,1) CALL FMDIV2_R2(MA,MB) CALL FMNTR(1,MB,MB,1,1) ELSE CALL FMDIV2_R2(MA,MB) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMDIV_R2 SUBROUTINE FMDIV2_R2(MA,MB) ! Internal division routine. MB = MA / MB USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MLR,MR,MS,MT1,MT2 INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KT3,L,N1,NG,NGUARD,NL IF (MBLOGS /= MBASE) CALL FMCONS JRSSAV = JRSIGN MACCA = MA(0) MACCB = MB(0) IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. & KDEBUG == 1) THEN CALL FMARGS('FMDIV ',2,MA,MB,KRESLT) IF (KRESLT /= 0) THEN NCALL = NCALL + 1 NAMEST(NCALL) = 'FMDIV ' CALL FMRSLT(MA,MB,M07,KRESLT) CALL FMEQ(M07,MB) JRSIGN = JRSSAV NCALL = NCALL - 1 RETURN ENDIF ELSE IF (MB(2) == 0) THEN NAMEST(NCALL) = 'FMDIV ' CALL FMIM(0,MB) KFLAG = -4 CALL FMWARN MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) JRSIGN = JRSSAV RETURN ENDIF IF (MA(2) == 0) THEN CALL FMIM(0,MB) MB(0) = MIN(MACCA,MACCB) JRSIGN = JRSSAV RETURN ENDIF ENDIF KFLAG = 0 ! NGUARD is the number of guard digits used. IF (NCALL > 1) THEN NGUARD = NGRD21 IF (NGUARD > NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 - 1 IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 10 ENDIF ENDIF N1 = NDIG + 1 NG = NDIG + NGUARD ! Save the sign of MA and MB and then work only with ! positive numbers. MAS = MA(-1) MBS = MB(-1) IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF MWA(1) = MA(1) - MB(1) + 1 IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN MBASEL = MBASE NDIGL = NDIG NGUARL = NGUARD DO J = 2, 1000 MR = MBASE*MBASEL IF (4*MR > MXBASE) THEN N21 = J - 1 NDIG = (NDIGL-1)/N21 + 1 IF (NDIG < 2) NDIG = 2 NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG IF (NGRDN < 1) NGRDN = 1 EXIT ENDIF MBASE = MR ENDDO MBASEN = MBASE NDIGN = NDIG ELSE MBASE = MBASEN NDIG = NDIGN ENDIF MPMA(1) = 0 MPMB(1) = 0 L = 2 - N21 DO J = 2, NDIGL+2-N21, N21 MT1 = MA(J) MT2 = MB(J) DO K = J+1, J+N21-1 MT1 = MT1*MBASEL + MA(K) MT2 = MT2*MBASEL + MB(K) ENDDO MPMA(2+J/N21) = MT1 MPMB(2+J/N21) = MT2 L = J ENDDO DO J = 3+L/N21, NDIG+NGRDN+2 MPMA(J) = 0 MPMB(J) = 0 ENDDO IF (L+N21 <= NDIGL+1) THEN MT1 = 0 MT2 = 0 DO J = L+N21, L+2*N21-1 IF (J <= NDIGL+1) THEN MT1 = MT1*MBASEL + MA(J) MT2 = MT2*MBASEL + MB(J) ELSE MT1 = MT1*MBASEL MT2 = MT2*MBASEL ENDIF ENDDO MPMA(2+(L+N21)/N21) = MT1 MPMB(2+(L+N21)/N21) = MT2 ENDIF NG = NDIG + NGRDN + 1 IF (MPMA(2) >= MPMB(2)) NG = NG + 1 ! Copy MA into the working array. DO J = 2, NDIG+1 MWA(J+1) = MPMA(J) ENDDO MWA(2) = 0 DO J = NDIG+3, NG+4 MWA(J) = 0 ENDDO CALL FMDIV3(MPMB,NG) KT3 = N21 - 1 IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN DO J = 2+NDIG+NGRDN, 3, -1 KT1 = MWA(J) KT = 2 + (J-2)*N21 KT2 = N21 + KT - 1 DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3) MWA(K-KT3) = IBITS(KT1,KT2-K,1) ENDDO ENDDO ELSE MS = MBASEL**(N21-1) DO J = 2+NDIG+NGRDN, 3, -1 MR = MS MT1 = MWA(J) DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3) MWA(K-KT3) = AINT (MT1/MR) MT1 = MT1 - MWA(K-KT3)*MR MR = AINT (MR/MBASEL) ENDDO ENDDO ENDIF NDIG = NDIGL MBASE = MBASEL ELSE ! Copy MA into the working array. DO J = 2, N1 MWA(J+1) = MA(J) ENDDO MWA(2) = 0 NL = N1 + NGUARD + 3 DO J = NDIG+3, NL MWA(J) = 0 ENDDO CALL FMDIV3(MB,NG) ENDIF ! Round, affix the sign, and return. IF (MWA(2) == 0) THEN MLR = 2*MWA(NDIG+3) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,1) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1+1) = MWA(N1+1) + 1 MWA(N1+2) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,1) ENDIF ENDIF ELSE MLR = 2*MWA(NDIG+2) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,0) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1) = MWA(N1) + 1 MWA(N1+1) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,0) ENDIF ENDIF ENDIF CALL FMMOVE(MWA,MB) IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMDIV ' CALL FMWARN ENDIF MB(-1) = 1 IF (MAS*MBS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1 IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MACCA,MACCB,MD2B) ELSE MB(0) = MIN(MACCA,MACCB) ENDIF JRSIGN = JRSSAV RETURN END SUBROUTINE FMDIV2_R2 SUBROUTINE FMDIV3(MB,NG) ! Internal division routine. Divide MA/MB and return the ! quotient in MWA. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MB(-1:LUNPCK) DOUBLE PRECISION XB,XBR,XBASE,XMWA REAL (KIND(1.0D0)) :: MAXMWA,MBM1,MCARRY,MKT,MLMAX,MQD INTEGER J,JB,JL,KA,KB,KL,KPTMWA,N1,NG,NL,NMBWDS,NZDMB N1 = NDIG + 1 NL = NG + 4 ! NMBWDS is the number of words of MB used to ! compute the estimated quotient digit MQD. NMBWDS = 4 IF (MBASE < 100) NMBWDS = 7 ! XB is an approximation of MB used in ! estimating the quotient digits. XBASE = DBLE(MBASE) XB = 0 JL = NMBWDS IF (JL <= N1) THEN DO J = 2, JL XB = XB*XBASE + DBLE(MB(J)) ENDDO ELSE DO J = 2, JL IF (J <= N1) THEN XB = XB*XBASE + DBLE(MB(J)) ELSE XB = XB*XBASE ENDIF ENDDO ENDIF IF (JL+1 <= N1) THEN XB = XB + DBLE(MB(JL+1))/XBASE ENDIF XBR = 1.0D0/XB ! MLMAX determines when to normalize all of MWA. MBM1 = MBASE - 1 MLMAX = MAXINT/MBM1 MKT = INTMAX - MBASE MLMAX = MIN(MLMAX,MKT) ! Count the trailing zero digits of MB. DO J = N1, 2, -1 IF (MB(J) /= 0) THEN NZDMB = N1 - J GO TO 110 ENDIF ENDDO ! MAXMWA is an upper bound on the size of values in MWA ! divided by MBASE-1. It is used to determine whether ! normalization can be postponed. 110 MAXMWA = 0 ! KPTMWA points to the next digit in the quotient. KPTMWA = 2 ! This is the start of the division loop. ! XMWA is an approximation of the active part of MWA ! used in estimating quotient digits. 120 KL = KPTMWA + NMBWDS - 1 IF (KL <= NL) THEN XMWA = ((DBLE(MWA(KPTMWA))*XBASE & + DBLE(MWA(KPTMWA+1)))*XBASE & + DBLE(MWA(KPTMWA+2)))*XBASE & + DBLE(MWA(KPTMWA+3)) DO J = KPTMWA+4, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) ENDDO ELSE XMWA = DBLE(MWA(KPTMWA)) DO J = KPTMWA+1, KL IF (J <= NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) ELSE XMWA = XMWA*XBASE ENDIF ENDDO ENDIF ! MQD is the estimated quotient digit. MQD = AINT(XMWA*XBR) IF (MQD < 0) MQD = MQD - 1 IF (MQD > 0) THEN MAXMWA = MAXMWA + MQD ELSE MAXMWA = MAXMWA - MQD ENDIF ! See if MWA must be normalized. KA = KPTMWA + 1 KB = MIN(KA+NDIG-1-NZDMB,NL) IF (MAXMWA >= MLMAX) THEN DO J = KB, KA, -1 IF (MWA(J) < 0) THEN MCARRY = INT((-MWA(J)-1)/MBASE) + 1 MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ELSE IF (MWA(J) >= MBASE) THEN MCARRY = -INT(MWA(J)/MBASE) MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ENDIF ENDDO XMWA = 0 IF (KL <= NL) THEN DO J = KPTMWA, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) ENDDO ELSE DO J = KPTMWA, KL IF (J <= NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) ELSE XMWA = XMWA*XBASE ENDIF ENDDO ENDIF MQD = AINT(XMWA*XBR) IF (MQD < 0) MQD = MQD - 1 IF (MQD > 0) THEN MAXMWA = MQD ELSE MAXMWA = -MQD ENDIF ENDIF ! Subtract MQD*MB from MWA. JB = KA - 2 IF (MQD /= 0) THEN ! Major (Inner Loop) DO J = KA, KB MWA(J) = MWA(J) - MQD*MB(J-JB) ENDDO ENDIF MWA(KA) = MWA(KA) + MWA(KA-1)*MBASE MWA(KPTMWA) = MQD KPTMWA = KPTMWA + 1 IF (KPTMWA <= NG) GO TO 120 IF (MWA(2) == 0 .AND. KPTMWA <= NG+1) GO TO 120 KL = KPTMWA + NMBWDS - 1 IF (KL <= NL) THEN XMWA = ((DBLE(MWA(KPTMWA))*XBASE & + DBLE(MWA(KPTMWA+1)))*XBASE & + DBLE(MWA(KPTMWA+2)))*XBASE & + DBLE(MWA(KPTMWA+3)) DO J = KPTMWA+4, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) ENDDO ELSE XMWA = DBLE(MWA(KPTMWA)) DO J = KPTMWA+1, KL IF (J <= NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) ELSE XMWA = XMWA*XBASE ENDIF ENDDO ENDIF MQD = AINT(XMWA*XBR) IF (MQD < 0) MQD = MQD - 1 MWA(KPTMWA) = MQD MWA(KPTMWA+1) = 0 MWA(KPTMWA+2) = 0 ! Final normalization. DO J = KPTMWA, 3, -1 IF (MWA(J) < 0) THEN MCARRY = INT((-MWA(J)-1)/MBASE) + 1 MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ELSE IF (MWA(J) >= MBASE) THEN MCARRY = -INT(MWA(J)/MBASE) MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ENDIF ENDDO RETURN END SUBROUTINE FMDIV3 SUBROUTINE FMDIVD(MA,MB,MC,MD,ME) ! Double division routine. MD = MA / MC, ME = MB / MC ! It is usually slightly faster to do two divisions that ! have a common denominator with one call. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK), & MD(-1:LUNPCK),ME(-1:LUNPCK) REAL (KIND(1.0D0)) :: MA2P,MACCA,MACCB,MACCC,MAS,MAXMWA,MB2P,MBS, & MBM1,MC2P,MCARRY,MCS,MD2B,MKT,MLMAX,MLR, & MQDMWA,MQDMWD,MTEMP DOUBLE PRECISION XB,XBR,XBASE,XMWA,XMWD INTEGER J,JB,JL,JRSSAV,KA,KB,KL,KOVUN,KPTMW,N1,NG,NGUARD,NL, & NMBWDS,NZDMB NCALL = NCALL + 1 JRSSAV = JRSIGN IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMDIVD' CALL FMNTR(2,MA,MB,2,1) IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN IF (NTRACE < 0) THEN CALL FMNTRJ(MC,NDIG) ELSE CALL FMPRNT(MC) ENDIF ENDIF ENDIF IF (MBLOGS /= MBASE) CALL FMCONS MACCA = MA(0) MACCB = MB(0) MACCC = MC(0) IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. & ABS(MC(1)) > MEXPAB .OR. MBASE*MBASE <= MXBASE/(4*MBASE)) THEN KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN .OR. & MB(1) == MEXPOV .OR. MB(1) == MEXPUN .OR. & MC(1) == MEXPOV .OR. MC(1) == MEXPUN) KOVUN = 1 IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR. & MC(1) == MUNKNO) KOVUN = 2 NCALL = NCALL + 1 CALL FMDIV2(MA,MC,MWD) KB = KFLAG CALL FMDIV2(MB,MC,ME) NCALL = NCALL - 1 IF (((KFLAG < 0 .OR. KB < 0) .AND. KOVUN == 0) .OR. & ((KFLAG == -4 .OR. KB == -4) .AND. KOVUN == 1)) THEN IF (KFLAG == -4 .OR. KB == -4) THEN KFLAG = -4 ELSE IF (KFLAG == -5 .OR. KB == -5) THEN KFLAG = -5 ELSE KFLAG = MIN(KFLAG,KB) ENDIF NAMEST(NCALL) = 'FMDIVD' CALL FMWARN ENDIF CALL FMEQ(MWD,MD) GO TO 130 ENDIF IF (MC(2) == 0) THEN NAMEST(NCALL) = 'FMDIVD' KFLAG = -4 CALL FMWARN CALL FMST2M('UNKNOWN',MD) CALL FMST2M('UNKNOWN',ME) GO TO 130 ENDIF IF (MA(2) == 0 .OR. MB(2) == 0) THEN CALL FMDIV2(MA,MC,MWD) CALL FMDIV2(MB,MC,ME) CALL FMEQ(MWD,MD) GO TO 130 ENDIF KFLAG = 0 ! NGUARD is the number of guard digits used. IF (NCALL > 1) THEN NGUARD = NGRD21 IF (NGUARD > NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 - 1 IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 10 ENDIF ENDIF MA2P = ABS(MA(2)) MB2P = ABS(MB(2)) MC2P = ABS(MC(2)) IF ((MC2P >= MA2P .OR. MC2P >= MB2P) .AND. NGUARD < 2) NGUARD = 2 N1 = NDIG + 1 NG = NDIG + NGUARD ! Copy MA and MB into the working arrays. DO J = 3, N1 MWA(J+1) = MA(J) MWD(J+1) = MB(J) ENDDO MWA(1) = MA(1) - MC(1) + 1 MWD(1) = MB(1) - MC(1) + 1 MWA(2) = 0 MWD(2) = 0 NL = N1 + NGUARD + 3 DO J = NDIG+3, NL MWA(J) = 0 MWD(J) = 0 ENDDO ! Save the signs and then work only with ! positive numbers. MAS = MA(-1) MBS = MB(-1) MCS = MC(-1) MWA(3) = MA(2) MWD(3) = MB(2) ! NMBWDS is the number of words used to compute ! the estimated quotient digits. NMBWDS = 4 IF (MBASE < 100) NMBWDS = 7 ! XB is an approximation of MC used in selecting ! estimated quotients. XBASE = DBLE(MBASE) XB = 0 JL = NMBWDS IF (JL <= N1) THEN DO J = 2, JL XB = XB*XBASE + DBLE(MC(J)) ENDDO ELSE DO J = 2, JL IF (J <= N1) THEN XB = XB*XBASE + DBLE(MC(J)) ELSE XB = XB*XBASE ENDIF ENDDO ENDIF IF (JL+1 <= N1) XB = XB + DBLE(MC(JL+1))/XBASE XBR = 1.0D0/XB ! MLMAX determines when to normalize all of MWA. MBM1 = MBASE - 1 MLMAX = MAXINT/MBM1 MKT = INTMAX - MBASE MLMAX = MIN(MLMAX,MKT) ! Count the trailing zero digits of MC. DO J = N1, 2, -1 IF (MC(J) /= 0) THEN NZDMB = N1 - J GO TO 110 ENDIF ENDDO ! MAXMWA is an upper bound on the size of values in MWA ! divided by MBASE-1. It is used to determine whether ! normalization can be postponed. 110 MAXMWA = 0 ! KPTMW points to the next digit in the quotient. KPTMW = 2 ! This is the start of the division loop. ! XMWA is an approximation of the active part of MWA ! used in selecting estimated quotients. 120 KL = KPTMW + NMBWDS - 1 IF (KL <= NL) THEN XMWA = ((DBLE(MWA(KPTMW))*XBASE & + DBLE(MWA(KPTMW+1)))*XBASE & + DBLE(MWA(KPTMW+2)))*XBASE & + DBLE(MWA(KPTMW+3)) XMWD = ((DBLE(MWD(KPTMW))*XBASE & + DBLE(MWD(KPTMW+1)))*XBASE & + DBLE(MWD(KPTMW+2)))*XBASE & + DBLE(MWD(KPTMW+3)) DO J = KPTMW+4, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) XMWD = XMWD*XBASE + DBLE(MWD(J)) ENDDO ELSE XMWA = DBLE(MWA(KPTMW)) XMWD = DBLE(MWD(KPTMW)) DO J = KPTMW+1, KL IF (J <= NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) XMWD = XMWD*XBASE + DBLE(MWD(J)) ELSE XMWA = XMWA*XBASE XMWD = XMWD*XBASE ENDIF ENDDO ENDIF ! MQDMWA and MQDMWD are the estimated quotient digits. MQDMWA = AINT(XMWA*XBR) IF (MQDMWA < 0) MQDMWA = MQDMWA - 1 MQDMWD = AINT(XMWD*XBR) IF (MQDMWD < 0) MQDMWD = MQDMWD - 1 MAXMWA = MAXMWA + MAX(ABS(MQDMWA),ABS(MQDMWD)) ! See if MWA and MWD must be normalized. KA = KPTMW + 1 KB = MIN(KA+NDIG-1-NZDMB,NL) IF (MAXMWA >= MLMAX) THEN DO J = KB, KA, -1 IF (MWA(J) < 0) THEN MCARRY = INT((-MWA(J)-1)/MBASE) + 1 MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ELSE IF (MWA(J) >= MBASE) THEN MCARRY = -INT(MWA(J)/MBASE) MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ENDIF IF (MWD(J) < 0) THEN MCARRY = INT((-MWD(J)-1)/MBASE) + 1 MWD(J) = MWD(J) + MCARRY*MBASE MWD(J-1) = MWD(J-1) - MCARRY ELSE IF (MWD(J) >= MBASE) THEN MCARRY = -INT(MWD(J)/MBASE) MWD(J) = MWD(J) + MCARRY*MBASE MWD(J-1) = MWD(J-1) - MCARRY ENDIF ENDDO XMWA = 0 XMWD = 0 IF (KL <= NL) THEN DO J = KPTMW, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) XMWD = XMWD*XBASE + DBLE(MWD(J)) ENDDO ELSE DO J = KPTMW, KL IF (J <= NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) XMWD = XMWD*XBASE + DBLE(MWD(J)) ELSE XMWA = XMWA*XBASE XMWD = XMWD*XBASE ENDIF ENDDO ENDIF MQDMWA = AINT(XMWA*XBR) IF (MQDMWA < 0) MQDMWA = MQDMWA - 1 MQDMWD = AINT(XMWD*XBR) IF (MQDMWD < 0) MQDMWD = MQDMWD - 1 MAXMWA = MAX(ABS(MQDMWA),ABS(MQDMWD)) ENDIF ! Subtract MQDMWA*MC from MWA and MQDMWD*MC from MWD. JB = KA - 2 ! Major (Inner Loop) DO J = KA, KB MTEMP = MC(J-JB) MWA(J) = MWA(J) - MQDMWA*MTEMP MWD(J) = MWD(J) - MQDMWD*MTEMP ENDDO MWA(KA) = MWA(KA) + MWA(KA-1)*MBASE MWD(KA) = MWD(KA) + MWD(KA-1)*MBASE MWA(KPTMW) = MQDMWA MWD(KPTMW) = MQDMWD KPTMW = KPTMW + 1 IF (KPTMW <= NG) GO TO 120 KL = KPTMW + NMBWDS - 1 IF (KL <= NL) THEN XMWA = ((DBLE(MWA(KPTMW))*XBASE & + DBLE(MWA(KPTMW+1)))*XBASE & + DBLE(MWA(KPTMW+2)))*XBASE & + DBLE(MWA(KPTMW+3)) XMWD = ((DBLE(MWD(KPTMW))*XBASE & + DBLE(MWD(KPTMW+1)))*XBASE & + DBLE(MWD(KPTMW+2)))*XBASE & + DBLE(MWD(KPTMW+3)) DO J = KPTMW+4, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) XMWD = XMWD*XBASE + DBLE(MWD(J)) ENDDO ELSE XMWA = DBLE(MWA(KPTMW)) XMWD = DBLE(MWD(KPTMW)) DO J = KPTMW+1, KL IF (J <= NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) XMWD = XMWD*XBASE + DBLE(MWD(J)) ELSE XMWA = XMWA*XBASE XMWD = XMWD*XBASE ENDIF ENDDO ENDIF MQDMWA = AINT(XMWA*XBR) IF (MQDMWA < 0) MQDMWA = MQDMWA - 1 MQDMWD = AINT(XMWD*XBR) IF (MQDMWD < 0) MQDMWD = MQDMWD - 1 MWA(KPTMW) = MQDMWA MWA(KPTMW+1) = 0 MWA(KPTMW+2) = 0 MWD(KPTMW) = MQDMWD MWD(KPTMW+1) = 0 MWD(KPTMW+2) = 0 ! Final normalization. DO J = KPTMW-1, 3, -1 IF (MWA(J) < 0) THEN MCARRY = INT((-MWA(J)-1)/MBASE) + 1 MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ELSE IF (MWA(J) >= MBASE) THEN MCARRY = -INT(MWA(J)/MBASE) MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ENDIF IF (MWD(J) < 0) THEN MCARRY = INT((-MWD(J)-1)/MBASE) + 1 MWD(J) = MWD(J) + MCARRY*MBASE MWD(J-1) = MWD(J-1) - MCARRY ELSE IF (MWD(J) >= MBASE) THEN MCARRY = -INT(MWD(J)/MBASE) MWD(J) = MWD(J) + MCARRY*MBASE MWD(J-1) = MWD(J-1) - MCARRY ENDIF ENDDO ! Round, affix the sign, and return. IF ((MAS > 0 .AND. MCS > 0) .OR. (MAS < 0 .AND. MCS < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF IF (MWA(2) == 0) THEN MLR = 2*MWA(NDIG+3) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,1) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1+1) = MWA(N1+1) + 1 MWA(N1+2) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,1) ENDIF ENDIF ELSE MLR = 2*MWA(NDIG+2) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,0) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1) = MWA(N1) + 1 MWA(N1+1) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,0) ENDIF ENDIF ENDIF CALL FMMOVE(MWA,MD) IF ((MBS > 0 .AND. MCS > 0) .OR. (MBS < 0 .AND. MCS < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF IF (MWD(2) == 0) THEN MLR = 2*MWD(NDIG+3) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWD,NDIG,NGUARD,1) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWD(N1+1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWD(N1+1) = MWD(N1+1) + 1 MWD(N1+2) = 0 ENDIF ELSE CALL FMRND(MWD,NDIG,NGUARD,1) ENDIF ENDIF ELSE MLR = 2*MWD(NDIG+2) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWD,NDIG,NGUARD,0) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWD(N1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWD(N1) = MWD(N1) + 1 MWD(N1+1) = 0 ENDIF ELSE CALL FMRND(MWD,NDIG,NGUARD,0) ENDIF ENDIF ENDIF CALL FMMOVE(MWD,ME) IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMDIVD' CALL FMWARN ENDIF MD(-1) = 1 IF (MAS*MCS < 0 .AND. MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -1 ME(-1) = 1 IF (MBS*MCS < 0 .AND. ME(1) /= MUNKNO .AND. ME(2) /= 0) ME(-1) = -1 IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MD(2))+1))/0.69315) MD(0) = MIN(MACCA,MACCC,MD2B) MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(ME(2))+1))/0.69315) ME(0) = MIN(MACCB,MACCC,MD2B) ELSE MD(0) = MIN(MACCA,MACCC) ME(0) = MIN(MACCB,MACCC) ENDIF 130 IF (NTRACE /= 0) THEN CALL FMNTR(1,MD,MD,1,1) IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN IF (NTRACE < 0) THEN CALL FMNTRJ(ME,NDIG) ELSE CALL FMPRNT(ME) ENDIF ENDIF ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN END SUBROUTINE FMDIVD SUBROUTINE FMDIVI(MA,IVAL,MB) ! MB = MA / IVAL ! Divide FM number MA by one word integer IVAL. ! This routine is faster than FMDIV when the divisor is less than ! MXBASE (the square root of the largest integer). ! When IVAL is not less than MXBASE, FMDIV2 is used. In this case, ! if IVAL is known to be a product of two integers less than ! MXBASE, it is usually faster to make two calls to FMDIVI with ! half-word factors than one call with their product. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER IVAL REAL (KIND(1.0D0)) :: MACCA,MD2B KFLAG = 0 MACCA = MA(0) NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMDIVI' CALL FMNTR(2,MA,MA,1,1) CALL FMNTRI(2,IVAL,0) CALL FMDIVN(MA,IVAL,MB) IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/ & 0.69315) MB(0) = MIN(MACCA,MD2B) ELSE MB(0) = MACCA ENDIF CALL FMNTR(1,MB,MB,1,1) ELSE CALL FMDIVN(MA,IVAL,MB) IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/ & 0.69315) MB(0) = MIN(MACCA,MD2B) ELSE MB(0) = MACCA ENDIF ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMDIVI SUBROUTINE FMDIVN(MA,IVAL,MB) ! Internal divide by integer routine. MB = MA / IVAL USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER IVAL REAL (KIND(1.0D0)) :: MA1,MAS,MKT,MLR,MODINT,MVALP INTEGER J,JRSSAV,KA,KB,KL,KPT,KPTWA,N1,NGUARD,NMVAL,NV2 ! Check for special cases. IF (MBLOGS /= MBASE) CALL FMCONS JRSSAV = JRSIGN N1 = NDIG + 1 IF (MA(1) == MUNKNO .OR. IVAL == 0) THEN MA1 = MA(1) CALL FMIM(0,MB) MB(0) = NINT(NDG2MX*ALOGM2) MB(1) = MUNKNO MB(2) = 1 KFLAG = -4 IF (MA1 /= MUNKNO) THEN NAMEST(NCALL) = 'FMDIVI' CALL FMWARN ENDIF JRSIGN = JRSSAV RETURN ENDIF IF (MA(2) == 0) THEN CALL FMEQ(MA,MB) JRSIGN = JRSSAV RETURN ENDIF IF (ABS(MA(1)) < MEXPOV .AND. ABS(IVAL) > 1) GO TO 110 IF (ABS(IVAL) == 1) THEN DO J = 0, N1 MB(J) = MA(J) ENDDO MB(-1) = MA(-1)*IVAL IF (MA(1) == MEXPOV) KFLAG = -5 IF (MA(1) == MEXPUN) KFLAG = -6 JRSIGN = JRSSAV RETURN ENDIF IF (MA(1) == MEXPUN) THEN MAS = MA(-1) CALL FMIM(0,MB) MB(1) = MEXPUN MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) IF ((MAS < 0 .AND. IVAL > 0) .OR. & (MAS > 0 .AND. IVAL < 0)) MB(-1) = -1 KFLAG = -6 JRSIGN = JRSSAV RETURN ENDIF IF (MA(1) == MEXPOV) THEN NAMEST(NCALL) = 'FMDIVI' CALL FMIM(0,MB) MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) KFLAG = -4 CALL FMWARN JRSIGN = JRSSAV RETURN ENDIF ! NGUARD is the number of guard digits used. 110 IF (NCALL > 1) THEN NGUARD = NGRD21 ELSE NGUARD = NGRD52 IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 10 ENDIF ENDIF ! If ABS(IVAL) >= MXBASE use FMDIV. MVALP = ABS(IVAL) NMVAL = INT(MVALP) NV2 = NMVAL - 1 IF (ABS(IVAL) > MXBASE .OR. NMVAL /= ABS(IVAL) .OR. & NV2 /= ABS(IVAL)-1) THEN CALL FMIM(IVAL,M01) CALL FMDIV2(MA,M01,MB) JRSIGN = JRSSAV RETURN ENDIF ! Work with positive numbers. MAS = MA(-1) ! Find the first significant digit of the quotient. MKT = MA(2) IF (MKT >= MVALP) THEN KPT = 2 GO TO 130 ENDIF DO J = 3, N1 MKT = MKT*MBASE + MA(J) IF (MKT >= MVALP) THEN KPT = J GO TO 130 ENDIF ENDDO KPT = N1 120 KPT = KPT + 1 MKT = MKT*MBASE IF (MKT < MVALP) GO TO 120 ! Do the rest of the division. 130 KA = KPT + 1 MWA(1) = MA(1) + 2 - KPT MWA(2) = INT (MKT/MVALP) MODINT = MKT - MWA(2)*MVALP KPTWA = 2 IF (KA <= N1) THEN KL = 3 - KA ! (Inner Loop) DO J = KA, N1 MKT = MODINT*MBASE + MA(J) MWA(KL+J) = INT (MKT/MVALP) MODINT = MKT - MWA(KL+J)*MVALP ENDDO KPTWA = KL + N1 ENDIF KA = KPTWA + 1 KB = N1 + NGUARD DO J = KA, KB MKT = MODINT*MBASE MWA(J) = INT (MKT/MVALP) MODINT = MKT - MWA(J)*MVALP ENDDO ! Round the result, put the sign on MB and return. MLR = 2*MWA(NDIG+2) + 1 IF ((MAS > 0 .AND. IVAL > 0) .OR. (MAS < 0 .AND. IVAL < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,0) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1) = MWA(N1) + 1 MWA(N1+1) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,0) ENDIF ENDIF CALL FMMOVE(MWA,MB) IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMDIVI' CALL FMWARN ENDIF MB(-1) = JRSIGN JRSIGN = JRSSAV RETURN END SUBROUTINE FMDIVN SUBROUTINE FMDIVI_R1(MA,IVAL) ! MA = MA / IVAL ! Divide FM number MA by one word integer IVAL. ! This routine is faster than FMDIV when the divisor is less than ! MXBASE (the square root of the largest integer). ! When IVAL is not less than MXBASE, FMDIV2 is used. In this case, ! if IVAL is known to be a product of two integers less than ! MXBASE, it is usually faster to make two calls to FMDIVI with ! half-word factors than one call with their product. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER IVAL REAL (KIND(1.0D0)) :: MACCA,MD2B KFLAG = 0 MACCA = MA(0) NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMDIVI' CALL FMNTR(2,MA,MA,1,1) CALL FMNTRI(2,IVAL,0) CALL FMDIVN_R1(MA,IVAL) IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/ & 0.69315) MA(0) = MIN(MACCA,MD2B) ELSE MA(0) = MACCA ENDIF CALL FMNTR(1,MA,MA,1,1) ELSE CALL FMDIVN_R1(MA,IVAL) IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/ & 0.69315) MA(0) = MIN(MACCA,MD2B) ELSE MA(0) = MACCA ENDIF ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMDIVI_R1 SUBROUTINE FMDIVN_R1(MA,IVAL) ! Internal divide by integer routine. MA = MA / IVAL USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER IVAL REAL (KIND(1.0D0)) :: MA1,MAS,MKT,MLR,MODINT,MVALP INTEGER J,JRSSAV,KA,KB,KL,KPT,KPTWA,N1,NGUARD,NMVAL,NV2 ! Check for special cases. IF (MBLOGS /= MBASE) CALL FMCONS JRSSAV = JRSIGN N1 = NDIG + 1 IF (MA(1) == MUNKNO .OR. IVAL == 0) THEN MA1 = MA(1) CALL FMIM(0,MA) MA(0) = NINT(NDG2MX*ALOGM2) MA(1) = MUNKNO MA(2) = 1 KFLAG = -4 IF (MA1 /= MUNKNO) THEN NAMEST(NCALL) = 'FMDIVI' CALL FMWARN ENDIF JRSIGN = JRSSAV RETURN ENDIF IF (MA(2) == 0) THEN JRSIGN = JRSSAV RETURN ENDIF IF (ABS(MA(1)) < MEXPOV .AND. ABS(IVAL) > 1) GO TO 110 IF (ABS(IVAL) == 1) THEN MA(-1) = MA(-1)*IVAL IF (MA(1) == MEXPOV) KFLAG = -5 IF (MA(1) == MEXPUN) KFLAG = -6 JRSIGN = JRSSAV RETURN ENDIF IF (MA(1) == MEXPUN) THEN MAS = MA(-1) CALL FMIM(0,MA) MA(1) = MEXPUN MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) IF ((MAS < 0 .AND. IVAL > 0) .OR. & (MAS > 0 .AND. IVAL < 0)) MA(-1) = -1 KFLAG = -6 JRSIGN = JRSSAV RETURN ENDIF IF (MA(1) == MEXPOV) THEN NAMEST(NCALL) = 'FMDIVI' CALL FMIM(0,MA) MA(1) = MUNKNO MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) KFLAG = -4 CALL FMWARN JRSIGN = JRSSAV RETURN ENDIF ! NGUARD is the number of guard digits used. 110 IF (NCALL > 1) THEN NGUARD = NGRD21 ELSE NGUARD = NGRD52 IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 10 ENDIF ENDIF ! If ABS(IVAL) >= MXBASE use FMDIV. MVALP = ABS(IVAL) NMVAL = INT(MVALP) NV2 = NMVAL - 1 IF (ABS(IVAL) > MXBASE .OR. NMVAL /= ABS(IVAL) .OR. & NV2 /= ABS(IVAL)-1) THEN CALL FMIM(IVAL,M01) CALL FMDIV2_R1(MA,M01) JRSIGN = JRSSAV RETURN ENDIF ! Work with positive numbers. MAS = MA(-1) ! Find the first significant digit of the quotient. MKT = MA(2) IF (MKT >= MVALP) THEN KPT = 2 GO TO 130 ENDIF DO J = 3, N1 MKT = MKT*MBASE + MA(J) IF (MKT >= MVALP) THEN KPT = J GO TO 130 ENDIF ENDDO KPT = N1 120 KPT = KPT + 1 MKT = MKT*MBASE IF (MKT < MVALP) GO TO 120 ! Do the rest of the division. 130 KA = KPT + 1 MWA(1) = MA(1) + 2 - KPT MWA(2) = INT (MKT/MVALP) MODINT = MKT - MWA(2)*MVALP KPTWA = 2 IF (KA <= N1) THEN KL = 3 - KA ! (Inner Loop) DO J = KA, N1 MKT = MODINT*MBASE + MA(J) MWA(KL+J) = INT (MKT/MVALP) MODINT = MKT - MWA(KL+J)*MVALP ENDDO KPTWA = KL + N1 ENDIF KA = KPTWA + 1 KB = N1 + NGUARD DO J = KA, KB MKT = MODINT*MBASE MWA(J) = INT (MKT/MVALP) MODINT = MKT - MWA(J)*MVALP ENDDO ! Round the result, put the sign on MA and return. MLR = 2*MWA(NDIG+2) + 1 IF ((MAS > 0 .AND. IVAL > 0) .OR. (MAS < 0 .AND. IVAL < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,0) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1) = MWA(N1) + 1 MWA(N1+1) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,0) ENDIF ENDIF CALL FMMOVE(MWA,MA) IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMDIVI' CALL FMWARN ENDIF MA(-1) = JRSIGN JRSIGN = JRSSAV RETURN END SUBROUTINE FMDIVN_R1 SUBROUTINE FMDM(X,MA) ! Internal routine for converting double precision to multiple ! precision. Called by FMDPM. USE FMVALS IMPLICIT NONE DOUBLE PRECISION X REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) DOUBLE PRECISION ONE,XBASE,Y,Y2,YT REAL (KIND(1.0D0)) :: MK,MN INTEGER J,K,N1,NE IF (MBLOGS /= MBASE) CALL FMCONS KFLAG = 0 N1 = NDIG + 1 ONE = 1.0D0 XBASE = MBASE K = 0 ! NE-1 is the number of words at the current precision and ! base roughly equal to machine precision. NE = INT(DLOGEB) + 3 Y = X IF (X < 0.0) Y = -X IF (X == 0.0) THEN DO J = 1, N1 MA(J) = 0 ENDDO GO TO 160 ENDIF ! Get the exponent. IF (Y > ONE) THEN IF (Y/XBASE < Y) THEN 110 K = K + 1 Y = Y/XBASE IF (Y > ONE) GO TO 110 IF (Y < ONE) THEN MA(1) = K GO TO 140 ENDIF GO TO 130 ELSE KFLAG = -4 CALL FMWARN DO J = 1, N1 MA(J) = 0 ENDDO MA(1) = MUNKNO MA(2) = 1 MA(-1) = 1 MA(0) = NINT(NDIG*ALOGM2) RETURN ENDIF ENDIF IF (Y < ONE) THEN IF (Y*XBASE > Y) THEN 120 K = K - 1 Y = Y*XBASE IF (Y < ONE) GO TO 120 IF (Y > ONE) THEN K = K + 1 Y = Y/XBASE MA(1) = K GO TO 140 ENDIF ELSE KFLAG = -4 CALL FMWARN DO J = 1, N1 MA(J) = 0 ENDDO MA(1) = MUNKNO MA(2) = 1 MA(-1) = 1 MA(0) = NINT(NDIG*ALOGM2) RETURN ENDIF ENDIF 130 MA(1) = K + 1 MA(2) = 1 DO J = 3, N1 MA(J) = 0 ENDDO GO TO 160 ! Build the rest of the number. 140 DO J = 2, NE Y = Y*XBASE MK = AINT(Y) YT = -MK CALL FMDBL(Y,YT,Y2) Y = Y2 MA(J) = MK IF (J >= N1) GO TO 150 ENDDO K = NE + 1 DO J = K, N1 MA(J) = 0 ENDDO ! Normalize. 150 IF (ABS(MA(2)) >= MBASE) THEN K = N1 + 1 DO J = 3, N1 K = K - 1 MA(K) = MA(K-1) ENDDO MN = AINT (MA(2)/MBASE) MA(3) = MA(2) - MN*MBASE MA(2) = MN MA(1) = MA(1) + 1 GO TO 160 ENDIF IF (MA(2) == 0) THEN DO J = 2, NDIG MA(J) = MA(J+1) ENDDO MA(1) = MA(1) - 1 MA(N1) = 0 ENDIF 160 MA(-1) = 1 IF (X < 0.0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1 MA(0) = MIN(NINT((NE-1)*ALOGM2),NINT(NDIG*ALOGM2)) RETURN END SUBROUTINE FMDM SUBROUTINE FMDM2(X,MA) ! Internal routine for converting double precision to multiple ! precision. Called by FMDP2M. USE FMVALS IMPLICIT NONE DOUBLE PRECISION X REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) DOUBLE PRECISION Y,TWO20 INTEGER J,JEXP,K,KEXP,KRESLT,N1,NDSAVE ! Increase the working precision. NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD21,1) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,M07,KRESLT) CALL FMEQ(M07,MA) IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF IF (MBLOGS /= MBASE) CALL FMCONS KFLAG = 0 N1 = NDIG + 1 IF (X == 0.0D0) THEN DO J = 1, N1 MA(J) = 0 ENDDO GO TO 140 ENDIF Y = ABS(X) TWO20 = 1048576.0D0 ! If this power of two is not representable at the current ! base and precision, use a smaller one. IF (INT(NDIG*ALOGM2) < 20) THEN K = INT(NDIG*ALOGM2) TWO20 = 1.0D0 DO J = 1, K TWO20 = TWO20*2.0D0 ENDDO ENDIF KEXP = 0 IF (Y > TWO20) THEN 110 Y = Y/TWO20 KEXP = KEXP + 1 IF (Y > TWO20) GO TO 110 ELSE IF (Y < 1.0D0) THEN 120 Y = Y*TWO20 KEXP = KEXP - 1 IF (Y < 1.0D0) GO TO 120 ENDIF K = INT(TWO20) CALL FMI2M(K,M04) K = INT(Y) CALL FMI2M(K,M02) Y = (Y-DBLE(K))*TWO20 JEXP = 0 130 K = INT(Y) CALL FMI2M(K,M03) CALL FMMPY_R1(M02,M04) JEXP = JEXP + 1 CALL FMADD_R1(M02,M03) Y = (Y-DBLE(K))*TWO20 IF (JEXP <= 1000 .AND. Y /= 0.0D0) GO TO 130 K = KEXP - JEXP CALL FMIPWR(M04,K,M03) CALL FMMPY(M02,M03,MA) 140 MA(-1) = 1 IF (X < 0.0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1 MA(0) = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315) NDIG = NDSAVE RETURN END SUBROUTINE FMDM2 SUBROUTINE FMDP2M(X,MA) ! MA = X ! Convert a double precision floating point number to FM format. ! This version tries to convert the REAL (KIND(1.0D0)) :: Machine ! number to FM with accuracy of nearly full FM precision. ! If conversion to FM with approximately double precision accuracy ! is good enough, FMDPM is faster and uses less scratch space. ! This routine assumes the machine's base for double precision is ! a power of two. USE FMVALS IMPLICIT NONE DOUBLE PRECISION X REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) NCALL = NCALL + 1 NAMEST(NCALL) = 'FMDP2M' IF (NTRACE /= 0) CALL FMNTRR(2,X,1) CALL FMDM2(X,MA) IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMDP2M SUBROUTINE FMDPM(X,MA) ! MA = X ! Convert a double precision floating point number to FM format. ! In general, the relative accuracy of the FM number returned is only ! the relative accuracy of a machine precision number. This may be ! true even if X can be represented exactly in the machine floating ! point number system. ! This version is faster than FMDP2M, but often less accurate. ! No scratch arrays are used. USE FMVALS IMPLICIT NONE DOUBLE PRECISION X REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) DOUBLE PRECISION Y,YT INTEGER K NCALL = NCALL + 1 NAMEST(NCALL) = 'FMDPM ' IF (NTRACE /= 0) CALL FMNTRR(2,X,1) ! Check to see if X is exactly a small integer. If so, ! converting as an integer is better. ! Also see if X is exactly a small integer divided by ! a small power of two. Y = 1048576.0D0 IF (ABS(X) < Y) THEN K = INT(X) Y = K IF (Y == X) THEN CALL FMIM(K,MA) GO TO 110 ENDIF ENDIF IF (ABS(X) < 1.0D0) THEN Y = 4096.0D0*X K = INT(Y) YT = K IF (Y == YT) THEN CALL FMIM(K,MA) CALL FMDIVI_R1(MA,4096) GO TO 110 ENDIF ENDIF CALL FMDM(X,MA) 110 IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMDPM SUBROUTINE FMENTR(NROUTN,MA,MB,NARGS,KNAM,MC,KRESLT,NDSAVE,MXSAVE, & KASAVE,KOVUN) ! Do the argument checking and increasing of precision and overflow ! threshold upon entry to an FM routine. ! NROUTN - routine name of calling routine ! MA - first input argument ! MB - second input argument (optional) ! NARGS - number of input arguments ! KNAM - positive if the routine name is to be printed. ! MC - result argument ! KRESLT - returned nonzero if the input arguments give the result ! immediately (e.g., MA*0 or OVERFLOW*MB) ! NDSAVE - saves the value of NDIG after NDIG is increased ! MXSAVE - saves the value of MXEXP ! KASAVE - saves the value of KACCSW ! KOVUN - returned nonzero if an input argument is (+ or -) overflow ! or underflow. USE FMVALS IMPLICIT NONE CHARACTER(6) :: NROUTN REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK),MXSAVE INTEGER KNAM,NARGS,KRESLT,NDSAVE,KASAVE,KOVUN REAL (KIND(1.0D0)) :: MACCAB INTEGER K NCALL = NCALL + 1 NAMEST(NCALL) = NROUTN IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,NARGS,KNAM) CALL FMARGS(NROUTN,NARGS,MA,MB,KRESLT) IF (MBLOGS /= MBASE) CALL FMCONS KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 IF (NARGS == 2) THEN IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1 ENDIF ! Increase the working precision. NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN KRESLT = 12 NDIG = NDSAVE ENDIF ENDIF IF (KRESLT /= 0) THEN MACCAB = MA(0) IF (NARGS == 2) MACCAB = MIN(MACCAB,MB(0)) IF (KRESLT == 9 .OR. KRESLT == 10 .OR. KRESLT >= 13) THEN IF (KRAD == 1) THEN CALL FMPI(MC) ELSE CALL FMI2M(180,MC) ENDIF IF (KRESLT <= 10) CALL FMDIVI_R1(MC,2) IF (KRESLT >= 14) CALL FMDIVI_R1(MC,4) CALL FMEQ2_R1(MC,NDIG,NDSAVE) NDIG = NDSAVE IF ((KRESLT == 9 .OR. KRESLT == 14) .AND. & MC(1) /= MUNKNO .AND. MC(2) /= 0) & MC(-1) = -MC(-1) MC(0) = MACCAB IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1) KASAVE = KACCSW MXSAVE = MXEXP NCALL = NCALL - 1 RETURN ENDIF NDIG = NDSAVE CALL FMRSLT(MA,MB,MC,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1) KASAVE = KACCSW MXSAVE = MXEXP NCALL = NCALL - 1 RETURN ENDIF KASAVE = KACCSW KACCSW = 0 ! Extend the overflow/underflow threshold. MXSAVE = MXEXP MXEXP = MXEXP2 RETURN END SUBROUTINE FMENTR SUBROUTINE FMEQ(MA,MB) ! MB = MA ! This is the standard form of equality, where MA and MB both ! have precision NDIG. Use FMEQU for assignments that also ! change precision. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER J DO J = -1, NDIG+1 MB(J) = MA(J) ENDDO ! Check for overflow or underflow. IF (ABS(MB(1)) > MXEXP) THEN IF (MB(1) /= MUNKNO .OR. MB(2) /= 1) THEN NCALL = NCALL + 1 CALL FMTRAP(MB) NCALL = NCALL - 1 ENDIF IF (MB(1) == MUNKNO) KFLAG = -4 ENDIF RETURN END SUBROUTINE FMEQ SUBROUTINE FMEQ2(MA,MB,NDA,NDB) ! Set MB (having NDB digits) equal to MA (having NDA digits). ! If MB has less precision than MA the result is rounded to NDB digits. ! If MB has more precision the result has zero digits padded on the ! right. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER NDA,NDB REAL (KIND(1.0D0)) :: M2,MACCA,MBS,MKT INTEGER J,JT,K,KB,L,N1 IF (MBLOGS /= MBASE) CALL FMCONS MACCA = MA(0) ! Check for precision in range. IF (NDA < 1 .OR. NDA > NDG2MX .OR. NDB < 1 .OR. & NDB > NDG2MX) THEN NCALL = NCALL + 1 NAMEST(NCALL) = 'FMEQU ' KFLAG = -1 CALL FMWARN WRITE (KW, & "(/' The two precisions in FMEQU were NDA =',I10," // & "' NDB =',I10/)" & ) NDA,NDB CALL FMIM(0,MB) KFLAG = -1 MB(1) = MUNKNO MB(2) = 1 MB(0) = NINT(NDIG*ALOGM2) NCALL = NCALL - 1 RETURN ENDIF MBS = MA(-1) MB(-1) = MBS ! Check for special symbols. KFLAG = 0 IF (ABS(MA(1)) >= MEXPOV) THEN DO J = 2, NDB MB(J+1) = 0 ENDDO MB(1) = MA(1) MB(2) = MA(2) GO TO 150 ENDIF IF (NDB == NDA) GO TO 130 IF (NDB > NDA) GO TO 140 ! Round to NDB digits. N1 = NDB + 1 DO J = 1, N1 MB(J) = MA(J) ENDDO IF (KROUND == -1 .AND. NCALL <= 1) THEN IF (MA(-1) > 0) GO TO 150 DO J = NDB+2, NDA+1 IF (MA(J) > 0) GO TO 110 ENDDO GO TO 150 ENDIF IF (KROUND == 2 .AND. NCALL <= 1) THEN IF (MA(-1) < 0) GO TO 150 DO J = NDB+2, NDA+1 IF (MA(J) > 0) GO TO 110 ENDDO GO TO 150 ENDIF IF (KROUND == 0 .AND. NCALL <= 1) GO TO 150 L = NDB + 2 IF (2*(MA(L)+1) < MBASE) GO TO 150 M2 = 2 IF (INT(MBASE-AINT (MBASE/M2)*M2) == 0) THEN IF (2*MA(L) < MBASE) GO TO 150 IF (2*MA(L) == MBASE) THEN IF (L <= NDA) THEN DO J = L, NDA IF (MA(J+1) > 0) GO TO 110 ENDDO ENDIF ! Round to even. IF (INT(MB(N1)-AINT (MB(N1)/M2)*M2) == 0) GO TO 150 ENDIF ELSE IF (2*MA(L)+1 == MBASE) THEN IF (L <= NDA) THEN DO J = L, NDA IF (2*(MA(J+1)+1) < MBASE) GO TO 150 IF (2*MA(J+1) > MBASE) GO TO 110 ENDDO GO TO 150 ENDIF ENDIF ENDIF 110 MB(NDB+1) = MB(NDB+1) + 1 MB(NDB+2) = 0 ! Check whether there was a carry in the rounded digit. KB = NDB + 1 IF (KB >= 3) THEN K = KB + 1 DO J = 3, KB K = K - 1 IF (MB(K) < MBASE) GO TO 120 MKT = AINT (MB(K)/MBASE) MB(K-1) = MB(K-1) + MKT MB(K) = MB(K) - MKT*MBASE ENDDO ENDIF ! If there is a carry in the first digit then the exponent ! must be adjusted and the number shifted right. IF (MB(2) < MBASE) GO TO 120 IF (KB >= 4) THEN K = KB + 1 DO J = 4, KB K = K - 1 MB(K) = MB(K-1) ENDDO ENDIF MKT = AINT (MB(2)/MBASE) IF (KB >= 3) MB(3) = MB(2) - MKT*MBASE MB(2) = MKT MB(1) = MB(1) + 1 120 IF (MBS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1 GO TO 150 ! MA and MB have the same precision. 130 DO J = 1, NDA+1 MB(J) = MA(J) ENDDO GO TO 150 ! Extend to NDB digits by padding with zeros. 140 DO J = 1, NDA+1 MB(J) = MA(J) ENDDO DO J = NDA+2, NDB+1 MB(J) = 0 ENDDO ! Check for overflow or underflow. 150 IF (ABS(MB(1)) > MXEXP) THEN IF (MB(1) /= MUNKNO .OR. MB(2) /= 1) THEN NCALL = NCALL + 1 CALL FMTRAP(MB) NCALL = NCALL - 1 ENDIF IF (MB(1) == MUNKNO) KFLAG = -4 ENDIF IF (KACCSW == 1) THEN JT = NINT(LOG(REAL(ABS(MB(2))+1))/0.69315) IF (NDB > NDA) THEN MB(0) = NINT((NDB-1)*ALOGM2 + JT) ELSE MB(0) = MIN(NINT((NDB-1)*ALOGM2+JT),INT(MACCA)) ENDIF ELSE MB(0) = MA(0) ENDIF RETURN END SUBROUTINE FMEQ2 SUBROUTINE FMEQ2_R1(MA,NDA,NDB) ! Change precision of MA from NDA digits on input to NDB digits on output. ! If NDB is less than NDA the result is rounded to NDB digits. ! If NDB is greater than NDA the result has zero digits padded on the ! right. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER NDA,NDB REAL (KIND(1.0D0)) :: M2,MACCA,MBS,MKT INTEGER J,JT,K,KB,L,N1 IF (MBLOGS /= MBASE) CALL FMCONS MACCA = MA(0) ! Check for precision in range. IF (NDA < 1 .OR. NDA > NDG2MX .OR. NDB < 1 .OR. & NDB > NDG2MX) THEN NCALL = NCALL + 1 NAMEST(NCALL) = 'FMEQU ' KFLAG = -1 CALL FMWARN WRITE (KW, & "(/' The two precisions in FMEQU were NDA =',I10," // & "' NDB =',I10/)" & ) NDA,NDB CALL FMIM(0,MA) KFLAG = -1 MA(1) = MUNKNO MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) NCALL = NCALL - 1 RETURN ENDIF MBS = MA(-1) ! Check for special symbols. KFLAG = 0 IF (ABS(MA(1)) >= MEXPOV) THEN DO J = 2, NDB MA(J+1) = 0 ENDDO GO TO 140 ENDIF IF (NDB == NDA) GO TO 140 IF (NDB > NDA) GO TO 130 ! Round to NDB digits. N1 = NDB + 1 IF (KROUND == -1 .AND. NCALL <= 1) THEN IF (MA(-1) > 0) GO TO 140 DO J = NDB+2, NDA+1 IF (MA(J) > 0) GO TO 110 ENDDO GO TO 140 ENDIF IF (KROUND == 2 .AND. NCALL <= 1) THEN IF (MA(-1) < 0) GO TO 140 DO J = NDB+2, NDA+1 IF (MA(J) > 0) GO TO 110 ENDDO GO TO 140 ENDIF IF (KROUND == 0 .AND. NCALL <= 1) GO TO 140 L = NDB + 2 IF (2*(MA(L)+1) < MBASE) GO TO 140 M2 = 2 IF (INT(MBASE-AINT (MBASE/M2)*M2) == 0) THEN IF (2*MA(L) < MBASE) GO TO 140 IF (2*MA(L) == MBASE) THEN IF (L <= NDA) THEN DO J = L, NDA IF (MA(J+1) > 0) GO TO 110 ENDDO ENDIF ! Round to even. IF (INT(MA(N1)-AINT (MA(N1)/M2)*M2) == 0) GO TO 140 ENDIF ELSE IF (2*MA(L)+1 == MBASE) THEN IF (L <= NDA) THEN DO J = L, NDA IF (2*(MA(J+1)+1) < MBASE) GO TO 140 IF (2*MA(J+1) > MBASE) GO TO 110 ENDDO GO TO 140 ENDIF ENDIF ENDIF 110 MA(NDB+1) = MA(NDB+1) + 1 MA(NDB+2) = 0 ! Check whether there was a carry in the rounded digit. KB = NDB + 1 IF (KB >= 3) THEN K = KB + 1 DO J = 3, KB K = K - 1 IF (MA(K) < MBASE) GO TO 120 MKT = AINT (MA(K)/MBASE) MA(K-1) = MA(K-1) + MKT MA(K) = MA(K) - MKT*MBASE ENDDO ENDIF ! If there is a carry in the first digit then the exponent ! must be adjusted and the number shifted right. IF (MA(2) < MBASE) GO TO 120 IF (KB >= 4) THEN K = KB + 1 DO J = 4, KB K = K - 1 MA(K) = MA(K-1) ENDDO ENDIF MKT = AINT (MA(2)/MBASE) IF (KB >= 3) MA(3) = MA(2) - MKT*MBASE MA(2) = MKT MA(1) = MA(1) + 1 120 IF (MBS < 0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1 GO TO 140 ! Extend to NDB digits by padding with zeros. 130 DO J = NDA+2, NDB+1 MA(J) = 0 ENDDO ! Check for overflow or underflow. 140 IF (ABS(MA(1)) > MXEXP) THEN IF (MA(1) /= MUNKNO .OR. MA(2) /= 1) THEN NCALL = NCALL + 1 CALL FMTRAP(MA) NCALL = NCALL - 1 ENDIF IF (MA(1) == MUNKNO) KFLAG = -4 ENDIF IF (KACCSW == 1) THEN JT = NINT(LOG(REAL(ABS(MA(2))+1))/0.69315) IF (NDB > NDA) THEN MA(0) = NINT((NDB-1)*ALOGM2 + JT) ELSE MA(0) = MIN(NINT((NDB-1)*ALOGM2+JT),INT(MACCA)) ENDIF ENDIF RETURN END SUBROUTINE FMEQ2_R1 SUBROUTINE FMEQU(MA,MB,NDA,NDB) ! Set MB (having NDB digits) equal to MA (having NDA digits). ! If MB has less precision than MA, the result is rounded to ! NDB digits. ! If MB has more precision, the result has its precision extended ! by padding with zero digits on the right. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER NDA,NDB CALL FMEQ2(MA,MB,NDA,NDB) RETURN END SUBROUTINE FMEQU SUBROUTINE FMEXIT(MT,MC,NDSAVE,MXSAVE,KASAVE,KOVUN) ! Upon exit from an FM routine the result MT (having precision NDIG) ! is rounded and returned in MC (having precision NDSAVE). ! The values of NDIG, MXEXP, and KACCSW are restored. ! KOVUN is nonzero if one of the routine's input arguments was overflow ! or underflow. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MT(-1:LUNPCK),MC(-1:LUNPCK),MXSAVE INTEGER NDSAVE,KASAVE,KOVUN INTEGER KFSAVE,KWRNSV KWRNSV = KWARN KWARN = 0 MXEXP = MXSAVE KFSAVE = KFLAG CALL FMEQ2(MT,MC,NDIG,NDSAVE) IF (KFLAG /= -5 .AND. KFLAG /= -6) KFLAG = KFSAVE NDIG = NDSAVE KWARN = KWRNSV IF (KFLAG == 1) KFLAG = 0 IF ((MC(1) == MUNKNO .AND. KFLAG /= -9) & .OR. (MC(1) == MEXPUN .AND. KOVUN == 0) & .OR. (MC(1) == MEXPOV .AND. KOVUN == 0)) CALL FMWARN IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1) NCALL = NCALL - 1 KACCSW = KASAVE RETURN END SUBROUTINE FMEXIT SUBROUTINE FMEXP(MA,MB) ! MB = EXP(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) CHARACTER(155) :: STRING REAL (KIND(1.0D0)) :: M1,MA1,MA2,MACCA,MACMAX,MAS,MXSAVE INTEGER IEXTRA,J,K,KASAVE,KOVUN,KRESLT,KT,KWRNSV,NDMB, & NDSAVE,NDSV,NMETHD REAL XMA,XOV IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN CALL FMENTR('FMEXP ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMEXP ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF MA1 = MA(1) MA2 = MA(2) MAS = MA(-1) MACCA = MA(0) CALL FMEQ2(MA,MB,NDSAVE,NDIG) MB(0) = NINT(NDIG*ALOGM2) ! Check for obvious underflow or overflow. ! XOV is LN(LN(slightly above overflow)) ! XMA is LN(LN(EXP(MA))) approximately. XOV = LOG(1.01*REAL(MXEXP)) + LOG(ALOGMB) M1 = 1 XMA = LOG(REAL(MAX(ABS(MA2),M1))) - ALOGMB + & REAL(MA1)*ALOGMB 110 IF (XMA >= XOV) THEN CALL FMIM(0,MB) IF (MAS > 0) THEN KFLAG = -5 CALL FMST2M('OVERFLOW',MB) ELSE KFLAG = -6 CALL FMST2M('UNDERFLOW',MB) ENDIF NDIG = NDSAVE MXEXP = MXSAVE KACCSW = KASAVE CALL FMWARN IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ! Split MA into integer and fraction parts. ! Work with a positive argument. ! M02 = integer part of ABS(MA) ! MB = fraction part of ABS(MA) MB(-1) = 1 CALL FMINT(MB,M02) CALL FMSUB_R1(MB,M02) ! If the integer part is not zero, use FMIPWR to compute ! E**(M02). If M02 is too large to represent as a one word ! integer, the definition of MXEXP insures that E**(M02) ! overflows or underflows. KWRNSV = KWARN KWARN = 0 CALL FMM2I(M02,KT) KWARN = KWRNSV IF (KFLAG /= 0) THEN XMA = XOV GO TO 110 ENDIF IF (KT > 0) THEN ! Compute IEXTRA, the number of extra digits required ! to get EXP(KT) correct to the current precision. IEXTRA = INT(LOG(REAL(KT))/ALOGMB + 0.5) IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN CALL FMEQ2_R1(MB,NDIG,NDIG+IEXTRA) ENDIF NDIG = NDIG + IEXTRA IF (NDIG > NDG2MX) THEN IF (NCALL == 1) THEN KFLAG = -9 CALL FMWARN NDIG = NDIG - IEXTRA CALL FMST2M('UNKNOWN',MB) DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN ELSE CALL FMEQ2_R1(MB,NDIG-IEXTRA,NDG2MX) NDIG = NDG2MX ENDIF ENDIF ! Check whether the current precision of e is large ! enough. IF (MBSE /= MBASE .OR. NDIG > NDIGE) THEN NDMB = INT(150.0*2.302585/ALOGMB) IF (NDMB >= NDIG) THEN NDSV = NDIG NDIG = MIN(NDMB,NDG2MX) STRING = '2.718281828459045235360287471352662497757247'// & '09369995957496696762772407663035354759457138217852516'// & '6427427466391932003059921817413596629043572900334295261' CALL FMST2M(STRING,MESAV) MESAV(0) = NINT(NDIG*ALOGM2) MBSE = MBASE NDIGE = NDIG IF (ABS(MESAV(1)) > 10) NDIGE = 0 NDIG = NDSV ELSE NDSV = NDIG NDIG = MIN(NDIG+2,NDG2MX) CALL FMI2M(1,MESAV) CALL FMEXP2(MESAV,M09) CALL FMEQ(M09,MESAV) MESAV(0) = NINT(NDIG*ALOGM2) MBSE = MBASE NDIGE = NDIG IF (ABS(MESAV(1)) > 10) NDIGE = 0 NDIG = NDSV ENDIF ENDIF ENDIF ! Now do the fraction part of MA and combine the results. KWRNSV = KWARN KWARN = 0 NMETHD = 1 IF (NDIG > 50) NMETHD = 2 IF (MB(2) /= 0 .AND. KT > 0 .AND. NMETHD == 1) THEN CALL FMEXP2(MB,M09) CALL FMEQ(M09,MB) CALL FMIPWR(MESAV,KT,M03) CALL FMMPY_R1(MB,M03) ELSE IF (MB(2) /= 0 .AND. KT == 0 .AND. NMETHD == 1) THEN CALL FMEXP2(MB,M09) CALL FMEQ(M09,MB) ELSE IF (MB(2) /= 0 .AND. KT > 0 .AND. NMETHD == 2) THEN NDSV = NDIG NDIG = MIN(NDIG+NGRD21,NDG2MX) CALL FMEQ2_R1(MB,NDSV,NDIG) IF (MB(1) >= 0) THEN CALL FMCSH2(MB,M09) CALL FMEQ(M09,MB) CALL FMSQR(MB,M03) CALL FMI2M(-1,M02) CALL FMADD_R1(M03,M02) CALL FMSQRT_R1(M03) CALL FMADD_R1(MB,M03) ELSE CALL FMSNH2(MB,M09) CALL FMEQ(M09,MB) CALL FMSQR(MB,M03) CALL FMI2M(1,M02) CALL FMADD_R1(M03,M02) CALL FMSQRT_R1(M03) CALL FMADD_R1(MB,M03) ENDIF NDIG = NDSV CALL FMIPWR(MESAV,KT,M03) CALL FMMPY_R1(MB,M03) ELSE IF (MB(2) /= 0 .AND. KT == 0 .AND. NMETHD == 2) THEN NDSV = NDIG NDIG = MIN(NDIG+NGRD21,NDG2MX) CALL FMEQ2_R1(MB,NDSV,NDIG) IF (MB(1) >= 0) THEN CALL FMCSH2(MB,M09) CALL FMEQ(M09,MB) CALL FMSQR(MB,M03) CALL FMI2M(-1,M02) CALL FMADD_R1(M03,M02) CALL FMSQRT_R1(M03) CALL FMADD_R1(MB,M03) ELSE CALL FMSNH2(MB,M09) CALL FMEQ(M09,MB) CALL FMSQR(MB,M03) CALL FMI2M(1,M02) CALL FMADD_R1(M03,M02) CALL FMSQRT_R1(M03) CALL FMADD_R1(MB,M03) ENDIF NDIG = NDSV ELSE IF (MB(2) == 0 .AND. KT > 0) THEN CALL FMIPWR(MESAV,KT,MB) ELSE CALL FMI2M(1,MB) ENDIF ! Invert if MA was negative. IF (MAS < 0) THEN CALL FMI2M(1,M02) CALL FMDIV_R2(M02,MB) ENDIF KWARN = KWRNSV ! Round the result and return. MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MACCA,MACMAX) DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMEXP SUBROUTINE FMEXP2(MA,MB) ! MB = EXP(MA) ! Internal exponential routine (called with 0 < MA <= 1). USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) ! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent ! sums. Increasing this value will begin to improve the ! speed of EXP when the base is large and precision exceeds ! about 1,500 decimal digits. REAL (KIND(1.0D0)) :: MAXVAL INTEGER J,J2,K,K2,KPT,KTWO,L,L2,N2,NBIG,NBOT,NDSAV1,NDSAVE, & NTERM,NTOP REAL ALOG2,ALOGT,B,T,TJ,XN IF (MBLOGS /= MBASE) CALL FMCONS NDSAVE = NDIG IF (MA(1) == 1) THEN ! Here the special case EXP(1.0) is computed. ! Use the direct series e = 1/0! + 1/1! + 1/2! + ... ! Do as much of the work as possible using small integers ! to minimize the number of FM calls. ! Reduce NDIG while computing each term in the ! sum as the terms get smaller. T = NDIG XN = T*ALOGMB/LOG(T) K = INT(LOG(XN)/ALOGMB) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN IF (NCALL == 1) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MB) RETURN ELSE NDIG = NDG2MX ENDIF ENDIF NDSAV1 = NDIG CALL FMI2M(2,MB) CALL FMI2M(1,M02) J = 2 NBIG = INT(MXBASE) 110 NTOP = 1 NBOT = J 120 IF (NBOT > NBIG/(J+1)) GO TO 130 J = J + 1 NTOP = J*NTOP + 1 NBOT = J*NBOT GO TO 120 130 CALL FMDIVI_R1(M02,NBOT) IF (NTOP > 1) THEN CALL FMMPYI(M02,NTOP,M03) NDIG = NDSAV1 CALL FMADD_R1(MB,M03) NDIG = NDSAV1 - INT(MB(1)-M03(1)) ELSE NDIG = NDSAV1 CALL FMADD_R1(MB,M02) NDIG = NDSAV1 - INT(MB(1)-M02(1)) ENDIF IF (NDIG < 2) NDIG = 2 IF (KFLAG /= 1) THEN J = J + 1 GO TO 110 ENDIF NDIG = NDSAVE CALL FMI2M(-1,M02) CALL FMADD(MB,M02,M03) KFLAG = 0 RETURN ENDIF ! Here is the general case. Compute EXP(MA) where ! 0 < MA < 1. ! Use the direct series ! EXP(X) = 1 + X + X**2/2! + X**3/3! + ... ! The argument will be halved K2 times before the series ! is summed. The series will be added as J2 concurrent ! series. The approximately optimal values of K2 and J2 ! are now computed to try to minimize the time required. ! N2 is the approximate number of terms of the series that ! will be needed, and L2 guard digits will be carried. B = REAL(MBASE) K = NGRD52 T = MAX(NDIG-K,2) ALOG2 = REAL(DLOGTW) ALOGT = LOG(T) TJ = 0.051*ALOGMB*T**0.3333 + 1.85 J2 = INT(TJ) J2 = MAX(1,MIN(J2,LJSUMS/NDG2MX)) K2 = INT(1.13*SQRT(T*ALOGMB/TJ) - 0.5*ALOGT + 4.5) L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B + & REAL(MA(3))/(B*B)))/ALOG2 - 0.3) K2 = K2 - L IF (L < 0) L = 0 IF (K2 < 0) THEN K2 = 0 J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) + .33) ENDIF IF (J2 <= 1) J2 = 1 N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) L2 = INT(LOG(REAL(N2)+2.0**K2)/ALOGMB) NDIG = NDIG + L2 IF (NDIG > NDG2MX) THEN IF (NCALL == 1) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MB) RETURN ELSE NDIG = NDG2MX ENDIF ENDIF NDSAV1 = NDIG ! Halve the argument K2 times. CALL FMEQ2(MA,M02,NDSAVE,NDIG) KTWO = 1 MAXVAL = MXBASE/2 IF (K2 > 0) THEN DO J = 1, K2 KTWO = 2*KTWO IF (KTWO > MAXVAL) THEN CALL FMDIVI_R1(M02,KTWO) KTWO = 1 ENDIF ENDDO IF (KTWO > 1) CALL FMDIVI_R1(M02,KTWO) ENDIF ! Sum the series X + X**2/2! + X**3/3! + .... ! Split into J2 concurrent sums and reduce NDIG while ! computing each term in the sum as the terms get smaller. CALL FMEQ(M02,MB) NTERM = 1 DO J = 1, J2 CALL FMDIVI_R1(MB,NTERM) NTERM = NTERM + 1 KPT = (J-1)*(NDIG+3) CALL FMEQ(MB,MJSUMS(KPT-1)) ENDDO IF (M02(1) < -NDIG) GO TO 150 CALL FMIPWR(M02,J2,M03) 140 CALL FMMPY_R1(MB,M03) DO J = 1, J2 CALL FMDIVI_R1(MB,NTERM) KPT = (J-1)*(NDSAV1+3) NDIG = NDSAV1 CALL FMADD_R1(MJSUMS(KPT-1),MB) IF (KFLAG /= 0) GO TO 150 NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-MB(1)) IF (NDIG < 2) NDIG = 2 NTERM = NTERM + 1 ENDDO GO TO 140 ! Put the J2 separate sums back together. 150 KFLAG = 0 KPT = (J2-1)*(NDIG+3) CALL FMEQ(MJSUMS(KPT-1),M03) IF (J2 >= 2) THEN DO J = 2, J2 CALL FMMPY_R2(M02,M03) KPT = (J2-J)*(NDIG+3) CALL FMADD_R1(M03,MJSUMS(KPT-1)) ENDDO ENDIF ! Reverse the effect of halving the argument to ! compute EXP(MA). NDIG = NDSAV1 IF (K2 > 0) THEN IF (NDSAVE <= 20) THEN CALL FMI2M(2,M02) DO J = 1, K2 CALL FMADD(M03,M02,MB) CALL FMMPY_R2(MB,M03) ENDDO ELSE DO J = 1, K2 CALL FMSQR(M03,MB) CALL FMADD(M03,M03,M02) CALL FMADD(MB,M02,M03) ENDDO ENDIF ENDIF CALL FMI2M(1,M02) CALL FMADD(M02,M03,MB) CALL FMEQ2_R1(MB,NDSAV1,NDSAVE) NDIG = NDSAVE RETURN END SUBROUTINE FMEXP2 SUBROUTINE FMFLAG(K) ! Return the internal condition variable KFLAG to the user. USE FMVALS IMPLICIT NONE INTEGER K K = KFLAG RETURN END SUBROUTINE FMFLAG SUBROUTINE FMFORM(FORM,MA,STRING) ! Convert an FM number (MA) to a character string base 10 (STRING) ! using character string FORM format. ! FORM can be one of these types: Iw, Fw.d, Ew.d, 1PEw.d ! for positive integers w,d. ! If Iw format is used and MA is not exactly an integer, then the ! nearest integer to MA is printed. USE FMVALS IMPLICIT NONE CHARACTER(*) :: FORM,STRING REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) CHARACTER(20) :: FORMB INTEGER J,JF1SAV,JF2SAV,JPT,K1,K2,K3,KD,KSAVE,KWD,KWI,LAST, & LB,LENGFM,LENGST,LFIRST,ND,NEXP NCALL = NCALL + 1 NAMEST(NCALL) = 'FMFORM' KSAVE = KFLAG JF1SAV = JFORM1 JF2SAV = JFORM2 STRING = ' ' LENGFM = LEN(FORM) LENGST = LEN(STRING) KWI = 75 KWD = 40 IF (INDEX(FORM,'I') > 0 .OR. INDEX(FORM,'i') > 0) THEN K1 = MAX(INDEX(FORM,'I'),INDEX(FORM,'i')) + 1 K2 = LENGFM WRITE (FORMB,"('(I',I5,')')") K2-K1+1 IF (K2 >= K1) THEN READ (FORM(K1:K2),FORMB) KWI ELSE KWI = LENGST ENDIF KWI = MAX(1,MIN(KWI,LENGST)) JFORM1 = 2 JFORM2 = 0 KWD = KWI + 21 IF (KWD > LMBUFF) GO TO 120 CALL FMNINT(MA,M02) IF (M02(2) /= 0) THEN CALL FMOUT(M02,CMBUFF,KWD) ELSE DO J = 1, KWD CMBUFF(J) = ' ' ENDDO CMBUFF(2) = '0' ENDIF LFIRST = 1 LAST = 1 DO J = 1, KWD IF (CMBUFF(KWD+1-J) /= ' ') LFIRST = KWD+1-J IF (CMBUFF(J) /= ' ') LAST = J ENDDO JPT = 1 IF (LAST-LFIRST+1 > KWI) GO TO 120 IF (LAST <= KWI) THEN DO J = LAST, LFIRST, -1 JPT = KWI - LAST + J STRING(JPT:JPT) = CMBUFF(J) ENDDO DO J = 1, JPT-1 STRING(J:J) = ' ' ENDDO ELSE DO J = LFIRST, LAST JPT = KWI - LAST + J STRING(JPT:JPT) = CMBUFF(J) ENDDO ENDIF ELSE IF (INDEX(FORM,'F') > 0 .OR. INDEX(FORM,'f') > 0) THEN K1 = MAX(INDEX(FORM,'F'),INDEX(FORM,'f')) + 1 K2 = INDEX(FORM,'.') K3 = LENGFM IF (K2 > K1) THEN WRITE (FORMB,"('(I',I5,')')") K2-K1 READ (FORM(K1:K2-1),FORMB) KWI ELSE KWI = 50 ENDIF IF (K3 > K2) THEN WRITE (FORMB,"('(I',I5,')')") K3-K2 READ (FORM(K2+1:K3),FORMB) KD ELSE KD = 0 ENDIF KWI = MAX(1,MIN(KWI,LENGST)) KD = MAX(0,MIN(KD,KWI-2)) JFORM1 = 2 JFORM2 = KD ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1 IF (ND < 2) ND = 2 NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6 LB = MAX(JFORM2+NEXP,ND+NEXP) LB = MIN(LB,LMBUFF) KWD = LB CALL FMOUT(MA,CMBUFF,KWD) LFIRST = 1 LAST = 1 DO J = 1, KWD IF (CMBUFF(KWD+1-J) /= ' ') LFIRST = KWD+1-J IF (CMBUFF(J) /= ' ') LAST = J ENDDO IF (LAST-LFIRST+1 > KWI) THEN ! Not enough room for this F format, or FMOUT converted ! it to E format to avoid showing no significant digits. ! See if a shortened form will fit in E format. NEXP = INT(LOG10((ABS(REAL(MA(1)))+1)*LOG10(REAL(MBASE))+1)+1) ND = KWI - NEXP - 5 IF (ND < 1) THEN GO TO 120 ELSE JFORM1 = 0 JFORM2 = ND CALL FMOUT(MA,CMBUFF,KWI) LFIRST = 1 LAST = 1 DO J = 1, KWI IF (CMBUFF(KWI+1-J) /= ' ') LFIRST = KWI+1-J IF (CMBUFF(J) /= ' ') LAST = J ENDDO ENDIF ENDIF JPT = 1 IF (LAST <= KWI) THEN DO J = LAST, LFIRST, -1 JPT = KWI - LAST + J STRING(JPT:JPT) = CMBUFF(J) ENDDO DO J = 1, JPT-1 STRING(J:J) = ' ' ENDDO ELSE DO J = LFIRST, LAST JPT = KWI - LAST + J STRING(JPT:JPT) = CMBUFF(J) ENDDO ENDIF ELSE IF (INDEX(FORM,'1PE') > 0 .OR. INDEX(FORM,'1pe') > 0) THEN K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1 K2 = INDEX(FORM,'.') K3 = LENGFM IF (K2 > K1) THEN WRITE (FORMB,"('(I',I5,')')") K2-K1 READ (FORM(K1:K2-1),FORMB) KWI ELSE KWI = 50 ENDIF IF (K3 > K2) THEN WRITE (FORMB,"('(I',I5,')')") K3-K2 READ (FORM(K2+1:K3),FORMB) KD ELSE KD = 0 ENDIF KWI = MAX(1,MIN(KWI,LENGST)) KD = MAX(0,MIN(KD,KWI-2)) JFORM1 = 1 JFORM2 = KD IF (KWI > LMBUFF) GO TO 120 CALL FMOUT(MA,CMBUFF,KWI) DO J = KWI, 1, -1 IF (J > LENGST) THEN IF (CMBUFF(J) /= ' ') GO TO 120 ELSE STRING(J:J) = CMBUFF(J) ENDIF ENDDO ELSE IF (INDEX(FORM,'E') > 0 .OR. INDEX(FORM,'e') > 0) THEN K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1 K2 = INDEX(FORM,'.') K3 = LENGFM IF (K2 > K1) THEN WRITE (FORMB,"('(I',I5,')')") K2-K1 READ (FORM(K1:K2-1),FORMB) KWI ELSE KWI = 50 ENDIF IF (K3 > K2) THEN WRITE (FORMB,"('(I',I5,')')") K3-K2 READ (FORM(K2+1:K3),FORMB) KD ELSE KD = 0 ENDIF KWI = MAX(1,MIN(KWI,LENGST)) KD = MAX(0,MIN(KD,KWI-2)) JFORM1 = 0 JFORM2 = KD IF (KWI > LMBUFF) GO TO 120 CALL FMOUT(MA,CMBUFF,KWI) DO J = KWI, 1, -1 IF (J > LENGST) THEN IF (CMBUFF(J) /= ' ') GO TO 120 ELSE STRING(J:J) = CMBUFF(J) ENDIF ENDDO ELSE GO TO 120 ENDIF 110 KFLAG = KSAVE JFORM1 = JF1SAV JFORM2 = JF2SAV NCALL = NCALL - 1 RETURN ! Error condition. 120 KFLAG = -8 DO J = 1, LENGST STRING(J:J) = '*' ENDDO GO TO 110 END SUBROUTINE FMFORM SUBROUTINE FMFPRT(FORM,MA) ! Print an FM number (MA) on unit KW using character ! string FORM format. ! FORM can be one of these types: Iw, Fw.d, Ew.d, 1PEw.d ! for positive integers w,d. ! If Iw format is used and MA is not exactly an integer, then the ! nearest integer to MA is printed. USE FMVALS IMPLICIT NONE CHARACTER(*) :: FORM REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) CHARACTER(20) :: FORM2,FORMB INTEGER J,JF1SAV,JF2SAV,JPT,K,K1,K2,K3,KD,KSAVE,KWD,KWI, & LAST,LB,LENGFM,LFIRST,ND,NEXP NCALL = NCALL + 1 NAMEST(NCALL) = 'FMFPRT' KSAVE = KFLAG JF1SAV = JFORM1 JF2SAV = JFORM2 LENGFM = LEN(FORM) KWI = 75 KWD = 40 IF (INDEX(FORM,'I') > 0 .OR. INDEX(FORM,'i') > 0) THEN K1 = MAX(INDEX(FORM,'I'),INDEX(FORM,'i')) + 1 K2 = LENGFM WRITE (FORMB,"('(I',I5,')')") K2-K1+1 IF (K2 >= K1) THEN READ (FORM(K1:K2),FORMB) KWI ELSE KWI = 50 ENDIF KWI = MAX(1,MIN(KWI,LMBUFF-11)) JFORM1 = 2 JFORM2 = 0 KWD = KWI + 21 CALL FMNINT(MA,M02) IF (M02(2) /= 0) THEN CALL FMOUT(M02,CMBUFF,KWD) ELSE DO J = 1, KWD CMBUFF(J) = ' ' ENDDO CMBUFF(2) = '0' ENDIF LFIRST = 1 LAST = 1 DO J = 1, KWD IF (CMBUFF(KWD+1-J) /= ' ') LFIRST = KWD+1-J IF (CMBUFF(J) /= ' ') LAST = J ENDDO JPT = 1 IF (LAST-LFIRST+1 > KWI) GO TO 120 IF (LAST <= KWI) THEN DO J = LAST, LFIRST, -1 JPT = KWI - LAST + J IF (JPT /= J) CMBUFF(JPT) = CMBUFF(J) ENDDO DO J = 1, JPT-1 CMBUFF(J) = ' ' ENDDO ELSE DO J = LFIRST, LAST JPT = KWI - LAST + J IF (JPT /= J) CMBUFF(JPT) = CMBUFF(J) ENDDO ENDIF ELSE IF (INDEX(FORM,'F') > 0 .OR. INDEX(FORM,'f') > 0) THEN K1 = MAX(INDEX(FORM,'F'),INDEX(FORM,'f')) + 1 K2 = INDEX(FORM(1:LENGFM),'.') K3 = LENGFM IF (K2 > K1) THEN WRITE (FORMB,"('(I',I5,')')") K2-K1 READ (FORM(K1:K2-1),FORMB) KWI ELSE KWI = 50 ENDIF IF (K3 > K2) THEN WRITE (FORMB,"('(I',I5,')')") K3-K2 READ (FORM(K2+1:K3),FORMB) KD ELSE KD = 0 ENDIF KWI = MAX(1,MIN(KWI,LMBUFF)) KD = MAX(0,MIN(KD,KWI-2)) JFORM1 = 2 JFORM2 = KD ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1 IF (ND < 2) ND = 2 NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6 LB = MAX(JFORM2+NEXP,ND+NEXP) LB = MIN(LB,LMBUFF) KWD = LB CALL FMOUT(MA,CMBUFF,KWD) LFIRST = 1 LAST = 1 DO J = 1, KWD IF (CMBUFF(KWD+1-J) /= ' ') LFIRST = KWD+1-J IF (CMBUFF(J) /= ' ') LAST = J ENDDO IF (LAST-LFIRST+1 > KWI) THEN ! Not enough room for this F format, or FMOUT converted ! it to E format to avoid showing no significant digits. ! See if a shortened form will fit in E format. NEXP = INT(LOG10((ABS(REAL(MA(1)))+1)*LOG10(REAL(MBASE))+1)+1) ND = KWI - NEXP - 5 IF (ND < 1) THEN GO TO 120 ELSE JFORM1 = 0 JFORM2 = ND CALL FMOUT(MA,CMBUFF,KWI) LFIRST = 1 LAST = 1 DO J = 1, KWI IF (CMBUFF(KWI+1-J) /= ' ') LFIRST = KWI+1-J IF (CMBUFF(J) /= ' ') LAST = J ENDDO ENDIF ENDIF JPT = 1 IF (LAST <= KWI) THEN DO J = LAST, LFIRST, -1 JPT = KWI - LAST + J IF (JPT /= J) CMBUFF(JPT) = CMBUFF(J) ENDDO DO J = 1, JPT-1 CMBUFF(J) = ' ' ENDDO ELSE DO J = LFIRST, LAST JPT = KWI - LAST + J IF (JPT /= J) CMBUFF(JPT) = CMBUFF(J) ENDDO ENDIF ELSE IF (INDEX(FORM,'1PE') > 0 .OR. INDEX(FORM,'1pe') > 0) THEN K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1 K2 = INDEX(FORM(1:LENGFM),'.') K3 = LENGFM IF (K2 > K1) THEN WRITE (FORMB,"('(I',I5,')')") K2-K1 READ (FORM(K1:K2-1),FORMB) KWI ELSE KWI = 50 ENDIF IF (K3 > K2) THEN WRITE (FORMB,"('(I',I5,')')") K3-K2 READ (FORM(K2+1:K3),FORMB) KD ELSE KD = 0 ENDIF KWI = MAX(1,MIN(KWI,LMBUFF)) KD = MAX(0,MIN(KD,KWI-2)) JFORM1 = 1 JFORM2 = KD CALL FMOUT(MA,CMBUFF,KWI) ELSE IF (INDEX(FORM,'E') > 0 .OR. INDEX(FORM,'e') > 0) THEN K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1 K2 = INDEX(FORM(1:LENGFM),'.') K3 = LENGFM IF (K2 > K1) THEN WRITE (FORMB,"('(I',I5,')')") K2-K1 READ (FORM(K1:K2-1),FORMB) KWI ELSE KWI = 50 ENDIF IF (K3 > K2) THEN WRITE (FORMB,"('(I',I5,')')") K3-K2 READ (FORM(K2+1:K3),FORMB) KD ELSE KD = 0 ENDIF KWI = MAX(1,MIN(KWI,LMBUFF)) KD = MAX(0,MIN(KD,KWI-2)) JFORM1 = 0 JFORM2 = KD CALL FMOUT(MA,CMBUFF,KWI) ELSE GO TO 120 ENDIF 110 LAST = KWI + 1 WRITE (FORM2,"(' (6X,',I3,'A1) ')") KSWIDE-7 IF (KFLAG /= -8) KFLAG = KSAVE JFORM1 = JF1SAV JFORM2 = JF2SAV DO J = KWI, 1, -1 IF (CMBUFF(J) /= ' ' .OR. J == 1) THEN WRITE (KW,FORM2) (CMBUFF(K),K=1,J) NCALL = NCALL - 1 RETURN ENDIF ENDDO NCALL = NCALL - 1 RETURN ! Error condition. 120 KFLAG = -8 DO J = 1, KWI CMBUFF(J) = '*' ENDDO GO TO 110 END SUBROUTINE FMFPRT SUBROUTINE FMGCDI(N1,N2) ! Find the Greatest Common Divisor of N1 and N2, and return both ! having been divided by their GCD. Both must be positive. USE FMVALS IMPLICIT NONE INTEGER K1,K2,K3,N1,N2 K1 = MAX(N1,N2) K2 = MIN(N1,N2) 110 K3 = MOD(K1,K2) IF (K3 == 0) THEN N1 = N1/K2 N2 = N2/K2 RETURN ELSE K1 = K2 K2 = K3 GO TO 110 ENDIF END SUBROUTINE FMGCDI SUBROUTINE FMHTBL ! Initialize two hash tables that are used for character ! look-up during input conversion. USE FMVALS IMPLICIT NONE INTEGER J,KPT CHARACTER :: LCHARS(21) = (/ & '+','-','0','1','2','3','4','5','6','7','8','9', & '.','E','D','Q','M','e','d','q','m' /) INTEGER :: LTYPES(21) = (/ 1,1,2,2,2,2,2,2,2,2,2,2,3,4,4,4,4,4,4,4,4 /) INTEGER :: LVALS(21) = (/ 1,-1,0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0,0,0,0 /) DO J = LHASH1, LHASH2 KHASHT(J) = 5 KHASHV(J) = 0 ENDDO DO J = 1, 21 KPT = ICHAR(LCHARS(J)) IF (KPT < LHASH1 .OR. KPT > LHASH2) THEN WRITE (KW, & "(/' Error in input conversion.'/" // & "' ICHAR function was out of range for the current'," // & "' dimensions.'/' ICHAR(''',A,''') gave the value '," // & "I12,', which is outside the currently'/' dimensioned'," // & "' bounds of (',I5,':',I5,') for variables KHASHT '," // & "'and KHASHV.'/' Re-define the two parameters '," // & "'LHASH1 and LHASH2 so the dimensions will'/' contain'," // & "' all possible output values from ICHAR.'//)" & ) LCHARS(J),KPT,LHASH1,LHASH2 ELSE KHASHT(KPT) = LTYPES(J) KHASHV(KPT) = LVALS(J) ENDIF ENDDO LHASH = 1 END SUBROUTINE FMHTBL SUBROUTINE FMI2M(IVAL,MA) ! MA = IVAL ! Convert an integer to FM format. ! The conversion is exact if IVAL is less than MBASE**NDIG, ! otherwise the result is an approximation. ! This routine performs the trace printing for the conversion. ! FMIM is used to do the arithmetic. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER IVAL NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMI2M ' CALL FMNTRI(2,IVAL,1) CALL FMIM(IVAL,MA) CALL FMNTR(1,MA,MA,1,1) ELSE CALL FMIM(IVAL,MA) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMI2M SUBROUTINE FMIM(IVAL,MA) ! MA = IVAL. Internal integer conversion routine. ! The conversion is exact if IVAL is less than MBASE**NDIG. ! Otherwise FMDM is used to get an approximation. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER IVAL DOUBLE PRECISION X REAL (KIND(1.0D0)) :: MK,ML,MVAL INTEGER J,JM2,KB,KB1,N1,NMVAL,NV2 IF (MBLOGS /= MBASE) CALL FMCONS KFLAG = 0 N1 = NDIG + 1 MVAL = ABS(IVAL) NMVAL = INT(MVAL) NV2 = NMVAL - 1 IF (ABS(IVAL) > MXBASE .OR. NMVAL /= ABS(IVAL) .OR. & NV2 /= ABS(IVAL)-1) THEN CALL FMIMS(IVAL,MA) GO TO 120 ENDIF ! Check for small IVAL. IF (MVAL < MBASE) THEN DO J = 3, N1 MA(J) = 0 ENDDO IF (IVAL >= 0) THEN MA(2) = IVAL MA(-1) = 1 ELSE MA(2) = -IVAL MA(-1) = -1 ENDIF IF (IVAL == 0) THEN MA(1) = 0 ELSE MA(1) = 1 ENDIF GO TO 120 ENDIF ! Compute and store the digits, right to left. MA(1) = 0 J = NDIG + 1 110 MK = AINT (MVAL/MBASE) ML = MVAL - MK*MBASE MA(1) = MA(1) + 1 MA(J) = ML IF (MK > 0) THEN MVAL = MK J = J - 1 IF (J >= 2) GO TO 110 ! Here IVAL cannot be expressed exactly. X = IVAL CALL FMDM(X,MA) RETURN ENDIF ! Normalize MA. KB = N1 - J + 2 JM2 = J - 2 DO J = 2, KB MA(J) = MA(J+JM2) ENDDO KB1 = KB + 1 IF (KB1 <= N1) THEN DO J = KB1, N1 MA(J) = 0 ENDDO ENDIF MA(-1) = 1 IF (IVAL < 0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1 120 MA(0) = NINT(NDIG*ALOGM2) RETURN END SUBROUTINE FMIM SUBROUTINE FMIMS(IVAL,MA) ! MA = IVAL. Internal integer conversion routine. ! This routine is called when M-variable precision is less than ! Integer precision. This often happens when single precision ! is chosen for M-variables. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER IVAL DOUBLE PRECISION X REAL (KIND(1.0D0)) :: ML INTEGER J,JM2,KB,KB1,KBASE,KMK,KVAL,N1 IF (MBLOGS /= MBASE) CALL FMCONS KFLAG = 0 N1 = NDIG + 1 ! Check for small IVAL. KVAL = ABS(IVAL) KBASE = INT(MBASE) IF (KVAL < KBASE) THEN DO J = 3, N1 MA(J) = 0 ENDDO IF (IVAL >= 0) THEN MA(2) = IVAL MA(-1) = 1 ELSE MA(2) = -IVAL MA(-1) = -1 ENDIF IF (IVAL == 0) THEN MA(1) = 0 ELSE MA(1) = 1 ENDIF GO TO 120 ENDIF ! Compute and store the digits, right to left. MA(1) = 0 J = NDIG + 1 110 KMK = (KVAL/KBASE) ML = KVAL - KMK*KBASE MA(1) = MA(1) + 1 MA(J) = ML IF (KMK > 0) THEN KVAL = KMK J = J - 1 IF (J >= 2) GO TO 110 ! Here IVAL cannot be expressed exactly. X = IVAL CALL FMDM(X,MA) RETURN ENDIF ! Normalize MA. KB = N1 - J + 2 JM2 = J - 2 DO J = 2, KB MA(J) = MA(J+JM2) ENDDO KB1 = KB + 1 IF (KB1 <= N1) THEN DO J = KB1, N1 MA(J) = 0 ENDDO ENDIF MA(-1) = 1 IF (IVAL < 0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1 120 MA(0) = NINT(NDIG*ALOGM2) RETURN END SUBROUTINE FMIMS SUBROUTINE FMINP(LINE,MA,LA,LB) ! Convert an array of characters to floating point multiple precision ! format. ! LINE is an A1 character array of length LB to be converted ! to FM format and returned in MA. ! LA is a pointer telling the routine where in the array to begin ! the conversion. This allows more than one number to be stored ! in an array and converted in place. ! LB is a pointer to the last character of the field for that number. ! The input number may be in integer or any real format. ! KESWCH = 1 causes input to FMINP with no digits before the exponent ! letter to be treated as if there were a leading '1'. ! This is sometimes better for interactive input: ! 'E7' converts to 10.0**7. ! = 0 causes a leading zero to be assumed. This gives ! compatibility with Fortran: ! 'E7' converts to 0.0. ! In exponential format the 'E' may also be 'D', 'Q', or 'M'. ! So that FMINP will convert any output from FMOUT, LINE is tested ! to see if the input is one of the special symbols +OVERFLOW, ! -OVERFLOW, +UNDERFLOW, -UNDERFLOW, or UNKNOWN. ! For user input the abbreviations OVFL, UNFL, UNKN may be used. USE FMVALS IMPLICIT NONE INTEGER LA,LB CHARACTER LINE(LB) REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) REAL (KIND(1.0D0)) :: M2,MNDSV1,MXSAV1,MXSAV2 INTEGER J,JSTATE,K,K10PWR,KASAVE,KDFLAG,KEXP,KF1,KF2,KMN,KOF,KPOWER, & KPT,KRSAVE,KSIGN,KSIGNX,KSTART,KSTOP,KTENEX,KTENF1,KTENF2, & KTYPE,KUF,KUK,KVAL,KWRNSV,LARGE,N2,NDSAV1,NDSAVE ! Simulate a finite-state automaton to scan the input line ! and build the number. States of the machine: ! 1. Initial entry to the subroutine ! 2. Sign of the number ! 3. Scanning digits before a decimal point ! 4. Decimal point ! 5. Scanning digits after a decimal point ! 6. E, D, Q, or M -- precision indicator before the exponent ! 7. Sign of the exponent ! 8. Scanning exponent ! 9. Syntax error ! Character types recognized by the machine: ! 1. Sign (+,-) ! 2. Numeral (0,1,...,9) ! 3. Decimal point (.) ! 4. Precision indicator (E,D,Q,M) ! 5. Illegal character for number ! All blanks are ignored. The analysis of the number proceeds as ! follows: If the simulated machine is in state JSTATE and a character ! of type JTYPE is encountered the new state of the machine is given by ! JTRANS(JSTATE,JTYPE). ! In this initialization note the array is loaded by columns. ! State 1 2 3 4 5 6 7 8 INTEGER :: JTRANS(8,4) = RESHAPE( (/ & 2, 9, 9, 9, 9, 7, 9, 9, & 3, 3, 3, 5, 5, 8, 8, 8, & 4, 4, 4, 9, 9, 9, 9, 9, & 6, 6, 6, 6, 6, 9, 9, 9 /) & , (/ 8,4 /) ) CHARACTER :: KOVFL(4) = (/ 'O','V','F','L' /) CHARACTER :: KUNFL(4) = (/ 'U','N','F','L' /) CHARACTER :: KUNKN(4) = (/ 'U','N','K','N' /) CHARACTER :: LOVFL(4) = (/ 'o','v','f','l' /) CHARACTER :: LUNFL(4) = (/ 'u','n','f','l' /) CHARACTER :: LUNKN(4) = (/ 'u','n','k','n' /) ! To avoid recursion, FMINP calls only internal arithmetic ! routines (FMADD2, FMMPY2, ...), so no trace printout is ! done during a call to FMINP. IF (MBLOGS /= MBASE) CALL FMCONS NCALL = NCALL + 1 NAMEST(NCALL) = 'FMINP ' ! Raise the call stack again, since the internal ! routines don't. NCALL = NCALL + 1 NAMEST(NCALL) = 'FMINP ' NDSAVE = NDIG KASAVE = KACCSW KACCSW = 0 KRSAVE = KROUND KROUND = 1 KFLAG = 0 MXSAV1 = MXEXP MXSAV2 = MXEXP2 IF (MXEXP < 100000) THEN MXEXP = 100000 MXEXP2 = 201000 ENDIF ! Initialize two hash tables that are used for character ! look-up during input conversion. IF (LHASH == 0) CALL FMHTBL ! Check for special symbols. KMN = 1 KOF = 1 KUF = 1 KUK = 1 DO J = LA, LB KPT = ICHAR(LINE(J)) IF (KPT >= LHASH1 .AND. KPT <= LHASH2) THEN KTYPE = KHASHT(KPT) IF (KTYPE == 2) GO TO 110 ENDIF IF (LINE(J) == '-') KMN = -1 IF (LINE(J) == KOVFL(KOF) .OR. LINE(J) == LOVFL(KOF)) THEN KOF = KOF + 1 IF (KOF == 5) THEN CALL FMIM(0,MA) MA(1) = MEXPOV MA(2) = 1 MA(-1) = KMN MA(0) = NINT(NDIG*ALOGM2) GO TO 150 ENDIF ENDIF IF (LINE(J) == KUNFL(KUF) .OR. LINE(J) == LUNFL(KOF)) THEN KUF = KUF + 1 IF (KUF == 5) THEN CALL FMIM(0,MA) MA(1) = MEXPUN MA(2) = 1 MA(-1) = KMN MA(0) = NINT(NDIG*ALOGM2) GO TO 150 ENDIF ENDIF IF (LINE(J) == KUNKN(KUK) .OR. LINE(J) == LUNKN(KOF)) THEN KUK = KUK + 1 IF (KUK == 5) THEN CALL FMIM(0,MA) MA(1) = MUNKNO MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) GO TO 150 ENDIF ENDIF ENDDO ! Increase the working precision. 110 K = NGRD52 NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) NDIG = NDG2MX NDSAV1 = NDIG M2 = 2 MNDSV1 = NDSAV1 KSTART = LA KSTOP = LB JSTATE = 1 KSIGN = 1 CALL FMIM(0,MLV2) CALL FMIM(0,MLV3) CALL FMIM(0,MLV4) CALL FMIM(0,MLV5) ! If MBASE is a power of ten then call FMINP2 for ! faster input conversion. KPOWER = INT(LOG10(DBLE(MBASE)) + 0.5D0) IF (MBASE == 10**KPOWER) THEN CALL FMINP2(MA,LINE,KSTART,KSTOP,JTRANS,KPOWER) GO TO 140 ENDIF N2 = 0 KSIGNX = 1 KF1 = 0 KF2 = 0 KEXP = 0 KTENF1 = 1 KTENF2 = 1 KTENEX = 1 K10PWR = 0 ! LARGE is a threshold used in order to do as much of the ! conversion as possible in one-word integer arithmetic. LARGE = INT((INTMAX - 10)/10) ! KDFLAG will be 1 if any digits are found before 'E'. KDFLAG = 0 ! Scan the number. DO J = KSTART, KSTOP IF (LINE(J) == ' ') CYCLE KPT = ICHAR(LINE(J)) IF (KPT < LHASH1 .OR. KPT > LHASH2) THEN WRITE (KW, & "(/' Error in input conversion.'/" // & "' ICHAR function was out of range for the current'," // & "' dimensions.'/' ICHAR(''',A,''') gave the value '," // & "I12,', which is outside the currently'/' dimensioned'," // & "' bounds of (',I5,':',I5,') for variables KHASHT '," // & "'and KHASHV.'/' Re-define the two parameters '," // & "'LHASH1 and LHASH2 so the dimensions will'/' contain'," // & "' all possible output values from ICHAR.'//)" & ) LINE(J),KPT,LHASH1,LHASH2 KTYPE = 5 KVAL = 0 ELSE KTYPE = KHASHT(KPT) KVAL = KHASHV(KPT) ENDIF IF (KTYPE >= 5) GO TO 160 JSTATE = JTRANS(JSTATE,KTYPE) SELECT CASE (JSTATE) ! State 2. Sign of the number. CASE (2) KSIGN = KVAL ! State 3. Digits before a decimal point. CASE (3) KDFLAG = 1 KF1 = 10*KF1 + KVAL KTENF1 = 10*KTENF1 IF (KTENF1 > LARGE) THEN IF (KTENF1 /= K10PWR .AND. MLV3(2) /= 0) THEN CALL FMIM(KTENF1,MA) K10PWR = KTENF1 ENDIF IF (MLV3(2) == 0) THEN CALL FMIM(KF1,MLV3) ELSE NDIG = INT(MAX(M2,MIN(MLV3(1)+MA(1),MNDSV1))) CALL FMMPY2_R1(MLV3,MA) NDIG = NDSAV1 CALL FMIM(KF1,MLV2) NDIG = INT(MAX(M2,MIN(MAX(MLV3(1),MLV2(1))+1,MNDSV1))) IF (KF1 /= 0) CALL FMADD2_R1(MLV3,MLV2) NDIG = NDSAV1 ENDIF KF1 = 0 KTENF1 = 1 ENDIF ! State 4. Decimal point CASE (4) CYCLE ! State 5. Digits after a decimal point. CASE (5) KDFLAG = 1 N2 = N2 + 1 KF2 = 10*KF2 + KVAL KTENF2 = 10*KTENF2 IF (KTENF2 > LARGE) THEN IF (KTENF2 /= K10PWR .AND. MLV4(2) /= 0) THEN CALL FMIM(KTENF2,MA) K10PWR = KTENF2 ENDIF IF (MLV4(2) == 0) THEN CALL FMIM(KF2,MLV4) ELSE NDIG = INT(MAX(M2,MIN(MLV4(1)+MA(1),MNDSV1))) CALL FMMPY2_R1(MLV4,MA) NDIG = NDSAV1 CALL FMIM(KF2,MLV2) NDIG = INT(MAX(M2,MIN(MAX(MLV4(1),MLV2(1))+1,MNDSV1))) IF (KF2 /= 0) CALL FMADD2_R1(MLV4,MLV2) NDIG = NDSAV1 ENDIF KF2 = 0 KTENF2 = 1 ENDIF ! State 6. Precision indicator. CASE (6) IF (KDFLAG == 0 .AND. KESWCH == 1) CALL FMIM(1,MLV3) ! State 7. Sign of the exponent. CASE (7) KSIGNX = KVAL ! State 8. Digits of the exponent. CASE (8) KEXP = 10*KEXP + KVAL KTENEX = 10*KTENEX IF (KTENEX > LARGE) THEN IF (KTENEX /= K10PWR .AND. MLV5(2) /= 0) THEN CALL FMIM(KTENEX,MA) K10PWR = KTENEX ENDIF IF (MLV5(2) == 0) THEN CALL FMIM(KEXP,MLV5) ELSE NDIG = INT(MAX(M2,MIN(MLV5(1)+MA(1),MNDSV1))) CALL FMMPY2_R1(MLV5,MA) NDIG = NDSAV1 CALL FMIM(KEXP,MLV2) NDIG = INT(MAX(M2,MIN(MAX(MLV5(1),MLV2(1))+1,MNDSV1))) IF (KEXP /= 0) CALL FMADD2_R1(MLV5,MLV2) NDIG = NDSAV1 ENDIF KEXP = 0 KTENEX = 1 ENDIF CASE DEFAULT GO TO 160 END SELECT ENDDO ! Form the number and return. ! MA = KSIGN*(MLV3 + MLV4/10.0**N2)*10.0**MLV5 IF (KTENF1 > 1) THEN IF (KTENF1 /= K10PWR .AND. MLV3(2) /= 0) THEN CALL FMIM(KTENF1,MA) K10PWR = KTENF1 ENDIF IF (MLV3(2) == 0) THEN CALL FMIM(KF1,MLV3) ELSE NDIG = INT(MAX(M2,MIN(MLV3(1)+MA(1),MNDSV1))) CALL FMMPY2_R1(MLV3,MA) NDIG = NDSAV1 CALL FMIM(KF1,MLV2) NDIG = INT(MAX(M2,MIN(MAX(MLV3(1),MLV2(1))+1,MNDSV1))) IF (KF1 /= 0) CALL FMADD2_R1(MLV3,MLV2) NDIG = NDSAV1 ENDIF ENDIF IF (KTENF2 > 1) THEN IF (KTENF2 /= K10PWR .AND. MLV4(2) /= 0) THEN CALL FMIM(KTENF2,MA) K10PWR = KTENF2 ENDIF IF (MLV4(2) == 0) THEN CALL FMIM(KF2,MLV4) ELSE NDIG = INT(MAX(M2,MIN(MLV4(1)+MA(1),MNDSV1))) CALL FMMPY2_R1(MLV4,MA) NDIG = NDSAV1 CALL FMIM(KF2,MLV2) NDIG = INT(MAX(M2,MIN(MAX(MLV4(1),MLV2(1))+1,MNDSV1))) IF (KF2 /= 0) CALL FMADD2_R1(MLV4,MLV2) NDIG = NDSAV1 ENDIF ENDIF IF (KTENEX > 1) THEN IF (KTENEX /= K10PWR .AND. MLV5(2) /= 0) THEN CALL FMIM(KTENEX,MA) K10PWR = KTENEX ENDIF IF (MLV5(2) == 0) THEN CALL FMIM(KEXP,MLV5) ELSE NDIG = INT(MAX(M2,MIN(MLV5(1)+MA(1),MNDSV1))) CALL FMMPY2_R1(MLV5,MA) NDIG = NDSAV1 CALL FMIM(KEXP,MLV2) NDIG = INT(MAX(M2,MIN(MAX(MLV5(1),MLV2(1))+1,MNDSV1))) IF (KEXP /= 0) CALL FMADD2_R1(MLV5,MLV2) NDIG = NDSAV1 ENDIF ENDIF IF (KSIGNX == -1 .AND. MLV5(1) /= MUNKNO .AND. MLV5(2) /= 0) & MLV5(-1) = -MLV5(-1) IF (MLV4(2) /= 0) THEN CALL FMIM(10,MLV2) K = N2 IF (MOD(K,2) == 0) THEN CALL FMIM(1,MA) ELSE CALL FMEQ(MLV2,MA) ENDIF 120 K = K/2 NDIG = INT(MAX(M2,MIN(2*MLV2(1),MNDSV1))) CALL FMSQR2_R1(MLV2) IF (MOD(K,2) == 1) THEN NDIG = INT(MAX(M2,MIN(MLV2(1)+MA(1),MNDSV1))) CALL FMMPY2_R2(MLV2,MA) ENDIF IF (K > 1) GO TO 120 NDIG = NDSAV1 CALL FMDIV2_R1(MLV4,MA) ENDIF IF (MLV5(2) /= 0) THEN CALL FMIM(10,MLV2) KWRNSV = KWARN KWARN = 0 CALL FMMI(MLV5,KEXP) KWARN = KWRNSV IF (KFLAG /= 0) GO TO 160 K = ABS(KEXP) IF (MOD(K,2) == 0) THEN CALL FMIM(1,MLV5) ELSE CALL FMEQ(MLV2,MLV5) ENDIF 130 K = K/2 NDIG = INT(MAX(M2,MIN(2*MLV2(1),MNDSV1))) CALL FMSQR2_R1(MLV2) IF (MOD(K,2) == 1) THEN NDIG = INT(MAX(M2,MIN(MLV2(1)+MLV5(1),MNDSV1))) CALL FMMPY2_R2(MLV2,MLV5) ENDIF IF (K > 1) GO TO 130 NDIG = NDSAV1 IF (KEXP < 0) THEN CALL FMIM(1,MLV2) CALL FMDIV2_R2(MLV2,MLV5) ENDIF ENDIF CALL FMADD2(MLV3,MLV4,MA) IF (MLV5(2) /= 0) CALL FMMPY2_R1(MA,MLV5) IF (KSIGN == -1 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -MA(-1) 140 CALL FMEQ2_R1(MA,NDIG,NDSAVE) IF (MA(1) == MUNKNO) GO TO 160 150 NDIG = NDSAVE KACCSW = KASAVE KROUND = KRSAVE MXEXP = MXSAV1 MXEXP2 = MXSAV2 IF (KFLAG == 1) KFLAG = 0 MA(0) = NINT(NDIG*ALOGM2) IF (MA(2) == 0) MA(-1) = 1 NCALL = NCALL - 2 RETURN ! Error in converting the number. 160 CALL FMIM(0,MA) MA(1) = MUNKNO MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) KFLAG = -7 NCALL = NCALL - 1 CALL FMWARN NCALL = NCALL + 1 GO TO 150 END SUBROUTINE FMINP SUBROUTINE FMINP2(MA,LINE,KSTART,KSTOP,JTRANS,KPOWER) ! Internal routine for input conversion for a power of ten MBASE. USE FMVALS IMPLICIT NONE INTEGER KSTART,KSTOP,KPOWER,JTRANS(8,4) CHARACTER LINE(KSTOP) REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER J,JSTATE,KDFLAG,KEXP,KF1,KF1DIG,KF2,KF2DIG,KF2PT,KNZDIG, & KPT,KSHIFT,KSIGN,KSIGNX,KTYPE,KVAL,LARGE JSTATE = 1 KDFLAG = 0 KSIGN = 1 KSIGNX = 1 KF1 = 0 KNZDIG = 0 KF1DIG = 0 KF2 = 0 KF2DIG = 0 KF2PT = 2 KEXP = 0 LARGE = INT(INTMAX/10) ! Scan the number. DO J = KSTART, KSTOP IF (LINE(J) == ' ') CYCLE KPT = ICHAR(LINE(J)) IF (KPT < LHASH1 .OR. KPT > LHASH2) THEN WRITE (KW, & "(/' Error in input conversion.'/" // & "' ICHAR function was out of range for the current'," // & "' dimensions.'/' ICHAR(''',A,''') gave the value '," // & "I12,', which is outside the currently'/' dimensioned'," // & "' bounds of (',I5,':',I5,') for variables KHASHT '," // & "'and KHASHV.'/' Re-define the two parameters '," // & "'LHASH1 and LHASH2 so the dimensions will'/' contain'," // & "' all possible output values from ICHAR.'//)" & ) LINE(J),KPT,LHASH1,LHASH2 KTYPE = 5 KVAL = 0 ELSE KTYPE = KHASHT(KPT) KVAL = KHASHV(KPT) ENDIF IF (KTYPE >= 5) GO TO 110 JSTATE = JTRANS(JSTATE,KTYPE) SELECT CASE (JSTATE) ! State 2. Sign of the number. CASE (2) KSIGN = KVAL ! State 3. Digits before a decimal point. CASE (3) KDFLAG = 1 KF1 = 10*KF1 + KVAL IF (KVAL > 0 .OR. KNZDIG /= 0) THEN KNZDIG = 1 KF1DIG = KF1DIG + 1 ENDIF IF (KF1DIG == KPOWER) THEN MLV3(1) = MLV3(1) + 1 IF (MLV3(1) < NDIG) MLV3(INT(MLV3(1))+1) = KF1 KF1 = 0 KF1DIG = 0 ENDIF ! State 4. Decimal point CASE (4) CYCLE ! State 5. Digits after a decimal point. CASE (5) KDFLAG = 1 IF (KF2PT > NDIG+1) CYCLE KF2 = 10*KF2 + KVAL KF2DIG = KF2DIG + 1 IF (KF2DIG == KPOWER) THEN MLV4(KF2PT) = KF2 IF (KF2 == 0 .AND. KF2PT == 2) THEN MLV4(1) = MLV4(1) - 1 ELSE KF2PT = KF2PT + 1 ENDIF KF2 = 0 KF2DIG = 0 ENDIF ! State 6. Precision indicator. CASE (6) IF (KDFLAG == 0 .AND. KESWCH == 1) CALL FMIM(1,MLV3) ! State 7. Sign of the exponent. CASE (7) KSIGNX = KVAL ! State 8. Digits of the exponent. CASE (8) IF (KEXP >= LARGE) THEN IF (MLV3(2) == 0 .AND. MLV4(2) == 0) THEN CALL FMIM(0,MA) RETURN ENDIF CALL FMIM(0,MA) IF (KSIGNX == 1) THEN MA(1) = MEXPOV KFLAG = -4 ELSE MA(1) = MEXPUN KFLAG = -4 ENDIF MA(2) = 1 MA(-1) = KSIGN MA(0) = NINT(NDIG*ALOGM2) NCALL = NCALL - 1 CALL FMWARN NCALL = NCALL + 1 RETURN ENDIF KEXP = 10*KEXP + KVAL CASE DEFAULT GO TO 110 END SELECT ENDDO ! Form the number and return. ! MA = KSIGN*(MLV3 + MLV4)*10.0**(KSIGNX*KEXP) IF (KF1DIG /= 0) THEN MLV3(1) = MLV3(1) + 1 KSHIFT = 10**(KPOWER-KF1DIG) IF (MLV3(1) < NDIG) MLV3(INT(MLV3(1))+1) = KF1*KSHIFT IF (KSHIFT > 1) THEN CALL FMDIVN_R1(MLV3,KSHIFT) ENDIF ENDIF IF (KF2DIG /= 0) THEN KSHIFT = 10**(KPOWER-KF2DIG) MLV4(KF2PT) = KF2*KSHIFT ENDIF IF (MLV4(2) == 0) MLV4(1) = 0 IF (KEXP /= 0) THEN IF (KSIGNX == 1) THEN MLV5(1) = INT(KEXP/KPOWER) + 1 MLV5(2) = 10**(MOD(KEXP,KPOWER)) ELSE MLV5(1) = -INT((KEXP-1)/KPOWER) KSHIFT = 10**(MOD(KEXP,KPOWER)) IF (KSHIFT > 1) THEN MLV5(2) = MBASE/KSHIFT ELSE MLV5(2) = 1 ENDIF ENDIF ENDIF CALL FMADD2(MLV3,MLV4,MA) IF (KEXP > 0) CALL FMMPY2_R1(MA,MLV5) MA(-1) = KSIGN RETURN ! Error in converting the number. 110 CALL FMIM(0,MA) MA(1) = MUNKNO MA(2) = 1 MA(-1) = 1 MA(0) = NINT(NDIG*ALOGM2) RETURN END SUBROUTINE FMINP2 SUBROUTINE FMINT(MA,MB) ! MB = INT(MA) ! The integer part of MA is computed and returned in MB as a multiple ! precision floating point number. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACMAX INTEGER J,KA,KB,KRESLT,N1 IF (MBLOGS /= MBASE) CALL FMCONS MACCA = MA(0) KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMINT ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) IF (ABS(MA(1)) > MEXPAB) THEN CALL FMARGS('FMINT ',1,MA,MB,KRESLT) IF (KRESLT /= 0) THEN CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF N1 = NDIG + 1 ! If MA is less than one in magnitude, return zero. IF (MA(1) <= 0) THEN DO J = 1, N1 MB(J) = 0 ENDDO GO TO 110 ENDIF ! If the radix point is off the right end of MA then MA is ! already an integer. Return MA. IF (MA(1) >= NDIG) THEN DO J = 1, N1 MB(J) = MA(J) ENDDO GO TO 110 ENDIF ! Here MA has both integer and fraction parts. Replace ! the digits right of the radix point by zeros. KA = INT(MA(1)) + 2 KB = KA - 1 DO J = 1, KB MB(J) = MA(J) ENDDO DO J = KA, N1 MB(J) = 0 ENDDO 110 IF (KACCSW == 1) THEN MACMAX = NINT((NDIG-1)*ALOGM2 + & LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MACCA,MACMAX) ELSE MB(0) = MACCA ENDIF MB(-1) = MA(-1) IF (MB(2) == 0) MB(-1) = 1 IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMINT SUBROUTINE FMIPWR(MA,IVAL,MB) ! MB = MA ** IVAL ! Raise an FM number to an integer power. ! The binary multiplication method used requires an average of ! 1.5 * LOG2(IVAL) multiplications. MA may be negative. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER IVAL REAL (KIND(1.0D0)) :: MACCA,MACMAX INTEGER JSIGN,K,KWRNSV,NDSAVE REAL XVAL IF (MBLOGS /= MBASE) CALL FMCONS KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMIPWR' IF (NTRACE /= 0) THEN CALL FMNTR(2,MA,MA,1,1) CALL FMNTRI(2,IVAL,0) ENDIF ! Check for special cases. IF (MA(1) == MUNKNO .OR. (IVAL <= 0 .AND. MA(2) == 0)) THEN KFLAG = -4 IF (IVAL <= 0 .AND. MA(2) == 0) CALL FMWARN CALL FMST2M('UNKNOWN',MB) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF IF (IVAL == 0) THEN CALL FMIM(1,MB) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF IF (ABS(IVAL) == 1) THEN KWRNSV = KWARN KWARN = 0 IF (IVAL == 1) THEN CALL FMEQ(MA,MB) ELSE CALL FMIM(1,M01) CALL FMDIV(M01,MA,MB) ENDIF IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 KWARN = KWRNSV RETURN ENDIF IF (MA(2) == 0) THEN CALL FMEQ(MA,MB) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF IF (MA(1) == MEXPOV) THEN JSIGN = 1 IF (MA(-1) < 0) JSIGN = -1 CALL FMIM(0,MB) IF (IVAL > 0) THEN CALL FMST2M('OVERFLOW',MB) MB(-1) = JSIGN**MOD(IVAL,2) KFLAG = -5 ELSE CALL FMST2M('UNDERFLOW',MB) MB(-1) = JSIGN**MOD(IVAL,2) KFLAG = -6 ENDIF IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF IF (MA(1) == MEXPUN) THEN JSIGN = 1 IF (MA(-1) < 0) JSIGN = -1 CALL FMIM(0,MB) IF (IVAL > 0) THEN CALL FMST2M('UNDERFLOW',MB) MB(-1) = JSIGN**MOD(IVAL,2) KFLAG = -6 ELSE CALL FMST2M('OVERFLOW',MB) MB(-1) = JSIGN**MOD(IVAL,2) KFLAG = -5 ENDIF IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ! Increase the working precision. NDSAVE = NDIG IF (NCALL == 1) THEN XVAL = ABS(IVAL) K = INT((5.0*REAL(DLOGTN) + LOG(XVAL))/ALOGMB + 2.0) NDIG = MAX(NDIG+K,2) IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10)) ENDIF ELSE XVAL = ABS(IVAL) IF (XVAL > 10.0 .OR. REAL(MBASE) <= 999.0) THEN K = INT(LOG(XVAL)/ALOGMB + 1.0) NDIG = NDIG + K ENDIF ENDIF IF (NDIG > NDG2MX) THEN IF (NCALL == 1) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MB) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ELSE NDIG = NDG2MX ENDIF ENDIF ! Initialize. K = ABS(IVAL) KWRNSV = KWARN KWARN = 0 MACCA = MA(0) CALL FMEQ2(MA,M01,NDSAVE,NDIG) M01(0) = NINT(NDIG*ALOGM2) ! Handle small exponents by hand. IF (K == 2) THEN CALL FMSQR(M01,MB) GO TO 120 ENDIF IF (K == 3) THEN CALL FMSQR(M01,MB) CALL FMMPY_R1(MB,M01) GO TO 120 ENDIF IF (K == 4) THEN CALL FMSQR(M01,MB) CALL FMSQR_R1(MB) GO TO 120 ENDIF IF (K == 5) THEN CALL FMSQR(M01,MB) CALL FMSQR_R1(MB) CALL FMMPY_R1(MB,M01) GO TO 120 ENDIF IF (MOD(K,2) == 0) THEN CALL FMI2M(1,MB) ELSE CALL FMEQ(M01,MB) ENDIF ! This is the multiplication loop. 110 K = K/2 CALL FMSQR_R1(M01) IF (MOD(K,2) == 1) CALL FMMPY_R2(M01,MB) IF (K > 1) GO TO 110 ! Invert if the exponent is negative. 120 IF (IVAL < 0) THEN CALL FMI2M(1,M01) CALL FMDIV_R2(M01,MB) ENDIF KWARN = KWRNSV ! Round the result and return. CALL FMEQ2_R1(MB,NDIG,NDSAVE) NDIG = NDSAVE IF (KACCSW == 1) THEN MACMAX = NINT((NDSAVE-1)*ALOGM2 + & LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MACCA,MACMAX) ELSE MB(0) = MACCA ENDIF IF (KFLAG < 0) CALL FMWARN IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMIPWR SUBROUTINE FMLG10(MA,MB) ! MB = LOG10(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE INTEGER J,K,KASAVE,KOVUN,KRESLT,NDSAVE IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0 .OR. MA(-1) < 0) THEN CALL FMENTR('FMLG10',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMLG10' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF MACCA = MA(0) CALL FMEQ2(MA,MB,NDSAVE,NDIG) MB(0) = NINT(NDIG*ALOGM2) CALL FMLN(MB,M13) CALL FMEQ(M13,MB) IF (MBASE /= MBSLI .OR. NDIG > NDIGLI) THEN CALL FMLNI(10,M03) ELSE CALL FMADD(MLN1,MLN3,M03) ENDIF CALL FMDIV_R1(MB,M03) ! Round the result and return. MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MACCA,MACMAX) DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMLG10 SUBROUTINE FMLN(MA,MB) ! MB = LOG(MA) (Natural logarithm) USE FMVALS IMPLICIT NONE DOUBLE PRECISION Y REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER NSTACK(19) REAL (KIND(1.0D0)) :: MA1,MACCA,MACMAX,MXSAVE INTEGER IEXTRA,IVAL,J,K,K2,K2EXP,KASAVE,KBOT,KM1,KOVUN,KRESLT, & KSCALE,KST,KWRNSV,LAST,N1,N3,NDSAV1,NDSAVE,NDSV REAL X IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0 .OR. MA(-1) < 0) THEN CALL FMENTR('FMLN ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMLN ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF ! If MA is close to 1, use the Taylor series: ! LN(1+X) = X - X**2/2 + X**3/3 - ... ! This is faster for small X and avoids cancellation error. ! This method is faster for moderate sized NDIG, but is ! asymptotically slower by a factor of NDIG**(2/3) than ! using Newton and FMEXP. For MBASE=10,000 the Taylor ! series is faster for NDIG less than about 150 (and is ! used only when MA is between .9999 and 1.0001). IF (MA(1) == 0 .OR. MA(1) == 1) THEN X = REAL(MBASE) X = X**(INT(MA(1))-1)*(REAL(MA(2))+REAL(MA(3))/X) ELSE X = 2.0 ENDIF IF (X > 0.9999 .AND. X <= 1.0001) THEN MACCA = MA(0) CALL FMEQ2(MA,M03,NDSAVE,NDIG) M03(0) = NINT(NDIG*ALOGM2) CALL FMI2M(-1,M01) CALL FMADD_R1(M03,M01) ! The sum will be done as two concurrent series. NDSAV1 = NDIG CALL FMEQ(M03,M04) CALL FMDIVI(M03,2,M05) CALL FMSQR(M03,MB) CALL FMEQ(M03,M02) KBOT = 2 110 KBOT = KBOT + 1 CALL FMMPY_R1(M02,MB) CALL FMDIVI(M02,KBOT,M01) NDIG = NDSAV1 CALL FMADD_R1(M04,M01) NDIG = MAX(2,NDSAV1 - INT(M04(1)-M01(1))) KBOT = KBOT + 1 CALL FMDIVI(M02,KBOT,M01) NDIG = NDSAV1 CALL FMADD_R1(M05,M01) NDIG = MAX(2,NDSAV1 - INT(M04(1)-M01(1))) IF (KFLAG /= 1) GO TO 110 NDIG = NDSAV1 CALL FMMPY_R1(M05,M03) CALL FMSUB(M04,M05,MB) GO TO 140 ENDIF MA1 = MA(1) MACCA = MA(0) CALL FMEQ2(MA,M05,NDSAVE,NDIG) M05(0) = NINT(NDIG*ALOGM2) ! Compute IEXTRA, the number of extra digits required. CALL FMI2M(1,M04) CALL FMSUB_R1(M04,M05) IEXTRA = MAX(0-INT(M04(1)),0) IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN CALL FMEQ2_R1(M05,NDIG,NDIG+IEXTRA) ENDIF NDIG = NDIG + IEXTRA IF (NDIG > NDG2MX) THEN IF (NCALL == 1) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MB) DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN ELSE CALL FMEQ2_R1(M05,NDIG-IEXTRA,NDG2MX) NDIG = NDG2MX ENDIF ENDIF ! Check to see if the argument is a small integer. ! If so use FMLNI. KM1 = 0 KWRNSV = KWARN KWARN = 0 CALL FMM2I(M05,IVAL) KWARN = KWRNSV IF (KFLAG == 0 .AND. IVAL < MXBASE) THEN CALL FMLNI(IVAL,MB) GO TO 140 ENDIF ! See if the argument can be scaled to a small integer. N3 = NDIG + 3 N1 = NDIG + 1 DO J = 2, N1 IF (M05(N3-J) /= 0) THEN LAST = N3 - J - 1 GO TO 120 ENDIF ENDDO 120 KSCALE = INT(MA1) - LAST M05(1) = LAST KWRNSV = KWARN KWARN = 0 CALL FMM2I(M05,IVAL) KWARN = KWRNSV IF (KFLAG == 0 .AND. IVAL < MXBASE) THEN CALL FMLNI(IVAL,M04) IF (IVAL == 1) KM1 = 1 K2EXP = 0 GO TO 130 ENDIF ! For the non-integer case, scale the argument to lie ! between e/2 and e to speed up the calls to FMEXP. M05(1) = 1 KSCALE = INT(MA1) - 1 CALL FMM2DP(M05,Y) K2EXP = INT(LOG(2.0*REAL(Y)/2.71828)/0.693147) IF (Y < 1.359141) THEN K2EXP = -1 CALL FMMPYI_R1(M05,2) Y = 2.0D0*Y ELSE K2 = 2**K2EXP CALL FMDIVI_R1(M05,K2) Y = Y/K2 ENDIF ! Generate the initial approximation. Y = LOG(Y) CALL FMDPM(Y,M04) CALL FMDIG(NSTACK,KST) ! Newton iteration. DO J = 1, KST NDIG = NSTACK(J) CALL FMEXP(M04,MB) CALL FMSUB(M05,MB,M02) CALL FMDIV_R2(M02,MB) CALL FMADD_R1(M04,MB) ENDDO M04(0) = NINT(NDIG*ALOGM2) ! Compute LN(MBASE**KSCALE). 130 IF ((MBSLB /= MBASE .OR. NDIGLB < NDIG) .AND. KSCALE /= 0) THEN NDSV = NDIG NDIG = MIN(NDIG+2,NDG2MX) CALL FMLNI(INT(MBASE),MLBSAV) MBSLB = MBASE NDIGLB = NDIG IF (ABS(MLBSAV(1)) > 10) NDIGLB = 0 NDIG = NDSV ENDIF IF (KSCALE /= 0 .AND. KM1 == 0) THEN CALL FMMPYI(MLBSAV,KSCALE,MB) CALL FMADD_R2(M04,MB) ELSE IF (KSCALE /= 0 .AND. KM1 == 1) THEN CALL FMMPYI(MLBSAV,KSCALE,MB) ELSE IF (KSCALE == 0 .AND. KM1 == 0) THEN CALL FMEQ(M04,MB) ELSE IF (KSCALE == 0 .AND. KM1 == 1) THEN CALL FMI2M(0,MB) ENDIF IF (K2EXP /= 0) THEN IF (MBASE /= MBSLI .OR. NDIG > NDIGLI) THEN CALL FMLNI(2,M04) ENDIF CALL FMMPYI(MLN1,K2EXP,M04) CALL FMADD_R1(MB,M04) ENDIF ! Round the result and return. 140 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MACCA,MACMAX) DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMLN SUBROUTINE FMLNI(IVAL,MA) ! MA = LOG(IVAL) ! Compute the natural logarithm of an integer IVAL. ! If IVAL has only powers of 2, 3, 5, and 7 in its factorization then ! FMLNI is faster than FMLN. Otherwise, if IVAL >= MXBASE (i.e., IVAL ! does not fit in 1/2 word) then FMLN is usually faster. ! Use FMLN instead of FMLNI if 10*IVAL would cause integer overflow. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER IVAL CHARACTER(155) :: STRING INTEGER INT2,J2,J3,J5,J7,JTEMP2,JTEMP3,JTEMP5,JTEMP7,K,K2,K3, & K5,K7,KASAVE,KDELTA,LAST,ND,NDMB,NDSAVE,NDSV,NT REAL XVAL IF (MBLOGS /= MBASE) CALL FMCONS KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMLNI ' IF (NTRACE /= 0) CALL FMNTRI(2,IVAL,1) ! Check for special cases. IF (IVAL <= 0) THEN KFLAG = -4 CALL FMWARN CALL FMST2M('UNKNOWN',MA) IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1) NCALL = NCALL - 1 RETURN ENDIF IF (IVAL == 1) THEN CALL FMI2M(0,MA) IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1) NCALL = NCALL - 1 RETURN ENDIF ! Increase the working precision. NDSAVE = NDIG IF (NCALL == 1) THEN K = NGRD52 NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MA) IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 ! Find integers K2, K3, K5, and K7 such that ! NT = 2**K2 * 3**K3 * 5**K5 * 7**K7 ! is a good approximation of IVAL. ! KDELTA = ABS(IVAL - NT). INT2 = IVAL IF (IVAL > INTMAX/100) INT2 = IVAL/100 KDELTA = INT2 NT = 0 K2 = 0 K3 = 0 K5 = 0 K7 = 0 ! Start the search loop. XVAL = INT2 LAST = INT(LOG(DBLE(XVAL))/DLOGTW + 2.0D0) JTEMP7 = 1 DO J7 = 1, LAST IF (JTEMP7 > INT2 .AND. & ABS(JTEMP7-INT2) > KDELTA) GO TO 140 JTEMP5 = JTEMP7 DO J5 = 1, LAST IF (JTEMP5 > INT2 .AND. & ABS(JTEMP5-INT2) > KDELTA) GO TO 130 JTEMP3 = JTEMP5 DO J3 = 1, LAST IF (JTEMP3 > INT2 .AND. & ABS(JTEMP3-INT2) > KDELTA) GO TO 120 JTEMP2 = JTEMP3 DO J2 = 1, LAST IF (ABS(JTEMP2-INT2) <= KDELTA) THEN IF (ABS(JTEMP2-INT2) == KDELTA .AND. & JTEMP2 < INT2) GO TO 110 KDELTA = ABS(JTEMP2-INT2) NT = JTEMP2 K2 = J2 - 1 K3 = J3 - 1 K5 = J5 - 1 K7 = J7 - 1 IF (KDELTA == 0) GO TO 140 ENDIF IF (JTEMP2 > INT2) GO TO 110 JTEMP2 = 2*JTEMP2 ENDDO 110 JTEMP3 = 3*JTEMP3 ENDDO 120 JTEMP5 = 5*JTEMP5 ENDDO 130 JTEMP7 = 7*JTEMP7 ENDDO ! If IVAL was too close to the integer overflow limit, ! restore NT to an approximation of IVAL. 140 IF (INT2 /= IVAL) THEN IF (NT <= INT2) THEN NT = NT*100 K2 = K2 + 2 K5 = K5 + 2 ELSE IF (NT <= IVAL/98) THEN NT = NT*98 K2 = K2 + 1 K7 = K7 + 2 ELSE NT = NT*70 K2 = K2 + 1 K5 = K5 + 1 K7 = K7 + 1 ENDIF ENDIF ! End of the search. Now compute LN(NT) as a linear ! combination of LN(2), LN(3), LN(5), and LN(7). IF (MBASE /= MBSLI .OR. NDIG > NDIGLI) THEN NDMB = INT(150.0*2.302585/ALOGMB) IF (NDMB >= NDIG) THEN NDSV = NDIG NDIG = MIN(NDMB,NDG2MX) STRING = '0.693147180559945309417232121458176568075500'// & '13436025525412068000949339362196969471560586332699641'// & '8687542001481020570685733685520235758130557032670751635' CALL FMST2M(STRING,MLN1) STRING = '1.098612288668109691395245236922525704647490'// & '55782274945173469433363749429321860896687361575481373'// & '2088787970029065957865742368004225930519821052801870767' CALL FMST2M(STRING,MLN2) STRING = '1.609437912434100374600759333226187639525601'// & '35426851772191264789147417898770765776463013387809317'// & '9610799966303021715562899724005229324676199633616617464' CALL FMST2M(STRING,MLN3) STRING = '1.945910149055313305105352743443179729637084'// & '72958186118845939014993757986275206926778765849858787'// & '1526993061694205851140911723752257677786843148958095164' CALL FMST2M(STRING,MLN4) MBSLI = MBASE NDIGLI = NDIG IF (ABS(MLN1(1)) > 10 .OR. ABS(MLN2(1)) > 10 .OR. & ABS(MLN3(1)) > 10 .OR. ABS(MLN4(1)) > 10) NDIGLI = 0 ELSE NDSV = NDIG NDIG = MIN(NDIG+2,NDG2MX) MBSLI = MBASE NDIGLI = NDIG CALL FMLNI2(1,126,MLN1) CALL FMLNI2(1,225,MLN2) CALL FMLNI2(1,2401,MLN3) CALL FMLNI2(1,4375,MLN4) ! Get Ln(2). CALL FMMPYI_R1(MLN1,-72) CALL FMMPYI(MLN2,-27,MA) CALL FMADD_R1(MLN1,MA) CALL FMMPYI(MLN3,19,MA) CALL FMADD_R1(MLN1,MA) CALL FMMPYI(MLN4,-31,MA) CALL FMADD_R1(MLN1,MA) ! Get Ln(3). CALL FMMPYI_R1(MLN2,-3) CALL FMMPYI(MLN1,19,MA) CALL FMADD_R1(MLN2,MA) CALL FMSUB_R1(MLN2,MLN3) CALL FMADD_R1(MLN2,MLN4) CALL FMDIVI_R1(MLN2,12) ! Get Ln(5). CALL FMSUB_R1(MLN3,MLN1) CALL FMMPYI(MLN2,27,MA) CALL FMADD_R1(MLN3,MA) CALL FMMPYI(MLN4,-4,MA) CALL FMADD_R1(MLN3,MA) CALL FMDIVI_R1(MLN3,18) ! Get Ln(7). CALL FMSUB_R2(MLN1,MLN4) CALL FMMPYI(MLN2,7,MA) CALL FMADD_R1(MLN4,MA) CALL FMMPYI(MLN3,-4,MA) CALL FMADD_R1(MLN4,MA) ENDIF MLN1(0) = NINT(NDIG*ALOGM2) MLN2(0) = MLN1(0) MLN3(0) = MLN1(0) MLN4(0) = MLN1(0) IF (ABS(MLN1(1)) > 10 .OR. ABS(MLN2(1)) > 10 .OR. & ABS(MLN3(1)) > 10 .OR. ABS(MLN4(1)) > 10) NDIGLI = 0 NDIG = NDSV ENDIF ! If NT /= IVAL then the final step is to compute ! LN(IVAL/NT) and then use LN(IVAL) = LN(IVAL/NT) + LN(NT). IF (NT /= IVAL) THEN ND = NT - IVAL CALL FMLNI2(ND,NT,MA) ENDIF CALL FMMPYI(MLN1,K2,M02) CALL FMMPYI(MLN2,K3,M01) CALL FMADD_R1(M02,M01) CALL FMMPYI(MLN3,K5,M01) CALL FMADD_R1(M02,M01) CALL FMMPYI(MLN4,K7,M01) IF (NT /= IVAL) CALL FMADD_R1(M02,MA) CALL FMADD(M02,M01,MA) ! Round and move the result to MA. KACCSW = KASAVE CALL FMEQ2_R1(MA,NDIG,NDSAVE) NDIG = NDSAVE IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMLNI SUBROUTINE FMLNI2(INT1,INT2,MA) ! MA = LN(1 - INT1/INT2) ! Taylor series for computing the logarithm of a rational number ! near 1. USE FMVALS IMPLICIT NONE INTEGER INT1,INT2 REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER J,NDSAVE CALL FMI2M(INT1,M02) CALL FMDIVI_R1(M02,INT2) CALL FMEQ(M02,MA) NDSAVE = NDIG J = 1 110 J = J + 1 IF (INT1 /= 1) CALL FMMPYI_R1(M02,INT1) CALL FMDIVI_R1(M02,INT2) CALL FMDIVI(M02,J,M01) NDIG = NDSAVE CALL FMADD_R1(MA,M01) NDIG = NDSAVE - INT(MA(1)-M01(1)) IF (NDIG < 2) NDIG = 2 IF (KFLAG /= 1) GO TO 110 NDIG = NDSAVE MA(0) = NINT(NDIG*ALOGM2) IF (MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -MA(-1) RETURN END SUBROUTINE FMLNI2 SUBROUTINE FMM2DP(MA,X) ! X = MA ! Convert an FM number to double precision. ! If KFLAG = -4 is returned for a value of MA that is in the range ! of the machine's double precision number system, change the ! definition of DPMAX in routine FMSET to reflect the current machine's ! range. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) DOUBLE PRECISION X INTEGER KRESLT NCALL = NCALL + 1 NAMEST(NCALL) = 'FMM2DP' KRESLT = 0 IF (ABS(MA(1)) > MEXPAB) THEN CALL FMARGS('FMM2DP',1,MA,MA,KRESLT) ENDIF IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) IF (KRESLT /= 0) THEN ! Here no valid result can be returned. Set X to some ! value that the user is likely to recognize as wrong. X = DBLE(RUNKNO) KFLAG = -4 IF (MA(1) /= MUNKNO) CALL FMWARN IF (NTRACE /= 0) CALL FMNTRR(1,X,1) NCALL = NCALL - 1 RETURN ENDIF CALL FMMD(MA,X) IF (NTRACE /= 0) CALL FMNTRR(1,X,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMM2DP SUBROUTINE FMM2I(MA,IVAL) ! IVAL = MA ! Convert an FM number to integer. ! KFLAG = 0 is returned if the conversion is exact. ! = -4 is returned if MA is larger than INTMAX in magnitude. ! IVAL = IUNKNO is returned as an indication that IVAL ! could not be computed without integer overflow. ! = 2 is returned if MA is smaller than INTMAX in magnitude ! but MA is not an integer. The next integer toward zero ! is returned in IVAL. ! It is sometimes convenient to call FMM2I to see if an FM number ! can be represented as a one-word integer, by checking KFLAG upon ! return. To avoid an unwanted error message being printed in the ! KFLAG=-4 case, set KWARN=0 before the call to FMM2I and reset it ! after the call. ! This routine performs the trace printing for the conversion. ! FMMI is used to do the arithmetic. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER IVAL NCALL = NCALL + 1 NAMEST(NCALL) = 'FMM2I ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) CALL FMMI(MA,IVAL) IF (NTRACE /= 0) CALL FMNTRI(1,IVAL,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMM2I SUBROUTINE FMM2SP(MA,X) ! X = MA ! Convert an FM number to single precision. ! MA is converted and the result is returned in X. ! If KFLAG = -4 is returned for a value of MA that is in the range ! of the machine's single precision number system, change the ! definition of SPMAX in routine FMSET to reflect the current machine's ! range. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) REAL X DOUBLE PRECISION Y INTEGER KRESLT NCALL = NCALL + 1 NAMEST(NCALL) = 'FMM2SP' KRESLT = 0 IF (ABS(MA(1)) > MEXPAB) THEN CALL FMARGS('FMM2SP',1,MA,MA,KRESLT) ENDIF IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) IF (KRESLT /= 0) THEN ! Here no valid result can be returned. Set X to some ! value that the user is likely to recognize as wrong. X = RUNKNO KFLAG = -4 IF (MA(1) /= MUNKNO) CALL FMWARN Y = DBLE(X) IF (NTRACE /= 0) CALL FMNTRR(1,Y,1) NCALL = NCALL - 1 RETURN ENDIF CALL FMMD(MA,Y) X = REAL(Y) IF (NTRACE /= 0) THEN Y = DBLE(X) CALL FMNTRR(1,Y,1) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMM2SP SUBROUTINE FMMAX(MA,MB,MC) ! MC = MAX(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) INTEGER KWRNSV LOGICAL FMCOMP KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMMAX ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1) KWRNSV = KWARN KWARN = 0 IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN CALL FMST2M('UNKNOWN',MC) KFLAG = -4 ELSE IF (FMCOMP(MA,'LT',MB)) THEN CALL FMEQ(MB,MC) ELSE CALL FMEQ(MA,MC) ENDIF KWARN = KWRNSV IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMMAX SUBROUTINE FMMD(MA,X) ! X = MA ! Internal routine for conversion to double precision. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) DOUBLE PRECISION X DOUBLE PRECISION Y,YT,XBASE,RZERO,ONE,PMAX,DLOGDP REAL (KIND(1.0D0)) :: MA1,MAS INTEGER J,KWRNSV,N1,NCASE ! Check to see if MA is in range for single or double ! precision. IF (MBLOGS /= MBASE) CALL FMCONS PMAX = DPMAX IF (NCALL > 0) THEN IF (NAMEST(NCALL) == 'FMM2SP') PMAX = DBLE(SPMAX) ENDIF DLOGDP = LOG(PMAX) MA1 = MA(1) NCASE = 0 IF (DBLE(MA(1)-1)*DLOGMB > DLOGDP) THEN KFLAG = -4 X = DBLE(RUNKNO) CALL FMWARN RETURN ELSE IF (DBLE(MA(1)+1)*DLOGMB > DLOGDP) THEN MA1 = MA1 - 2 NCASE = 1 ELSE IF (DBLE(MA(1)+1)*DLOGMB < -DLOGDP) THEN KFLAG = -10 X = 0.0D0 CALL FMWARN RETURN ELSE IF (DBLE(MA(1)-1)*DLOGMB < -DLOGDP) THEN MA1 = MA1 + 2 NCASE = 2 ENDIF ! Try FMMI first so that small integers will be ! converted exactly. KWRNSV = KWARN KWARN = 0 CALL FMMI(MA,J) KWARN = KWRNSV IF (KFLAG == 0) THEN X = J RETURN ENDIF KFLAG = 0 MAS = MA(-1) RZERO = 0.0D0 ONE = 1.0D0 N1 = NDIG + 1 XBASE = MBASE X = RZERO Y = ONE DO J = 2, N1 Y = Y/XBASE YT = MA(J) X = X + Y*YT YT = ONE + Y*XBASE IF (YT <= ONE) GO TO 110 ENDDO 110 X = X*XBASE**MA1 IF (MAS < 0) X = -X ! Check the result if it is near overflow or underflow. IF (NCASE == 1) THEN IF (X <= PMAX/(XBASE*XBASE)) THEN X = X*XBASE*XBASE ELSE KFLAG = -4 X = DBLE(RUNKNO) CALL FMWARN ENDIF ELSE IF (NCASE == 2) THEN IF (X >= (1.0D0/PMAX)*XBASE*XBASE) THEN X = X/(XBASE*XBASE) ELSE KFLAG = -10 X = 0.0D0 CALL FMWARN ENDIF ENDIF RETURN END SUBROUTINE FMMD SUBROUTINE FMMI(MA,IVAL) ! IVAL = MA. Internal FM to integer conversion routine. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER IVAL INTEGER J,KA,KB,LARGE,N1 KFLAG = 0 N1 = NDIG + 1 LARGE = INT(INTMAX/MBASE) IVAL = 0 IF (MA(1) <= 0) THEN IF (MA(2) /= 0) KFLAG = 2 RETURN ENDIF KB = INT(MA(1)) + 1 IVAL = INT(ABS(MA(2))) IF (KB >= 3) THEN DO J = 3, KB IF (IVAL > LARGE) THEN KFLAG = -4 IF (MA(1) /= MUNKNO) CALL FMWARN IVAL = IUNKNO RETURN ENDIF IF (J <= N1) THEN IVAL = IVAL*INT(MBASE) IF (IVAL > INTMAX-MA(J)) THEN KFLAG = -4 IF (MA(1) /= MUNKNO) CALL FMWARN IVAL = IUNKNO RETURN ELSE IVAL = IVAL + INT(MA(J)) ENDIF ELSE IVAL = IVAL*INT(MBASE) ENDIF ENDDO ENDIF IF (MA(-1) < 0) IVAL = -IVAL ! Check to see if MA is an integer. KA = KB + 1 IF (KA <= N1) THEN DO J = KA, N1 IF (MA(J) /= 0) THEN KFLAG = 2 RETURN ENDIF ENDDO ENDIF RETURN END SUBROUTINE FMMI SUBROUTINE FMMIN(MA,MB,MC) ! MC = MIN(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) INTEGER KWRNSV LOGICAL FMCOMP KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMMIN ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1) KWRNSV = KWARN KWARN = 0 IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN CALL FMST2M('UNKNOWN',MC) KFLAG = -4 ELSE IF (FMCOMP(MA,'GT',MB)) THEN CALL FMEQ(MB,MC) ELSE CALL FMEQ(MA,MC) ENDIF KWARN = KWRNSV IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMMIN SUBROUTINE FMMOD(MA,MB,MC) ! MC = MA(MOD MB). USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MVB,MVC,MVY,MVZ,MXSAVE INTEGER J,K,KASAVE,KB,KE,KN,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV LOGICAL FMCOMP IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB) THEN CALL FMENTR('FMMOD ',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMMOD ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MB,MC,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF KWRNSV = KWARN KWARN = 0 MACCA = MA(0) MACCB = MB(0) IF (MB(1) > MA(1) .AND. MB(2) /= 0) THEN CALL FMEQ2(MA,M01,NDSAVE,NDIG) M01(0) = NINT(NDIG*ALOGM2) ELSE ! Special cases when MB is a small integer. CALL FMEQ2(MA,M02,NDSAVE,NDIG) M02(0) = NINT(NDIG*ALOGM2) CALL FMEQ2(MB,M03,NDSAVE,NDIG) M03(0) = NINT(NDIG*ALOGM2) M02(-1) = 1 M03(-1) = 1 CALL FMM2I(M03,KB) IF (KFLAG == 0 .AND. KB < MXBASE) THEN IF (KB == 1 .OR. KB == -1) THEN IF (M02(1) >= NDIG) THEN CALL FMI2M(0,M01) GO TO 130 ELSE CALL FMINT(M02,M03) CALL FMSUB(M02,M03,M01) IF (MA(-1) < 0 .AND. M01(1) /= MUNKNO .AND. & M01(2) /= 0) M01(-1) = -M01(-1) GO TO 130 ENDIF ELSE IF (M02(1) == MEXPOV .OR. KB == 0) THEN KFLAG = -4 KWARN = KWRNSV KACCSW = KASAVE MXEXP = MXSAVE CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MC) IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1) NCALL = NCALL - 1 RETURN ELSE IF (M02(1) > NDIG.AND.MOD(INT(MBASE),KB) == 0) THEN CALL FMI2M(0,M01) GO TO 130 ENDIF IF (M02(1) < NDIG) THEN DO J = INT(M02(1))+1, NDIG+1 IF (M02(J) /= 0) GO TO 120 ENDDO ENDIF KE = MIN(INT(M02(1)),NDIG) MVB = KB MVC = MOD(M02(2),MVB) DO J = 3, KE+1 MVC = MOD(MVC*MBASE+M02(J),MVB) ENDDO IF (MVC == 0) THEN CALL FMI2M(0,M01) GO TO 130 ENDIF KN = INT(M02(1)) - KE MVY = MOD(MBASE,MVB) MVZ = 1 IF (MOD(KN,2) == 1) MVZ = MVY IF (MVY /= 1) THEN 110 KN = KN/2 MVY = MOD(MVY*MVY,MVB) IF (MOD(KN,2) == 1) MVZ = MOD(MVZ*MVY,MVB) IF (KN > 1) GO TO 110 ENDIF MVZ = MOD(MVZ*MVC,MVB) KE = INT(MVZ) CALL FMI2M(KE,M01) IF (MA(-1) < 0 .AND. M01(1) /= MUNKNO .AND. & M01(2) /= 0) M01(-1) = -M01(-1) GO TO 130 ENDIF ! General case. 120 IF (MA(2) /= 0) THEN NDIG = NDIG + INT(MA(1)-MB(1)) ENDIF IF (NDIG > NDG2MX .OR. MB(2) == 0) THEN KFLAG = -9 IF (MA(1) == MEXPOV .OR. MB(1) == MEXPUN .OR. MB(2) == 0) & KFLAG = -4 KWARN = KWRNSV KACCSW = KASAVE MXEXP = MXSAVE CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MC) IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1) NCALL = NCALL - 1 RETURN ENDIF CALL FMEQ2(MA,M02,NDSAVE,NDIG) M02(0) = NINT(NDIG*ALOGM2) CALL FMEQ2(MB,M03,NDSAVE,NDIG) M03(0) = NINT(NDIG*ALOGM2) M02(-1) = 1 M03(-1) = 1 CALL FMDIV(M02,M03,M01) CALL FMINT(M01,M08) CALL FMEQ(M08,M01) CALL FMMPY_R1(M01,M03) CALL FMSUB_R2(M02,M01) ! Due to rounding, M01 may not be between 0 and MB here. NTRSAV = NTRACE NTRACE = 0 IF (FMCOMP(M01,'GE',M03)) THEN NTRACE = NTRSAV CALL FMSUB_R1(M01,M03) ENDIF NTRACE = NTRSAV IF (M01(-1) < 0) CALL FMADD_R1(M01,M03) IF (MA(-1) < 0 .AND. M01(1) /= MUNKNO .AND. M01(2) /= 0) & M01(-1) = -M01(-1) ENDIF 130 IF (KFLAG == 1) KFLAG = 0 KWARN = KWRNSV MACMAX = NINT((NDSAVE-1)*ALOGM2+LOG(REAL(ABS(M01(2))+1))/0.69315) M01(0) = MIN(M01(0),MACCA,MACCB,MACMAX) CALL FMEXIT(M01,MC,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMMOD SUBROUTINE FMMOVE(MW,MA) ! Move a result from a work area (MW) to MA. ! If the result has MW(2)=0, then it is shifted and the exponent ! adjusted when it is moved to MA. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MW(LMWA) INTEGER J,N1,N2 IF (MW(2) /= 0) THEN N1 = NDIG + 1 ! Major (Inner Loop) DO J = 1, N1 MA(J) = MW(J) ENDDO ELSE N2 = NDIG + 2 DO J = 3, N2 MA(J-1) = MW(J) ENDDO IF (MA(2) /= 0) THEN MA(1) = MW(1) - 1 ELSE MA(1) = 0 ENDIF ENDIF MA(-1) = 1 IF (ABS(MA(1)) > MXEXP) CALL FMTRAP(MA) RETURN END SUBROUTINE FMMOVE SUBROUTINE FMMPY(MA,MB,MC) ! MC = MA * MB ! When one of the numbers MA, MB is known to have more zero digits ! (base MBASE) than the other, it is faster if MB is the one with ! more zero digits. ! This routine performs the trace printing for multiplication. ! FMMPY2 is used to do the arithmetic. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMMPY ' CALL FMNTR(2,MA,MB,2,1) CALL FMMPY2(MA,MB,MC) CALL FMNTR(1,MC,MC,1,1) ELSE CALL FMMPY2(MA,MB,MC) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMMPY SUBROUTINE FMMPY2(MA,MB,MC) ! Internal multiplication routine. MC = MA * MB USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MR,MS,MT1,MT2 INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KSHIFT,L,N1,NGUARD IF (MBLOGS /= MBASE) CALL FMCONS JRSSAV = JRSIGN MACCA = MA(0) MACCB = MB(0) IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. & KDEBUG == 1) THEN CALL FMARGS('FMMPY ',2,MA,MB,KRESLT) IF (KRESLT /= 0) THEN NCALL = NCALL + 1 NAMEST(NCALL) = 'FMMPY ' CALL FMRSLT(MA,MB,MC,KRESLT) JRSIGN = JRSSAV NCALL = NCALL - 1 RETURN ENDIF ELSE IF (MA(2) == 0 .OR. MB(2) == 0) THEN CALL FMIM(0,MC) MC(0) = MIN(MACCA,MACCB) JRSIGN = JRSSAV RETURN ENDIF KFLAG = 0 ! Save the sign of MA and MB and then work only with ! positive numbers. MAS = MA(-1) MBS = MB(-1) ! NGUARD is the number of guard digits used. IF (NCALL > 1) THEN NGUARD = NGRD22 IF (NGUARD > NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 IF (NGUARD > NDIG) NGUARD = NDIG IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 2 ENDIF ENDIF IF (MA(2)*MB(2) < MBASE .AND. NGUARD < 3) NGUARD = 3 N1 = NDIG + 1 ! If MBASE is small, pack the input numbers and use a larger ! base to speed up the calculation. IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN MBASEL = MBASE NDIGL = NDIG NGUARL = NGUARD DO J = 2, 1000 MR = MBASE*MBASEL IF (4*MR > MXBASE) THEN N21 = J - 1 NDIG = (NDIGL-1)/N21 + 1 IF (NDIG < 2) NDIG = 2 NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG IF (NGRDN < 1) NGRDN = 1 EXIT ENDIF MBASE = MR ENDDO MBASEN = MBASE NDIGN = NDIG ELSE MBASE = MBASEN NDIG = NDIGN ENDIF MPMA(1) = 0 MPMB(1) = 0 L = 2 - N21 DO J = 2, NDIGL+2-N21, N21 MT1 = MA(J) MT2 = MB(J) DO K = J+1, J+N21-1 MT1 = MT1*MBASEL + MA(K) MT2 = MT2*MBASEL + MB(K) ENDDO MPMA(2+J/N21) = MT1 MPMB(2+J/N21) = MT2 L = J ENDDO DO J = 3+L/N21, NDIG+NGRDN+1 MPMA(J) = 0 MPMB(J) = 0 ENDDO IF (L+N21 <= NDIGL+1) THEN MT1 = 0 MT2 = 0 DO J = L+N21, L+2*N21-1 IF (J <= NDIGL+1) THEN MT1 = MT1*MBASEL + MA(J) MT2 = MT2*MBASEL + MB(J) ELSE MT1 = MT1*MBASEL MT2 = MT2*MBASEL ENDIF ENDDO MPMA(2+(L+N21)/N21) = MT1 MPMB(2+(L+N21)/N21) = MT2 ENDIF CALL FMMPY3(MPMA,MPMB,NGRDN,KSHIFT) IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN DO J = 1+NDIG+NGRDN, 2, -1 KT1 = MWA(J) KT = 2 + (J-2)*N21 KT2 = N21 + KT - 1 DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2) MWA(K) = IBITS(KT1,KT2-K,1) ENDDO ENDDO ELSE MS = MBASEL**(N21-1) DO J = 1+NDIG+NGRDN, 2, -1 MR = MS MT1 = MWA(J) DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2) MWA(K) = AINT (MT1/MR) MT1 = MT1 - MWA(K)*MR MR = AINT (MR/MBASEL) ENDDO ENDDO ENDIF KSHIFT = 0 IF (MWA(2) == 0) KSHIFT = 1 MWA(1) = MA(1) + MB(1) NDIG = NDIGL MBASE = MBASEL ELSE CALL FMMPY3(MA,MB,NGUARD,KSHIFT) ENDIF ! The multiplication is complete. Round the result, ! move it to MC, and append the correct sign. IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF MR = 2*MWA(NDIG+2+KSHIFT) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ELSE IF (MR >= MBASE) THEN IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1 MWA(N1+1+KSHIFT) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ENDIF ENDIF CALL FMMOVE(MWA,MC) IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMMPY ' CALL FMWARN ENDIF MC(-1) = 1 IF (MAS*MBS < 0 .AND. MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1 IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315) MC(0) = MIN(MACCA,MACCB,MD2B) ELSE MC(0) = MIN(MACCA,MACCB) ENDIF JRSIGN = JRSSAV RETURN END SUBROUTINE FMMPY2 SUBROUTINE FMMPY_R1(MA,MB) ! MA = MA * MB ! When one of the numbers MA, MB is known to have more zero digits ! (base MBASE) than the other, it is faster if MB is the one with ! more zero digits. ! This routine performs the trace printing for multiplication. ! FMMPY2_R1 is used to do the arithmetic. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMMPY ' CALL FMNTR(2,MA,MB,2,1) CALL FMMPY2_R1(MA,MB) CALL FMNTR(1,MA,MA,1,1) ELSE CALL FMMPY2_R1(MA,MB) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMMPY_R1 SUBROUTINE FMMPY2_R1(MA,MB) ! Internal multiplication routine. MA = MA * MB USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MR,MS,MT1,MT2 INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KSHIFT,L,N1,NGUARD IF (MBLOGS /= MBASE) CALL FMCONS JRSSAV = JRSIGN MACCA = MA(0) MACCB = MB(0) IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. & KDEBUG == 1) THEN CALL FMARGS('FMMPY ',2,MA,MB,KRESLT) IF (KRESLT /= 0) THEN NCALL = NCALL + 1 NAMEST(NCALL) = 'FMMPY ' CALL FMRSLT(MA,MB,M07,KRESLT) CALL FMEQ(M07,MA) JRSIGN = JRSSAV NCALL = NCALL - 1 RETURN ENDIF ELSE IF (MA(2) == 0 .OR. MB(2) == 0) THEN CALL FMIM(0,MA) MA(0) = MIN(MACCA,MACCB) JRSIGN = JRSSAV RETURN ENDIF KFLAG = 0 ! Save the sign of MA and MB and then work only with ! positive numbers. MAS = MA(-1) MBS = MB(-1) ! NGUARD is the number of guard digits used. IF (NCALL > 1) THEN NGUARD = NGRD22 IF (NGUARD > NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 IF (NGUARD > NDIG) NGUARD = NDIG IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 2 ENDIF ENDIF IF (MA(2)*MB(2) < MBASE .AND. NGUARD < 3) NGUARD = 3 N1 = NDIG + 1 ! If MBASE is small, pack the input numbers and use a larger ! base to speed up the calculation. IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN MBASEL = MBASE NDIGL = NDIG NGUARL = NGUARD DO J = 2, 1000 MR = MBASE*MBASEL IF (4*MR > MXBASE) THEN N21 = J - 1 NDIG = (NDIGL-1)/N21 + 1 IF (NDIG < 2) NDIG = 2 NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG IF (NGRDN < 1) NGRDN = 1 EXIT ENDIF MBASE = MR ENDDO MBASEN = MBASE NDIGN = NDIG ELSE MBASE = MBASEN NDIG = NDIGN ENDIF MPMA(1) = 0 MPMB(1) = 0 L = 2 - N21 DO J = 2, NDIGL+2-N21, N21 MT1 = MA(J) MT2 = MB(J) DO K = J+1, J+N21-1 MT1 = MT1*MBASEL + MA(K) MT2 = MT2*MBASEL + MB(K) ENDDO MPMA(2+J/N21) = MT1 MPMB(2+J/N21) = MT2 L = J ENDDO DO J = 3+L/N21, NDIG+NGRDN+1 MPMA(J) = 0 MPMB(J) = 0 ENDDO IF (L+N21 <= NDIGL+1) THEN MT1 = 0 MT2 = 0 DO J = L+N21, L+2*N21-1 IF (J <= NDIGL+1) THEN MT1 = MT1*MBASEL + MA(J) MT2 = MT2*MBASEL + MB(J) ELSE MT1 = MT1*MBASEL MT2 = MT2*MBASEL ENDIF ENDDO MPMA(2+(L+N21)/N21) = MT1 MPMB(2+(L+N21)/N21) = MT2 ENDIF CALL FMMPY3(MPMA,MPMB,NGRDN,KSHIFT) IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN DO J = 1+NDIG+NGRDN, 2, -1 KT1 = MWA(J) KT = 2 + (J-2)*N21 KT2 = N21 + KT - 1 DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2) MWA(K) = IBITS(KT1,KT2-K,1) ENDDO ENDDO ELSE MS = MBASEL**(N21-1) DO J = 1+NDIG+NGRDN, 2, -1 MR = MS MT1 = MWA(J) DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2) MWA(K) = AINT (MT1/MR) MT1 = MT1 - MWA(K)*MR MR = AINT (MR/MBASEL) ENDDO ENDDO ENDIF KSHIFT = 0 IF (MWA(2) == 0) KSHIFT = 1 MWA(1) = MA(1) + MB(1) NDIG = NDIGL MBASE = MBASEL ELSE CALL FMMPY3(MA,MB,NGUARD,KSHIFT) ENDIF ! The multiplication is complete. Round the result, ! move it to MA, and append the correct sign. IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF MR = 2*MWA(NDIG+2+KSHIFT) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ELSE IF (MR >= MBASE) THEN IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1 MWA(N1+1+KSHIFT) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ENDIF ENDIF CALL FMMOVE(MWA,MA) IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMMPY ' CALL FMWARN ENDIF MA(-1) = 1 IF (MAS*MBS < 0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1 IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315) MA(0) = MIN(MACCA,MACCB,MD2B) ELSE MA(0) = MIN(MACCA,MACCB) ENDIF JRSIGN = JRSSAV RETURN END SUBROUTINE FMMPY2_R1 SUBROUTINE FMMPY_R2(MA,MB) ! MB = MA * MB ! When one of the numbers MA, MB is known to have more zero digits ! (base MBASE) than the other, it is faster if MB is the one with ! more zero digits. ! This routine performs the trace printing for multiplication. ! FMMPY2_R2 is used to do the arithmetic. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMMPY ' CALL FMNTR(2,MA,MB,2,1) CALL FMMPY2_R2(MA,MB) CALL FMNTR(1,MB,MB,1,1) ELSE CALL FMMPY2_R2(MA,MB) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMMPY_R2 SUBROUTINE FMMPY2_R2(MA,MB) ! Internal multiplication routine. MB = MA * MB USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MR,MS,MT1,MT2 INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KSHIFT,L,N1,NGUARD IF (MBLOGS /= MBASE) CALL FMCONS JRSSAV = JRSIGN MACCA = MA(0) MACCB = MB(0) IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. & KDEBUG == 1) THEN CALL FMARGS('FMMPY ',2,MA,MB,KRESLT) IF (KRESLT /= 0) THEN NCALL = NCALL + 1 NAMEST(NCALL) = 'FMMPY ' CALL FMRSLT(MA,MB,M07,KRESLT) CALL FMEQ(M07,MB) JRSIGN = JRSSAV NCALL = NCALL - 1 RETURN ENDIF ELSE IF (MA(2) == 0 .OR. MB(2) == 0) THEN CALL FMIM(0,MB) MB(0) = MIN(MACCA,MACCB) JRSIGN = JRSSAV RETURN ENDIF KFLAG = 0 ! Save the sign of MA and MB and then work only with ! positive numbers. MAS = MA(-1) MBS = MB(-1) ! NGUARD is the number of guard digits used. IF (NCALL > 1) THEN NGUARD = NGRD22 IF (NGUARD > NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 IF (NGUARD > NDIG) NGUARD = NDIG IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 2 ENDIF ENDIF IF (MA(2)*MB(2) < MBASE .AND. NGUARD < 3) NGUARD = 3 N1 = NDIG + 1 ! If MBASE is small, pack the input numbers and use a larger ! base to speed up the calculation. IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN MBASEL = MBASE NDIGL = NDIG NGUARL = NGUARD DO J = 2, 1000 MR = MBASE*MBASEL IF (4*MR > MXBASE) THEN N21 = J - 1 NDIG = (NDIGL-1)/N21 + 1 IF (NDIG < 2) NDIG = 2 NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG IF (NGRDN < 1) NGRDN = 1 EXIT ENDIF MBASE = MR ENDDO MBASEN = MBASE NDIGN = NDIG ELSE MBASE = MBASEN NDIG = NDIGN ENDIF MPMA(1) = 0 MPMB(1) = 0 L = 2 - N21 DO J = 2, NDIGL+2-N21, N21 MT1 = MA(J) MT2 = MB(J) DO K = J+1, J+N21-1 MT1 = MT1*MBASEL + MA(K) MT2 = MT2*MBASEL + MB(K) ENDDO MPMA(2+J/N21) = MT1 MPMB(2+J/N21) = MT2 L = J ENDDO DO J = 3+L/N21, NDIG+NGRDN+1 MPMA(J) = 0 MPMB(J) = 0 ENDDO IF (L+N21 <= NDIGL+1) THEN MT1 = 0 MT2 = 0 DO J = L+N21, L+2*N21-1 IF (J <= NDIGL+1) THEN MT1 = MT1*MBASEL + MA(J) MT2 = MT2*MBASEL + MB(J) ELSE MT1 = MT1*MBASEL MT2 = MT2*MBASEL ENDIF ENDDO MPMA(2+(L+N21)/N21) = MT1 MPMB(2+(L+N21)/N21) = MT2 ENDIF CALL FMMPY3(MPMA,MPMB,NGRDN,KSHIFT) IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN DO J = 1+NDIG+NGRDN, 2, -1 KT1 = MWA(J) KT = 2 + (J-2)*N21 KT2 = N21 + KT - 1 DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2) MWA(K) = IBITS(KT1,KT2-K,1) ENDDO ENDDO ELSE MS = MBASEL**(N21-1) DO J = 1+NDIG+NGRDN, 2, -1 MR = MS MT1 = MWA(J) DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2) MWA(K) = AINT (MT1/MR) MT1 = MT1 - MWA(K)*MR MR = AINT (MR/MBASEL) ENDDO ENDDO ENDIF KSHIFT = 0 IF (MWA(2) == 0) KSHIFT = 1 MWA(1) = MA(1) + MB(1) NDIG = NDIGL MBASE = MBASEL ELSE CALL FMMPY3(MA,MB,NGUARD,KSHIFT) ENDIF ! The multiplication is complete. Round the result, ! move it to MB, and append the correct sign. IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF MR = 2*MWA(NDIG+2+KSHIFT) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ELSE IF (MR >= MBASE) THEN IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1 MWA(N1+1+KSHIFT) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ENDIF ENDIF CALL FMMOVE(MWA,MB) IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMMPY ' CALL FMWARN ENDIF MB(-1) = 1 IF (MAS*MBS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1 IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MACCA,MACCB,MD2B) ELSE MB(0) = MIN(MACCA,MACCB) ENDIF JRSIGN = JRSSAV RETURN END SUBROUTINE FMMPY2_R2 SUBROUTINE FMMPY3(MA,MB,NGUARD,KSHIFT) ! Internal multiplication of MA*MB. The result is returned in MWA. ! Both MA and MB are positive. ! NGUARD is the number of guard digits that will be used. ! KSHIFT = 1 is returned if a left shift is pending (i.e., MWA(2)=0). ! The shift will be done in FMMOVE. KSHIFT = 0 is returned ! if no shift is pending. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER NGUARD,KSHIFT REAL (KIND(1.0D0)) :: MAXMWA,MBJ,MBKJ,MBM1,MBNORM,MK,MKT,MMAX,MT INTEGER J,JM1,K,KB,KI,KJ,KL,KNZ,KWA,L,N1 N1 = NDIG + 1 MWA(1) = MA(1) + MB(1) L = N1 + NGUARD MWA(L+1) = 0 ! The multiplication loop begins here. ! MBNORM is the minimum number of digits that can be ! multiplied before normalization is required. ! MAXMWA is an upper bound on the size of values in MWA ! divided by (MBASE-1). It is used to determine ! whether to normalize before the next digit is ! multiplied. MBM1 = MBASE - 1 MBNORM = AINT (MAXINT/(MBM1*MBM1)) MMAX = INTMAX - MBASE MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX) IF (MBNORM > 1) THEN MBJ = MB(2) ! Count the trailing zeros in MA. IF (MA(N1) /= 0) THEN KNZ = N1 ELSE DO J = NDIG, 2, -1 IF (MA(J) /= 0) THEN KNZ = J GO TO 110 ENDIF ENDDO ENDIF 110 MWA(2) = 0 DO K = NDIG+2, L MWA(K) = 0 ENDDO ! (Inner Loop) DO K = 2, N1 MWA(K+1) = MA(K)*MBJ ENDDO MAXMWA = MBJ DO J = 3, N1 MBJ = MB(J) IF (MBJ /= 0) THEN MAXMWA = MAXMWA + MBJ JM1 = J - 1 KL = MIN(KNZ,L-JM1) ! Major (Inner Loop) DO K = J+1, J+KL-1 MWA(K) = MWA(K) + MA(K-JM1)*MBJ ENDDO ENDIF IF (MAXMWA > MMAX) THEN MAXMWA = 0 ! Here normalization is only required for the ! range of digits currently changing in MWA. DO KB = JM1+KL, JM1+2, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE ENDDO ENDIF ENDDO ! Perform the final normalization. (Inner Loop) DO KB = L, 3, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE ENDDO ELSE ! If normalization must be done for each digit, combine ! the two loops and normalize as the digits are multiplied. DO J = 2, L MWA(J) = 0 ENDDO KJ = NDIG + 2 DO J = 2, N1 KJ = KJ - 1 MBKJ = MB(KJ) IF (MBKJ == 0) CYCLE KL = L - KJ + 1 IF (KL > N1) KL = N1 KI = KL + 2 KWA = KL+ KJ + 1 MK = 0 DO K = 2, KL MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MK MK = INT (MT/MBASE) MWA(KWA-K) = MT - MBASE*MK ENDDO MWA(KWA-KL-1) = MK ENDDO ENDIF ! Set KSHIFT = 1 if a shift left is necessary. IF (MWA(2) == 0) THEN KSHIFT = 1 RETURN ELSE KSHIFT = 0 RETURN ENDIF END SUBROUTINE FMMPY3 SUBROUTINE FMMPYD(MA,MB,MC,MD,ME) ! Double multiplication routine. MD = MA * MB, ME = MA * MC ! It is usually slightly faster to do two multiplications that ! have a common factor with one call. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK), & MD(-1:LUNPCK),ME(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACCB,MACCC,MAS,MAXMWA,MBS,MBJ,MBKJ, & MBM1,MBNORM,MCJ,MCKJ,MCS,MD2B,MKB,MKC,MKT, & MMAX,MR,MT,MTEMP INTEGER J,JM1,JRSSAV,K,KB,KI,KJ,KL,KNZ,KOVUN,KSHIFT,KWA,L,N1,NGUARD NCALL = NCALL + 1 JRSSAV = JRSIGN IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMMPYD' CALL FMNTR(2,MA,MB,2,1) IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN IF (NTRACE < 0) THEN CALL FMNTRJ(MC,NDIG) ELSE CALL FMPRNT(MC) ENDIF ENDIF ENDIF IF (MBLOGS /= MBASE) CALL FMCONS MACCA = MA(0) MACCB = MB(0) MACCC = MC(0) IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. & ABS(MC(1)) > MEXPAB .OR. MBASE*MBASE <= MXBASE/(4*MBASE)) THEN KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN .OR. & MB(1) == MEXPOV .OR. MB(1) == MEXPUN .OR. & MC(1) == MEXPOV .OR. MC(1) == MEXPUN) KOVUN = 1 IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR. & MC(1) == MUNKNO) KOVUN = 2 NCALL = NCALL + 1 CALL FMMPY2(MA,MB,MWD) KB = KFLAG CALL FMMPY2(MA,MC,ME) NCALL = NCALL - 1 IF (((KFLAG < 0 .OR. KB < 0) .AND. KOVUN == 0) .OR. & ((KFLAG == -4 .OR. KB == -4) .AND. KOVUN == 1)) THEN IF (KFLAG == -4 .OR. KB == -4) THEN KFLAG = -4 ELSE IF (KFLAG == -5 .OR. KB == -5) THEN KFLAG = -5 ELSE KFLAG = MIN(KFLAG,KB) ENDIF NAMEST(NCALL) = 'FMMPYD' CALL FMWARN ENDIF CALL FMEQ(MWD,MD) GO TO 120 ENDIF IF (MA(2) == 0) THEN CALL FMIM(0,MD) MD(0) = MIN(MACCA,MACCB) CALL FMIM(0,ME) ME(0) = MIN(MACCA,MACCC) GO TO 120 ENDIF IF (MB(2) == 0) THEN CALL FMMPY2(MA,MC,ME) CALL FMIM(0,MD) MD(0) = MIN(MACCA,MACCB) GO TO 120 ENDIF IF (MC(2) == 0) THEN CALL FMMPY2(MA,MB,MD) CALL FMIM(0,ME) ME(0) = MIN(MACCA,MACCC) GO TO 120 ENDIF KFLAG = 0 ! NGUARD is the number of guard digits used. IF (NCALL > 1) THEN NGUARD = NGRD22 IF (NGUARD > NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 IF (NGUARD > NDIG) NGUARD = NDIG IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 10 ENDIF ENDIF IF ((MA(2)*MB(2) < MBASE .OR. MA(2)*MC(2) < MBASE) & .AND. NGUARD < 3) NGUARD = 3 ! Save the sign of MA, MB, and MC and then ! work only with positive numbers. MAS = MA(-1) MBS = MB(-1) MCS = MC(-1) N1 = NDIG + 1 MWA(1) = MA(1) + MB(1) MWD(1) = MA(1) + MC(1) L = NDIG + 1 + NGUARD MWA(L+1) = 0 MWD(L+1) = 0 ! The multiplication loop begins here. ! MBNORM is the minimum number of digits that can be ! multiplied before normalization is required. ! MAXMWA is an upper bound on the size of values in MWA ! divided by (MBASE-1). It is used to determine ! whether to normalize before the next digit is ! multiplied. MBM1 = MBASE - 1 MBNORM = AINT (MAXINT/(MBM1*MBM1)) MMAX = INTMAX - MBASE MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX) IF (MBNORM > 1) THEN MBJ = MB(2) MCJ = MC(2) ! Count the trailing zeros in MA. IF (MA(N1) /= 0) THEN KNZ = N1 ELSE DO J = NDIG, 2, -1 IF (MA(J) /= 0) THEN KNZ = J GO TO 110 ENDIF ENDDO ENDIF 110 MWA(2) = 0 MWD(2) = 0 DO K = NDIG+2, L MWA(K) = 0 MWD(K) = 0 ENDDO ! (Inner Loop) DO K = 2, N1 MTEMP = MA(K) MWA(K+1) = MTEMP*MBJ MWD(K+1) = MTEMP*MCJ ENDDO IF (MBJ > MCJ) THEN MAXMWA = MBJ ELSE MAXMWA = MCJ ENDIF DO J = 3, N1 MBJ = MB(J) MCJ = MC(J) IF (MBJ > MCJ) THEN MAXMWA = MAXMWA + MBJ ELSE MAXMWA = MAXMWA + MCJ ENDIF JM1 = J - 1 KL = MIN(KNZ,L-JM1) ! Major (Inner Loop) DO K = J+1, J+KL-1 MTEMP = MA(K-JM1) MWA(K) = MWA(K) + MTEMP*MBJ MWD(K) = MWD(K) + MTEMP*MCJ ENDDO IF (MAXMWA > MMAX) THEN MAXMWA = 0 ! Here normalization is only required for the ! range of digits currently changing in MWA. DO KB = JM1+KL, JM1+2, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE MKT = INT (MWD(KB)/MBASE) MWD(KB-1) = MWD(KB-1) + MKT MWD(KB) = MWD(KB) - MKT*MBASE ENDDO ENDIF ENDDO ! Perform the final normalization. (Inner Loop) DO KB = L, 3, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE MKT = INT (MWD(KB)/MBASE) MWD(KB-1) = MWD(KB-1) + MKT MWD(KB) = MWD(KB) - MKT*MBASE ENDDO ELSE ! If normalization must be done for each digit, combine ! the two loops and normalize as the digits are multiplied. DO J = 2, L MWA(J) = 0 MWD(J) = 0 ENDDO KJ = NDIG + 2 DO J = 2, N1 KJ = KJ - 1 MBKJ = MB(KJ) MCKJ = MC(KJ) KL = L - KJ + 1 IF (KL > N1) KL = N1 KI = KL + 2 KWA = KL+ KJ + 1 MKB = 0 MKC = 0 DO K = 2, KL MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MKB MKB = INT (MT/MBASE) MWA(KWA-K) = MT - MBASE*MKB MT = MA(KI-K)*MCKJ + MWD(KWA-K) + MKC MKC = INT (MT/MBASE) MWD(KWA-K) = MT - MBASE*MKC ENDDO MWA(KWA-KL-1) = MKB MWD(KWA-KL-1) = MKC ENDDO ENDIF ! Set KSHIFT = 1 if a shift left is necessary. IF (MWA(2) == 0) THEN KSHIFT = 1 ELSE KSHIFT = 0 ENDIF ! The multiplications are complete. IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF MR = 2*MWA(NDIG+2+KSHIFT) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ELSE IF (MR >= MBASE) THEN IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1 MWA(N1+1+KSHIFT) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ENDIF ENDIF CALL FMMOVE(MWA,MD) IF ((MAS > 0 .AND. MCS > 0) .OR. (MAS < 0 .AND. MCS < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF IF (MWD(2) == 0) THEN KSHIFT = 1 ELSE KSHIFT = 0 ENDIF MR = 2*MWD(NDIG+2+KSHIFT) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWD,NDIG,NGUARD,KSHIFT) ELSE IF (MR >= MBASE) THEN IF (MR-1 > MBASE .AND. MWD(N1+KSHIFT) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWD(N1+KSHIFT) = MWD(N1+KSHIFT) + 1 MWD(N1+1+KSHIFT) = 0 ENDIF ELSE CALL FMRND(MWD,NDIG,NGUARD,KSHIFT) ENDIF ENDIF CALL FMMOVE(MWD,ME) IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMMPYD' CALL FMWARN ENDIF MD(-1) = 1 IF (MAS*MBS < 0 .AND. MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -1 ME(-1) = 1 IF (MAS*MCS < 0 .AND. ME(1) /= MUNKNO .AND. ME(2) /= 0) ME(-1) = -1 IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MD(2))+1))/0.69315) MD(0) = MIN(MACCA,MACCB,MD2B) MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(ME(2))+1))/0.69315) ME(0) = MIN(MACCA,MACCC,MD2B) ELSE MD(0) = MIN(MACCA,MACCB) ME(0) = MIN(MACCA,MACCC) ENDIF 120 IF (NTRACE /= 0) THEN CALL FMNTR(1,MD,MD,1,1) IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN IF (NTRACE < 0) THEN CALL FMNTRJ(ME,NDIG) ELSE CALL FMPRNT(ME) ENDIF ENDIF ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN END SUBROUTINE FMMPYD SUBROUTINE FMMPYE(MA,MB,MC,MD,ME,MF,MG) ! Triple multiplication routine. ! ME = MA * MB, MF = MA * MC, MG = MA * MD ! It is usually slightly faster to do three multiplications that ! have a common factor with one call. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK), & MD(-1:LUNPCK),ME(-1:LUNPCK),MF(-1:LUNPCK), & MG(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACCB,MACCC,MACCD,MAS,MAXJ,MAXMWA,MBS,MBJ, & MBKJ,MBM1,MBNORM,MCJ,MCKJ,MCS,MD2B,MDJ,MDKJ,MDS, & MKB,MKC,MKD,MKT,MMAX,MR,MT,MTEMP INTEGER J,JM1,JRSSAV,K,KB,KI,KJ,KL,KNZ,KOVUN,KSHIFT,KWA,L,N1,NGUARD NCALL = NCALL + 1 JRSSAV = JRSIGN IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMMPYE' CALL FMNTR(2,MA,MB,2,1) IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN IF (NTRACE < 0) THEN CALL FMNTRJ(MC,NDIG) CALL FMNTRJ(MD,NDIG) ELSE CALL FMPRNT(MC) CALL FMPRNT(MD) ENDIF ENDIF ENDIF IF (MBLOGS /= MBASE) CALL FMCONS MACCA = MA(0) MACCB = MB(0) MACCC = MC(0) MACCD = MD(0) IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. & ABS(MC(1)) > MEXPAB .OR. ABS(MD(1)) > MEXPAB .OR. & MBASE*MBASE <= MXBASE/(4*MBASE)) THEN KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN .OR. & MB(1) == MEXPOV .OR. MB(1) == MEXPUN .OR. & MC(1) == MEXPOV .OR. MC(1) == MEXPUN .OR. & MD(1) == MEXPOV .OR. MD(1) == MEXPUN) KOVUN = 1 IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR. & MC(1) == MUNKNO .OR. MD(1) == MUNKNO) KOVUN = 2 NCALL = NCALL + 1 CALL FMMPY2(MA,MB,MWD) KB = KFLAG CALL FMMPY2(MA,MC,MWE) KJ = KFLAG CALL FMMPY2(MA,MD,MG) NCALL = NCALL - 1 IF (((KFLAG < 0 .OR. KB < 0 .OR. KJ < 0) .AND. KOVUN == 0) & .OR. ((KFLAG == -4 .OR. KB == -4 .OR. KJ == -4) .AND. & KOVUN == 1)) THEN IF (KFLAG == -4 .OR. KB == -4 .OR. KJ == -4) THEN KFLAG = -4 ELSE IF (KFLAG == -5 .OR. KB == -5 .OR. KJ == -5) THEN KFLAG = -5 ELSE KFLAG = MIN(KFLAG,KB,KJ) ENDIF NAMEST(NCALL) = 'FMMPYE' CALL FMWARN ENDIF CALL FMEQ(MWD,ME) CALL FMEQ(MWE,MF) GO TO 120 ENDIF IF (MA(2) == 0) THEN CALL FMIM(0,ME) ME(0) = MIN(MACCA,MACCB) CALL FMIM(0,MF) MF(0) = MIN(MACCA,MACCC) CALL FMIM(0,MG) MG(0) = MIN(MACCA,MACCD) GO TO 120 ENDIF IF (MB(2) == 0 .OR. MC(2) == 0 .OR. MD(2) == 0) THEN CALL FMMPY2(MA,MB,MWD) CALL FMMPY2(MA,MC,MWE) CALL FMMPY2(MA,MD,MG) CALL FMEQ(MWD,ME) CALL FMEQ(MWE,MF) GO TO 120 ENDIF KFLAG = 0 ! NGUARD is the number of guard digits used. IF (NCALL > 1) THEN NGUARD = NGRD22 IF (NGUARD > NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 IF (NGUARD > NDIG) NGUARD = NDIG IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 10 ENDIF ENDIF IF ((MA(2)*MB(2) < MBASE .OR. MA(2)*MC(2) < MBASE .OR. & MA(2)*MD(2) < MBASE) .AND. NGUARD < 3) NGUARD = 3 ! Save the signs and then work only with positive numbers. MAS = MA(-1) MBS = MB(-1) MCS = MC(-1) MDS = MD(-1) N1 = NDIG + 1 MWA(1) = MA(1) + MB(1) MWD(1) = MA(1) + MC(1) MWE(1) = MA(1) + MD(1) L = NDIG + 1 + NGUARD MWA(L+1) = 0 MWD(L+1) = 0 MWE(L+1) = 0 ! The multiplication loop begins here. ! MBNORM is the minimum number of digits that can be ! multiplied before normalization is required. ! MAXMWA is an upper bound on the size of values in MWA ! divided by (MBASE-1). It is used to determine ! whether to normalize before the next digit is ! multiplied. MBM1 = MBASE - 1 MBNORM = AINT (MAXINT/(MBM1*MBM1)) MMAX = INTMAX - MBASE MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX) IF (MBNORM > 1) THEN MBJ = MB(2) MCJ = MC(2) MDJ = MD(2) ! Count the trailing zeros in MA. IF (MA(N1) /= 0) THEN KNZ = N1 ELSE DO J = NDIG, 2, -1 IF (MA(J) /= 0) THEN KNZ = J GO TO 110 ENDIF ENDDO ENDIF 110 MWA(2) = 0 MWD(2) = 0 MWE(2) = 0 DO K = NDIG+2, L MWA(K) = 0 MWD(K) = 0 MWE(K) = 0 ENDDO ! (Inner Loop) DO K = 2, N1 MTEMP = MA(K) MWA(K+1) = MTEMP*MBJ MWD(K+1) = MTEMP*MCJ MWE(K+1) = MTEMP*MDJ ENDDO MAXMWA = MBJ IF (MCJ > MAXMWA) MAXMWA = MCJ IF (MDJ > MAXMWA) MAXMWA = MDJ DO J = 3, N1 MBJ = MB(J) MCJ = MC(J) MDJ = MD(J) MAXJ = MBJ IF (MCJ > MAXJ) MAXJ = MCJ IF (MDJ > MAXJ) MAXJ = MDJ MAXMWA = MAXMWA + MAXJ JM1 = J - 1 KL = MIN(KNZ,L-JM1) ! Major (Inner Loop) DO K = J+1, J+KL-1 MTEMP = MA(K-JM1) MWA(K) = MWA(K) + MTEMP*MBJ MWD(K) = MWD(K) + MTEMP*MCJ MWE(K) = MWE(K) + MTEMP*MDJ ENDDO IF (MAXMWA > MMAX) THEN MAXMWA = 0 ! Here normalization is only required for the ! range of digits currently changing in MWA. DO KB = JM1+KL, JM1+2, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE MKT = INT (MWD(KB)/MBASE) MWD(KB-1) = MWD(KB-1) + MKT MWD(KB) = MWD(KB) - MKT*MBASE MKT = INT (MWE(KB)/MBASE) MWE(KB-1) = MWE(KB-1) + MKT MWE(KB) = MWE(KB) - MKT*MBASE ENDDO ENDIF ENDDO ! Perform the final normalization. (Inner Loop) DO KB = L, 3, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE MKT = INT (MWD(KB)/MBASE) MWD(KB-1) = MWD(KB-1) + MKT MWD(KB) = MWD(KB) - MKT*MBASE MKT = INT (MWE(KB)/MBASE) MWE(KB-1) = MWE(KB-1) + MKT MWE(KB) = MWE(KB) - MKT*MBASE ENDDO ELSE ! If normalization must be done for each digit, combine ! the two loops and normalize as the digits are multiplied. DO J = 2, L MWA(J) = 0 MWD(J) = 0 MWE(J) = 0 ENDDO KJ = NDIG + 2 DO J = 2, N1 KJ = KJ - 1 MBKJ = MB(KJ) MCKJ = MC(KJ) MDKJ = MD(KJ) KL = L - KJ + 1 IF (KL > N1) KL = N1 KI = KL + 2 KWA = KL+ KJ + 1 MKB = 0 MKC = 0 MKD = 0 DO K = 2, KL MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MKB MKB = INT (MT/MBASE) MWA(KWA-K) = MT - MBASE*MKB MT = MA(KI-K)*MCKJ + MWD(KWA-K) + MKC MKC = INT (MT/MBASE) MWD(KWA-K) = MT - MBASE*MKC MT = MA(KI-K)*MDKJ + MWE(KWA-K) + MKD MKD = INT (MT/MBASE) MWE(KWA-K) = MT - MBASE*MKD ENDDO MWA(KWA-KL-1) = MKB MWD(KWA-KL-1) = MKC MWE(KWA-KL-1) = MKD ENDDO ENDIF ! Set KSHIFT = 1 if a shift left is necessary. IF (MWA(2) == 0) THEN KSHIFT = 1 ELSE KSHIFT = 0 ENDIF ! The multiplications are complete. IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF MR = 2*MWA(NDIG+2+KSHIFT) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ELSE IF (MR >= MBASE) THEN IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1 MWA(N1+1+KSHIFT) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ENDIF ENDIF CALL FMMOVE(MWA,ME) IF ((MAS > 0 .AND. MCS > 0) .OR. (MAS < 0 .AND. MCS < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF IF (MWD(2) == 0) THEN KSHIFT = 1 ELSE KSHIFT = 0 ENDIF MR = 2*MWD(NDIG+2+KSHIFT) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWD,NDIG,NGUARD,KSHIFT) ELSE IF (MR >= MBASE) THEN IF (MR-1 > MBASE .AND. MWD(N1+KSHIFT) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWD(N1+KSHIFT) = MWD(N1+KSHIFT) + 1 MWD(N1+1+KSHIFT) = 0 ENDIF ELSE CALL FMRND(MWD,NDIG,NGUARD,KSHIFT) ENDIF ENDIF CALL FMMOVE(MWD,MF) IF ((MAS > 0 .AND. MDS > 0) .OR. (MAS < 0 .AND. MDS < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF IF (MWE(2) == 0) THEN KSHIFT = 1 ELSE KSHIFT = 0 ENDIF MR = 2*MWE(NDIG+2+KSHIFT) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWE,NDIG,NGUARD,KSHIFT) ELSE IF (MR >= MBASE) THEN IF (MR-1 > MBASE .AND. MWE(N1+KSHIFT) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWE(N1+KSHIFT) = MWE(N1+KSHIFT) + 1 MWE(N1+1+KSHIFT) = 0 ENDIF ELSE CALL FMRND(MWE,NDIG,NGUARD,KSHIFT) ENDIF ENDIF CALL FMMOVE(MWE,MG) IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMMPYE' CALL FMWARN ENDIF ME(-1) = 1 IF (MAS*MBS < 0 .AND. ME(1) /= MUNKNO .AND. ME(2) /= 0) ME(-1) = -1 MF(-1) = 1 IF (MAS*MCS < 0 .AND. MF(1) /= MUNKNO .AND. MF(2) /= 0) MF(-1) = -1 MG(-1) = 1 IF (MAS*MDS < 0 .AND. MG(1) /= MUNKNO .AND. MG(2) /= 0) MG(-1) = -1 IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(ME(2))+1))/0.69315) ME(0) = MIN(MACCA,MACCB,MD2B) MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MF(2))+1))/0.69315) MF(0) = MIN(MACCA,MACCC,MD2B) MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MG(2))+1))/0.69315) MG(0) = MIN(MACCA,MACCD,MD2B) ELSE ME(0) = MIN(MACCA,MACCB) MF(0) = MIN(MACCA,MACCC) MG(0) = MIN(MACCA,MACCD) ENDIF 120 IF (NTRACE /= 0) THEN CALL FMNTR(1,ME,ME,1,1) IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN IF (NTRACE < 0) THEN CALL FMNTRJ(MF,NDIG) CALL FMNTRJ(MG,NDIG) ELSE CALL FMPRNT(MF) CALL FMPRNT(MG) ENDIF ENDIF ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN END SUBROUTINE FMMPYE SUBROUTINE FMMPYI(MA,IVAL,MB) ! MB = MA * IVAL ! Multiply FM number MA by one word integer IVAL. ! This routine is faster than FMMPY when IVAL*MBASE is a ! one word integer. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER IVAL REAL (KIND(1.0D0)) :: MACCA,MAS,MCARRY,MD2B,MKT,MLR,MVAL INTEGER J,JRSSAV,KA,KB,KC,KSHIFT,N1,NGUARD,NMVAL,NV2 IF (MBLOGS /= MBASE) CALL FMCONS JRSSAV = JRSIGN MACCA = MA(0) NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMMPYI' CALL FMNTR(2,MA,MA,1,1) CALL FMNTRI(2,IVAL,0) ENDIF KFLAG = 0 N1 = NDIG + 1 ! Check for special cases. IF (MA(2) == 0) THEN CALL FMEQ(MA,MB) IF (NTRACE /= 0) THEN CALL FMNTR(1,MB,MB,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN ENDIF IF (ABS(MA(1)) < MEXPOV .AND. ABS(IVAL) > 1) GO TO 110 IF (MA(1) == MUNKNO) THEN CALL FMST2M('UNKNOWN',MB) KFLAG = -4 IF (NTRACE /= 0) THEN CALL FMNTR(1,MB,MB,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN ENDIF IF (IVAL == 0) THEN CALL FMIM(0,MB) IF (NTRACE /= 0) THEN CALL FMNTR(1,MB,MB,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN ENDIF IF (ABS(IVAL) == 1) THEN DO J = -1, N1 MB(J) = MA(J) ENDDO IF (MA(1) == MEXPOV) KFLAG = -5 IF (MA(1) == MEXPUN) KFLAG = -6 MB(-1) = MA(-1)*IVAL IF (NTRACE /= 0) THEN CALL FMNTR(1,MB,MB,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN ENDIF IF (MA(1) == MEXPOV) THEN MAS = MA(-1) KFLAG = -5 CALL FMST2M('OVERFLOW',MB) IF ((MAS < 0 .AND. IVAL > 0) .OR. & (MAS > 0 .AND. IVAL < 0)) MB(-1) = -1 IF (NTRACE /= 0) THEN CALL FMNTR(1,MB,MB,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN ENDIF IF (MA(1) == MEXPUN) THEN NAMEST(NCALL) = 'FMMPYI' KFLAG = -4 CALL FMWARN CALL FMST2M('UNKNOWN',MB) IF (NTRACE /= 0) THEN CALL FMNTR(1,MB,MB,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN ENDIF ! Work with positive numbers. 110 MAS = MA(-1) MVAL = ABS(IVAL) NMVAL = INT(MVAL) NV2 = NMVAL - 1 ! To leave room for the normalization, shift the product ! to the right KSHIFT places in MWA. KSHIFT = INT((LOG(DBLE(MA(2)+1)*DBLE(MVAL)))/DLOGMB) ! If IVAL is too big use FMMPY. IF (KSHIFT > NDIG .OR. MVAL > MAXINT/MBASE .OR. & NMVAL /= ABS(IVAL) .OR. NV2 /= ABS(IVAL)-1) THEN CALL FMIM(IVAL,M01) CALL FMMPY2(MA,M01,MB) IF (NTRACE /= 0) THEN CALL FMNTR(1,MB,MB,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN ENDIF MWA(1) = MA(1) + KSHIFT KA = 2 + KSHIFT KB = N1 + KSHIFT KC = NDIG + 5 DO J = KB, KC MWA(J) = 0 ENDDO MCARRY = 0 ! This is the main multiplication loop. DO J = KB, KA, -1 MKT = MA(J-KSHIFT)*MVAL + MCARRY MCARRY = INT (MKT/MBASE) MWA(J) = MKT - MCARRY*MBASE ENDDO ! Resolve the final carry. DO J = KA-1, 2, -1 MKT = INT (MCARRY/MBASE) MWA(J) = MCARRY - MKT*MBASE MCARRY = MKT ENDDO ! Now the first significant digit in the product is in ! MWA(2) or MWA(3). Round the result and move it to MB. IF ((MAS > 0 .AND. IVAL > 0) .OR. (MAS < 0 .AND. IVAL < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF IF (MWA(2) == 0) THEN MLR = 2*MWA(NDIG+3) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN NGUARD = KSHIFT - 1 CALL FMRND(MWA,NDIG,NGUARD,1) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1+1) = MWA(N1+1) + 1 MWA(N1+2) = 0 ENDIF ELSE NGUARD = KSHIFT - 1 CALL FMRND(MWA,NDIG,NGUARD,1) ENDIF ENDIF ELSE MLR = 2*MWA(NDIG+2) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,KSHIFT,0) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1) = MWA(N1) + 1 MWA(N1+1) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,KSHIFT,0) ENDIF ENDIF ENDIF CALL FMMOVE(MWA,MB) IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMMPYI' CALL FMWARN ENDIF ! Put the sign on the result. MB(-1) = JRSIGN IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MACCA,MD2B) ELSE MB(0) = MACCA ENDIF IF (NTRACE /= 0) THEN CALL FMNTR(1,MB,MB,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN END SUBROUTINE FMMPYI SUBROUTINE FMMPYI_R1(MA,IVAL) ! MA = MA * IVAL ! Multiply FM number MA by one word integer IVAL. ! This routine is faster than FMMPY when IVAL*MBASE is a ! one word integer. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER IVAL REAL (KIND(1.0D0)) :: MACCA,MAS,MCARRY,MD2B,MKT,MLR,MVAL INTEGER J,JRSSAV,KA,KB,KC,KSHIFT,N1,NGUARD,NMVAL,NV2 IF (MBLOGS /= MBASE) CALL FMCONS JRSSAV = JRSIGN MACCA = MA(0) NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMMPYI' CALL FMNTR(2,MA,MA,1,1) CALL FMNTRI(2,IVAL,0) ENDIF KFLAG = 0 N1 = NDIG + 1 ! Check for special cases. IF (MA(2) == 0) THEN IF (NTRACE /= 0) THEN CALL FMNTR(1,MA,MA,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN ENDIF IF (ABS(MA(1)) < MEXPOV .AND. ABS(IVAL) > 1) GO TO 110 IF (MA(1) == MUNKNO) THEN CALL FMST2M('UNKNOWN',MA) KFLAG = -4 IF (NTRACE /= 0) THEN CALL FMNTR(1,MA,MA,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN ENDIF IF (IVAL == 0) THEN CALL FMIM(0,MA) IF (NTRACE /= 0) THEN CALL FMNTR(1,MA,MA,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN ENDIF IF (ABS(IVAL) == 1) THEN IF (MA(1) == MEXPOV) KFLAG = -5 IF (MA(1) == MEXPUN) KFLAG = -6 MA(-1) = MA(-1)*IVAL IF (NTRACE /= 0) THEN CALL FMNTR(1,MA,MA,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN ENDIF IF (MA(1) == MEXPOV) THEN MAS = MA(-1) KFLAG = -5 CALL FMST2M('OVERFLOW',MA) IF ((MAS < 0 .AND. IVAL > 0) .OR. & (MAS > 0 .AND. IVAL < 0)) MA(-1) = -1 IF (NTRACE /= 0) THEN CALL FMNTR(1,MA,MA,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN ENDIF IF (MA(1) == MEXPUN) THEN NAMEST(NCALL) = 'FMMPYI' KFLAG = -4 CALL FMWARN CALL FMST2M('UNKNOWN',MA) IF (NTRACE /= 0) THEN CALL FMNTR(1,MA,MA,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN ENDIF ! Work with positive numbers. 110 MAS = MA(-1) MVAL = ABS(IVAL) NMVAL = INT(MVAL) NV2 = NMVAL - 1 ! To leave room for the normalization, shift the product ! to the right KSHIFT places in MWA. KSHIFT = INT((LOG(DBLE(MA(2)+1)*DBLE(MVAL)))/DLOGMB) ! If IVAL is too big use FMMPY. IF (KSHIFT > NDIG .OR. MVAL > MAXINT/MBASE .OR. & NMVAL /= ABS(IVAL) .OR. NV2 /= ABS(IVAL)-1) THEN CALL FMIM(IVAL,M01) CALL FMMPY2_R1(MA,M01) IF (NTRACE /= 0) THEN CALL FMNTR(1,MA,MA,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN ENDIF MWA(1) = MA(1) + KSHIFT KA = 2 + KSHIFT KB = N1 + KSHIFT KC = NDIG + 5 DO J = KB, KC MWA(J) = 0 ENDDO MCARRY = 0 ! This is the main multiplication loop. DO J = KB, KA, -1 MKT = MA(J-KSHIFT)*MVAL + MCARRY MCARRY = INT (MKT/MBASE) MWA(J) = MKT - MCARRY*MBASE ENDDO ! Resolve the final carry. DO J = KA-1, 2, -1 MKT = INT (MCARRY/MBASE) MWA(J) = MCARRY - MKT*MBASE MCARRY = MKT ENDDO ! Now the first significant digit in the product is in ! MWA(2) or MWA(3). Round the result and move it to MA. IF ((MAS > 0 .AND. IVAL > 0) .OR. (MAS < 0 .AND. IVAL < 0)) THEN JRSIGN = 1 ELSE JRSIGN = -1 ENDIF IF (MWA(2) == 0) THEN MLR = 2*MWA(NDIG+3) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN NGUARD = KSHIFT - 1 CALL FMRND(MWA,NDIG,NGUARD,1) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1+1) = MWA(N1+1) + 1 MWA(N1+2) = 0 ENDIF ELSE NGUARD = KSHIFT - 1 CALL FMRND(MWA,NDIG,NGUARD,1) ENDIF ENDIF ELSE MLR = 2*MWA(NDIG+2) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,KSHIFT,0) ELSE IF (MLR >= MBASE) THEN IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1) = MWA(N1) + 1 MWA(N1+1) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,KSHIFT,0) ENDIF ENDIF ENDIF CALL FMMOVE(MWA,MA) IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMMPYI' CALL FMWARN ENDIF ! Put the sign on the result. MA(-1) = JRSIGN IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315) MA(0) = MIN(MACCA,MD2B) ELSE MA(0) = MACCA ENDIF IF (NTRACE /= 0) THEN CALL FMNTR(1,MA,MA,1,1) ENDIF NCALL = NCALL - 1 JRSIGN = JRSSAV RETURN END SUBROUTINE FMMPYI_R1 SUBROUTINE FMNINT(MA,MB) ! MB = NINT(MA) -- MB is returned as the nearest integer to MA. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MA2,MXSAVE INTEGER J,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB) THEN CALL FMENTR('FMNINT',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMNINT' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF KWRNSV = KWARN KWARN = 0 CALL FMEQ2(MA,MB,NDSAVE,NDIG) IF (NDSAVE > INT(MA(1))) THEN MA2 = MA(-1) MB(-1) = 1 CALL FMI2M(1,M01) CALL FMDIVI_R1(M01,2) CALL FMADD_R1(MB,M01) CALL FMINT(MB,M08) CALL FMEQ(M08,MB) IF (MA2 < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1) ENDIF KWARN = KWRNSV ! Round the result and return. DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMNINT SUBROUTINE FMNTR(NTR,MA,MB,NARG,KNAM) ! Print FM numbers in base 10 format using FMOUT for conversion. ! This is used for trace output from the FM routines. ! NTR = 1 if a result of an FM call is to be printed. ! = 2 to print input argument(s) to an FM call. ! MA - the FM number to be printed. ! MB - an optional second FM number to be printed. ! NARG - the number of arguments. NARG = 1 if only MA is to be ! printed, and NARG = 2 if both MA and MB are to be printed. ! KNAM - positive if the routine name is to be printed. ! NTRACE and LVLTRC (in module FMVALS) control trace printout. ! NTRACE = 0 No printout except warnings and errors. ! NTRACE = 1 The result of each call to one of the routines ! is printed in base 10, using FMOUT. ! NTRACE = -1 The result of each call to one of the routines ! is printed in internal base MBASE format. ! NTRACE = 2 The input arguments and result of each call to one ! of the routines is printed in base 10, using FMOUT. ! NTRACE = -2 The input arguments and result of each call to one ! of the routines is printed in base MBASE format. ! LVLTRC defines the call level to which the trace is done. LVLTRC = 1 ! means only FM routines called directly by the user are traced, ! LVLTRC = K prints traces for FM routines with call levels up ! to and including level K. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER KNAM,NTR,NARG CHARACTER(6) :: NAME IF (NTRACE == 0) RETURN IF (NCALL > LVLTRC) RETURN IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN IF (NTR == 2) THEN IF (KNAM > 0) THEN NAME = NAMEST(NCALL) WRITE (KW,"(' Input to ',A6)") NAME ENDIF ELSE NAME = NAMEST(NCALL) IF (KFLAG == 0) THEN WRITE (KW, & "(' ',A6,15X,'Call level =',I2,5X,'MBASE ='," // & "I10,5X,'NDIG =',I6)" & ) NAME,NCALL,INT(MBASE),NDIG ELSE WRITE (KW, & "(' ',A6,6X,'Call level =',I2,4X,'MBASE ='," // & "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)" & ) NAME,NCALL,INT(MBASE),NDIG,KFLAG ENDIF ENDIF ! Check for base MBASE internal format trace. IF (NTRACE < 0) THEN CALL FMNTRJ(MA,NDIG) IF (NARG == 2) CALL FMNTRJ(MB,NDIG) ENDIF ! Check for base 10 trace using FMOUT. IF (NTRACE > 0) THEN CALL FMPRNT(MA) IF (NARG == 2) THEN CALL FMPRNT(MB) ENDIF ENDIF RETURN END SUBROUTINE FMNTR SUBROUTINE FMNTRI(NTR,N,KNAM) ! Internal routine for trace output of integer variables. ! NTR = 1 for output values ! 2 for input values ! N Integer to be printed. ! KNAM is positive if the routine name is to be printed. USE FMVALS IMPLICIT NONE INTEGER NTR,N,KNAM CHARACTER(6) :: NAME IF (NTRACE == 0) RETURN IF (NCALL > LVLTRC) RETURN IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN IF (NTR == 2 .AND. KNAM > 0) THEN NAME = NAMEST(NCALL) WRITE (KW,"(' Input to ',A6)") NAME ENDIF IF (NTR == 1 .AND. KNAM > 0) THEN NAME = NAMEST(NCALL) IF (KFLAG == 0) THEN WRITE (KW, & "(' ',A6,15X,'Call level =',I2,5X,'MBASE ='," // & "I10,5X,'NDIG =',I6)" & ) NAME,NCALL,INT(MBASE),NDIG ELSE WRITE (KW, & "(' ',A6,6X,'Call level =',I2,4X,'MBASE ='," // & "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)" & ) NAME,NCALL,INT(MBASE),NDIG,KFLAG ENDIF ENDIF WRITE (KW,"(1X,I18)") N RETURN END SUBROUTINE FMNTRI SUBROUTINE FMNTRJ(MA,ND) ! Print trace output in internal base MBASE format. The number to ! be printed is in MA. ! ND is the number of base MBASE digits to be printed. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER ND CHARACTER(50) :: FORM INTEGER J,L,N,N1 N1 = ND + 1 L = INT(LOG10(DBLE(MBASE-1))) + 2 N = (KSWIDE-23)/L IF (N > 10) N = 5*(N/5) IF (ND <= N) THEN WRITE (FORM,"(' (1X,I19,I',I2,',',I3,'I',I2,') ')") L+2, N-1, L ELSE WRITE (FORM, & "(' (1X,I19,I',I2,',',I3,'I',I2,'/" // & "(22X,',I3,'I',I2,')) ')" & ) L+2, N-1, L, N, L ENDIF WRITE (KW,FORM) INT(MA(1)),INT(MA(-1)*MA(2)),(INT(MA(J)),J=3,N1) RETURN END SUBROUTINE FMNTRJ SUBROUTINE FMNTRR(NTR,X,KNAM) ! Internal routine for trace output of real variables. ! NTR - 1 for output values ! 2 for input values ! X - Double precision value to be printed if NX == 1 ! KNAM - Positive if the routine name is to be printed. USE FMVALS IMPLICIT NONE INTEGER NTR,KNAM DOUBLE PRECISION X CHARACTER(6) :: NAME IF (NTRACE == 0) RETURN IF (NCALL > LVLTRC) RETURN IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN IF (NTR == 2 .AND. KNAM > 0) THEN NAME = NAMEST(NCALL) WRITE (KW,"(' Input to ',A6)") NAME ENDIF IF (NTR == 1 .AND. KNAM > 0) THEN NAME = NAMEST(NCALL) IF (KFLAG == 0) THEN WRITE (KW, & "(' ',A6,15X,'Call level =',I2,5X,'MBASE ='," // & "I10,5X,'NDIG =',I6)" & ) NAME,NCALL,INT(MBASE),NDIG ELSE WRITE (KW, & "(' ',A6,6X,'Call level =',I2,4X,'MBASE ='," // & "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)" & ) NAME,NCALL,INT(MBASE),NDIG,KFLAG ENDIF ENDIF WRITE (KW,"(1X,D30.20)") X RETURN END SUBROUTINE FMNTRR SUBROUTINE FMOUT(MA,LINE,LB) ! Convert a floating multiple precision number to a character array ! for output. ! MA is an FM number to be converted to an A1 character ! array in base 10 format ! LINE is the CHARACTER*1 array in which the result is returned. ! LB is the length of LINE. ! JFORM1 and JFORM2 (in module FMVALS) determine the format of LINE. ! JFORM1 = 0 normal setting ( .314159M+6 ) ! = 1 1PE format ( 3.14159M+5 ) ! = 2 F format ( 314159.000 ) ! JFORM2 = number of significant digits to display (if JFORM1 = 0, 1) ! = number of digits after the decimal point (if JFORM1 = 2) ! If JFORM2 == 0 and JFORM1 /= 2 then a default number of ! digits is chosen. The default is roughly the full precision ! of MA. ! If JFORM2 == 0 and JFORM1 == 2 then the number is returned in ! integer format with no decimal point. Rounding is done as ! with other settings, so the value displayed is the nearest ! integer to MA. ! If JFORM1 == 2 and MA is too large or too small to display in the ! requested format, it is converted using JFORM1=0, JFORM2=0. ! LINE should be dimensioned at least LOG10(MBASE)*NDIG + 15 on a ! 32-bit machine to allow for up to 10 digit exponents. Replace ! 15 by 20 if 48-bit integers are used, 25 for 64-bit integers, .... USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER LB CHARACTER LINE(LB) CHARACTER KCHAR REAL (KIND(1.0D0)) :: M2,MBSAVE,MEXP,MEXP10,MKT,MNDGMS,MS1,MS2, & MSD2,MT10,MXSAVE INTEGER J,JDPT,JF1SAV,JF2SAV,K,K1,K2,KA,KASAVE,KB,KC,KDIGIT, & KEXP,KEXPSH,KMS2SD,KMT,KPT,KRSAVE,L,ND,NDE,NDE2,NDIGMS, & NDS2,NDSAVE,NPOWER,NSD1,NSD2,NVAL,NWORD,NWORD1,NWORD2 REAL X CHARACTER :: NUMB(10) = (/ '0','1','2','3','4','5','6','7','8','9' /) CHARACTER :: NUNKNO(12) = (/ & ' ',' ',' ','U','N','K','N','O','W','N',' ',' ' /) CHARACTER :: NEXPOV(12) = (/ & ' ',' ',' ','O','V','E','R','F','L','O','W',' ' /) CHARACTER :: NEXPUN(12) = (/ & ' ',' ',' ','U','N','D','E','R','F','L','O','W' /) ! To avoid recursion, FMOUT calls only internal arithmetic ! routines (FMADD2, FMMPY2, ...), so no trace printout is ! done during a call to FMOUT. KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMOUT ' ! Raise the call stack again, since the internal ! routines don't. NCALL = NCALL + 1 NAMEST(NCALL) = 'FMOUT ' DO J = 1, LB LINE(J) = ' ' ENDDO ! Check for special cases. IF (MA(1) == MUNKNO) THEN DO J = 1, 12 LINE(J) = NUNKNO(J) ENDDO NCALL = NCALL - 2 RETURN ENDIF IF (MA(1) == MEXPOV) THEN DO J = 1, 12 LINE(J) = NEXPOV(J) ENDDO LINE(2) = '+' IF (MA(-1) < 0) LINE(2) = '-' NCALL = NCALL - 2 RETURN ENDIF IF (MA(1) == MEXPUN) THEN DO J = 1, 12 LINE(J) = NEXPUN(J) ENDDO LINE(2) = '+' IF (MA(-1) < 0) LINE(2) = '-' NCALL = NCALL - 2 RETURN ENDIF IF (MA(2) == 0 .AND. JFORM1 == 2 .AND. JFORM2 == 0) THEN LINE(2) = '0' NCALL = NCALL - 2 RETURN ENDIF KASAVE = KACCSW KACCSW = 0 KRSAVE = KROUND KROUND = 1 JF1SAV = JFORM1 JF2SAV = JFORM2 MBSAVE = MBASE NDSAVE = NDIG MXSAVE = MXEXP ! ND is the number of base 10 digits required. 110 ND = JFORM2 IF (JFORM1 == 2 .AND. MA(1) > 0) ND = JFORM2 + & INT(REAL(MA(1))*LOG10(REAL(MBASE))) + 1 IF (ND <= 1) THEN K = INT(REAL(NDIG)*LOG10(REAL(MBASE))) ND = MAX(K,JFORM2) ENDIF IF (JFORM2 <= 0 .AND. JFORM1 <= 1) ND = & INT(1.1 + REAL(NDIG-1)*LOG10(REAL(MBASE))) IF (ND < 2) ND = 2 IF (LB < ND+6) THEN IF (JFORM1 == 2) THEN JFORM1 = 0 JFORM2 = 0 GO TO 110 ENDIF GO TO 170 ENDIF ! Convert to the base that is the largest power of 10 ! less than MXBASE and build the output number. NPOWER = INT(LOG10(REAL(MXBASE)/4)) MXEXP = MXEXP2 MBASE = 10**NPOWER IF (MBLOGS /= MBASE) CALL FMCONS NDIG = ND/NPOWER + 3 IF (NDIG < 2) NDIG = 2 IF (NDIG > NDG2MX) THEN KFLAG = -9 NCALL = NCALL - 1 CALL FMWARN NCALL = NCALL + 1 GO TO 170 ENDIF IF (MA(2) == 0) THEN CALL FMIM(0,MLV4) GO TO 130 ENDIF ! Check to see if MA is already in a base that is a ! power of ten. If so, the conversion can be skipped. K = NPOWER DO J = 1, K MBASE = 10**J IF (MBASE == MBSAVE) THEN IF (MBLOGS /= MBASE) CALL FMCONS NPOWER = J NDIG = ND/NPOWER + 2 IF (NDIG < 2) NDIG = 2 IF (NDIG > NDG2MX) THEN KFLAG = -9 NCALL = NCALL - 1 CALL FMWARN NCALL = NCALL + 1 GO TO 170 ENDIF CALL FMEQ2(MA,MLV4,NDSAVE,NDIG) MLV4(-1) = 1 GO TO 130 ENDIF ENDDO IF (MBLOGS /= MBASE) CALL FMCONS CALL FMIM(INT(MBSAVE),MLV2) NDS2 = NDSAVE + 1 CALL FMIM(1,MLV3) KMT = 1 ! Convert the fraction part of MA to the new base. KPT = NDS2 + 1 DO J = 3, NDS2 KPT = KPT - 1 IF (MA(KPT) /= 0) EXIT ENDDO KEXPSH = KPT - 1 KDIGIT = INT(ABS(MA(2))) CALL FMIM(KDIGIT,MLV4) NDIGMS = NDIG DO J = 3, KPT KDIGIT = INT(MA(J)) NDIG = MIN(NDIGMS,MAX(2,INT(MLV4(1)+MLV2(1)))) CALL FMMPY2_R1(MLV4,MLV2) IF (KDIGIT > 0) THEN IF (KMT /= KDIGIT) THEN NDIG = MIN(NDIGMS,MAX(2,INT(MLV2(1)))) CALL FMIM(KDIGIT,MLV3) KMT = KDIGIT ENDIF NDIG = MIN(NDIGMS,MAX(2,INT(MAX(MLV4(1),MLV3(1)))+1)) CALL FMADD2_R1(MLV4,MLV3) ENDIF ENDDO ! Convert the exponent. NDIG = NDIGMS CALL FMIM(1,MLV3) K = ABS(INT(MA(1))-KEXPSH) IF (MOD(K,2) == 1) THEN CALL FMEQ(MLV2,MLV3) ELSE CALL FMIM(1,MLV3) ENDIF 120 K = K/2 M2 = 2 MNDGMS = NDIGMS NDIG = INT(MIN(MNDGMS,MAX(M2,MLV2(1)*M2))) IF (K > 0) CALL FMSQR2_R1(MLV2) IF (MOD(K,2) == 1) THEN NDIG = INT(MIN(MNDGMS,MAX(M2,MLV3(1)+MLV2(1)))) CALL FMMPY2_R1(MLV3,MLV2) ENDIF IF (K > 1) GO TO 120 NDIG = NDIGMS IF (MA(1)-KEXPSH < 0) THEN CALL FMDIV2_R1(MLV4,MLV3) ELSE CALL FMMPY2_R1(MLV4,MLV3) ENDIF ! Now MLV4 is the value of MA converted to a ! power of ten base. ! Convert it to a character string base 10 for output. ! MEXP10 is the base 10 exponent. ! KMS2SD is the number of base 10 significant digits ! in MLV4(2). 130 MS1 = MLV4(1) 140 MEXP10 = NPOWER*MLV4(1) KMS2SD = NPOWER K = INT(MBASE) DO J = 1, NPOWER K = K/10 IF (MLV4(2) < K .AND. MLV4(2) /= 0) THEN MEXP10 = MEXP10 - 1 KMS2SD = KMS2SD - 1 ENDIF ENDDO ! For printing using JFORM1 = 1, reduce the exponent to ! account for the fact that the decimal point and first ! significant digit will later be swapped. IF (JFORM1 == 1 .AND. MLV4(2) /= 0) MEXP10 = MEXP10 - 1 ! Find the position in the unpacked number for rounding. ! NWORD is the word in which rounding is done, or zero if ! no rounding is necessary. ! NWORD is set to -1 if JFORM1 is 2 (F format) but no ! significant digits would be printed. This case ! defaults to JFORM1 = 0. ! NVAL gives the position within that word where rounding ! occurs. ! NSD1 is the maximum number of base 10 S.D.'s in NWORD ! digits of base 10**NPOWER. ! NSD2 is the number of base 10 S.D.'s needed to get ND ! base 10 digits after the decimal. NSD2 = ND IF (JFORM1 == 2) THEN MSD2 = JFORM2 + MEXP10 IF (MSD2 > ND) THEN NSD2 = ND ELSE NSD2 = INT(MSD2) ENDIF NWORD = (NSD2-KMS2SD-1+NPOWER)/NPOWER + 2 IF (NWORD < 2) NWORD = -1 IF (NWORD > NDIG) NWORD = 0 IF (NWORD >= 2 .AND. NSD2 <= 0) NWORD = -1 ELSE NWORD = (ND-KMS2SD-1+NPOWER)/NPOWER + 2 ENDIF NSD1 = KMS2SD + NPOWER*(NWORD-2) IF (NWORD < 2) THEN NVAL = 0 ELSE NVAL = 10**(NSD1-NSD2) ENDIF ! Now do the base 10 rounding. IF (NWORD >= 2) THEN X = 0.0 IF (NVAL > 1) X = MOD(INT(MLV4(NWORD)),NVAL) IF (NWORD < NDIG+1) THEN X = REAL(DBLE(X) + DBLE(MLV4(NWORD+1))/DBLE(MBASE)) ENDIF X = X/NVAL IF (X < 0.5) GO TO 150 MS2 = MLV4(2) MLV4(NWORD) = INT(MLV4(NWORD)/NVAL)*NVAL MLV4(NWORD+1) = 0 MLV4(NWORD+2) = 0 MLV4(NWORD) = MLV4(NWORD) + NVAL IF (MLV4(NWORD) >= MBASE) THEN NWORD1 = NWORD - 1 NWORD2 = NWORD - 2 IF (NWORD > 2) THEN CALL FMEQ2_R1(MLV4,NWORD1,NWORD2) ELSE MLV4(1) = MLV4(1) + 1 MLV4(2) = INT(MLV4(2)/MBASE) MLV4(3) = 0 ENDIF ENDIF IF (MLV4(1) /= MS1 .OR. MLV4(2) /= MS2) GO TO 140 ENDIF ! Build the base 10 character string. 150 IF (MA(-1) < 0) LINE(1) = '-' LINE(2) = '.' K = 10**KMS2SD L = 2 IF (NWORD == -1) NSD2 = ND DO J = 1, NSD2 K = K/10 IF (K == 0) THEN K = INT(MBASE)/10 L = L + 1 ENDIF KDIGIT = INT(MLV4(L))/K MLV4(L) = MOD(INT(MLV4(L)),K) LINE(J+2) = NUMB(KDIGIT+1) ENDDO KA = NSD2 + 3 KB = ND + 2 IF (KB >= KA) THEN DO J = KA, KB LINE(J) = NUMB(1) ENDDO ENDIF LINE(ND+3) = CMCHAR LINE(ND+4) = '+' IF (MEXP10 < 0) LINE(ND+4) = '-' IF (MA(2) == 0) LINE(ND+4) = ' ' ! Build the digits of the base 10 exponent backwards, ! then reverse them. NDE = 1 MEXP = ABS(MEXP10) MT10 = 10 DO J = 1, LB MKT = AINT (MEXP/MT10) KDIGIT = INT(MEXP-MKT*MT10) LINE(ND+4+J) = NUMB(KDIGIT+1) MEXP = MKT IF (MEXP == 0) EXIT IF (ND+5+J > LB) THEN DO K = 1, LB LINE(K) = '*' ENDDO GO TO 160 ENDIF NDE = NDE + 1 ENDDO NDE2 = NDE/2 IF (NDE2 < 1) GO TO 160 K1 = ND + 4 K2 = ND + 5 + NDE DO J = 1, NDE2 K1 = K1 + 1 K2 = K2 - 1 KCHAR = LINE(K1) LINE(K1) = LINE(K2) LINE(K2) = KCHAR ENDDO ! If JFORM1 is 1 put the first digit left of the decimal. 160 IF (JFORM1 == 1) THEN KCHAR = LINE(2) LINE(2) = LINE(3) LINE(3) = KCHAR ENDIF ! If JFORM1 is 2 put the number into fixed format. IF (JFORM1 == 2 .AND. JFORM2 >= 0) THEN IF (MEXP10 <= -JFORM2 .OR. MEXP10+2 > LB) THEN JFORM1 = 0 JFORM2 = 0 MBASE = MBSAVE IF (MBLOGS /= MBASE) CALL FMCONS NDIG = NDSAVE MXEXP = MXSAVE DO J = 1, LB LINE(J) = ' ' ENDDO GO TO 110 ENDIF KA = ND + 3 DO J = KA, LB LINE(J) = NUMB(1) ENDDO KEXP = INT(MEXP10) IF (MEXP10 > 0) THEN DO J = 1, KEXP LINE(J+1) = LINE(J+2) ENDDO LINE(KEXP+2) = '.' ENDIF IF (MEXP10 < 0) THEN KEXP = -INT(MEXP10) KA = 3 + KEXP KB = LB + 1 KC = KB - KEXP DO J = KA, LB KB = KB - 1 KC = KC - 1 LINE(KB) = LINE(KC) LINE(KC) = NUMB(1) ENDDO ENDIF JDPT = 0 DO J = 1, LB IF (LINE(J) == '.') JDPT = J IF (JDPT > 0 .AND. J > JDPT+JFORM2) LINE(J) = ' ' ENDDO IF (JFORM2 == 0 .AND. JDPT > 0) LINE(KEXP+2) = ' ' ENDIF ! Restore values and return GO TO 180 ! LINE is not big enough to hold the number ! of digits specified. 170 KFLAG = -8 DO J = 1, LB LINE(J) = '*' ENDDO NCALL = NCALL - 1 CALL FMWARN NCALL = NCALL + 1 180 MBASE = MBSAVE IF (MBLOGS /= MBASE) CALL FMCONS NDIG = NDSAVE MXEXP = MXSAVE NCALL = NCALL - 2 KACCSW = KASAVE KROUND = KRSAVE JFORM1 = JF1SAV JFORM2 = JF2SAV RETURN END SUBROUTINE FMOUT SUBROUTINE FMPACK(MA,MP) ! MA is packed two base NDIG digits per word and returned in MP. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MP(-1:LPACK) INTEGER J,KP KP = 2 MP(-1) = MA(-1) MP(0) = MA(0) MP(1) = MA(1) MP(2) = ABS(MA(2))*MBASE + MA(3) IF (NDIG >= 4) THEN DO J = 4, NDIG, 2 KP = KP + 1 MP(KP) = MA(J)*MBASE + MA(J+1) ENDDO ENDIF IF (MOD(NDIG,2) == 1) MP(KP+1) = MA(NDIG+1)*MBASE RETURN END SUBROUTINE FMPACK SUBROUTINE FMPI(MA) ! MA = pi USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) CHARACTER(155) :: STRING INTEGER K,KASAVE,NDMB,NDSAVE,NDSV IF (MBLOGS /= MBASE) CALL FMCONS KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMPI ' IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN WRITE (KW,"(' Input to FMPI')") ENDIF KASAVE = KACCSW KACCSW = 0 ! Increase the working precision. NDSAVE = NDIG IF (NCALL == 1) THEN K = NGRD52 NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MA) GO TO 110 ENDIF ENDIF ! Check to see if pi has previously been computed ! in base MBASE with sufficient precision. IF (MBSPI == MBASE .AND. NDIGPI >= NDIG) THEN IF (NAMEST(NCALL-1) /= 'NOEQ ') THEN KACCSW = KASAVE CALL FMEQ2(MPISAV,MA,NDIGPI,NDSAVE) ENDIF ELSE NDMB = INT(150.0*2.302585/ALOGMB) IF (NDMB >= NDIG) THEN NDSV = NDIG NDIG = MIN(NDMB,NDG2MX) STRING = '3.141592653589793238462643383279502884197169'// & '39937510582097494459230781640628620899862803482534211'// & '7067982148086513282306647093844609550582231725359408128' CALL FMST2M(STRING,MPISAV) MPISAV(0) = NINT(NDIG*ALOGM2) MBSPI = MBASE NDIGPI = NDIG IF (ABS(MPISAV(1)) > 10) NDIGPI = 0 ELSE NDSV = NDIG NDIG = MIN(NDIG+2,NDG2MX) CALL FMPI2(MPISAV) MPISAV(0) = NINT(NDIG*ALOGM2) MBSPI = MBASE NDIGPI = NDIG IF (ABS(MPISAV(1)) > 10) NDIGPI = 0 ENDIF IF (NAMEST(NCALL-1) /= 'NOEQ ') THEN KACCSW = KASAVE CALL FMEQ2(MPISAV,MA,NDIG,NDSAVE) ENDIF NDIG = NDSV ENDIF 110 NDIG = NDSAVE KACCSW = KASAVE IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMPI SUBROUTINE FMPI2(MPI) ! Internal routine to compute pi. ! The formula used is due to S. Ramanujan: ! (4n)!(1103+26390n) ! 1/pi = (sqrt(8)/9801) * sum(n=0 to infinity) -------------------- ! ((n!)**4)(396**(4n)) ! The result is returned in MPI. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MPI(-1:LUNPCK) DOUBLE PRECISION X REAL (KIND(1.0D0)) :: MX INTEGER NSTACK(19),J,K,KST,LARGE,N,NDIGRD,NDSAVE IF (MBLOGS /= MBASE) CALL FMCONS NDSAVE = NDIG N = -1 CALL FMI2M(1103,MPI) CALL FMI2M(1,M02) CALL FMI2M(26390,M03) CALL FMI2M(1103,M04) MX = MXBASE**2/MBASE IF (MX > MXEXP2) MX = MXEXP2 110 N = N + 1 LARGE = INT(MX)/(4*N + 3) J = 4*N + 1 IF (J > LARGE) THEN CALL FMMPYI_R1(M02,J) J = J + 1 CALL FMMPYI_R1(M02,J) J = J + 1 CALL FMMPYI_R1(M02,J) ELSE IF (J*(J+1) > LARGE) THEN K = J*(J+1) CALL FMMPYI_R1(M02,K) J = J + 2 CALL FMMPYI_R1(M02,J) ELSE K = J*(J+1)*(J+2) CALL FMMPYI_R1(M02,K) ENDIF J = N + 1 LARGE = INT(MXBASE)/J IF (J > LARGE) THEN CALL FMDIVI_R1(M02,J) CALL FMDIVI_R1(M02,J) CALL FMDIVI_R1(M02,J) ELSE IF (J*J > LARGE) THEN K = J*J CALL FMDIVI_R1(M02,K) CALL FMDIVI_R1(M02,J) ELSE K = J*J*J CALL FMDIVI_R1(M02,K) ENDIF ! Break 4/396**4 into 1/(2178*2178*1296). J = 2178 LARGE = INT(MXBASE)/J IF (J > LARGE) THEN CALL FMDIVI_R1(M02,J) CALL FMDIVI_R1(M02,J) CALL FMDIVI_R1(M02,1296) ELSE K = J*J CALL FMDIVI_R1(M02,K) CALL FMDIVI_R1(M02,1296) ENDIF NDIGRD = NDIG NDIG = NDSAVE CALL FMADD_R2(M03,M04) NDIG = NDIGRD CALL FMMPY(M02,M04,M01) NDIG = NDSAVE CALL FMADD_R1(MPI,M01) NDIG = MAX(2,NDSAVE - INT(MPI(1) - M01(1))) IF (KFLAG /= 1) GO TO 110 NDIG = NDSAVE CALL FMI2M(8,M02) X = 8 X = SQRT(X) CALL FMDPM(X,M04) CALL FMDIG(NSTACK,KST) DO J = 1, KST NDIG = NSTACK(J) CALL FMDIV(M02,M04,M01) CALL FMADD_R1(M04,M01) CALL FMDIVI_R1(M04,2) ENDDO M04(0) = NINT(NDIG*ALOGM2) CALL FMI2M(9801,M03) CALL FMMPY_R1(MPI,M04) CALL FMDIV_R2(M03,MPI) RETURN END SUBROUTINE FMPI2 SUBROUTINE FMPRNT(MA) ! Print MA in base 10 format. ! FMPRNT can be called directly by the user for easy output ! in M format. MA is converted using FMOUT and printed. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) CHARACTER(20) :: FORM INTEGER J,K,KSAVE,L,LAST,LB,ND,NEXP NCALL = NCALL + 1 NAMEST(NCALL) = 'FMPRNT' KSAVE = KFLAG ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1 IF (ND < 2) ND = 2 NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6 LB = MAX(JFORM2+NEXP,ND+NEXP) LB = MIN(LB,LMBUFF) CALL FMOUT(MA,CMBUFF,LB) KFLAG = KSAVE LAST = LB + 1 WRITE (FORM,"(' (6X,',I3,'A1) ')") KSWIDE-7 DO J = 1, LB IF (CMBUFF(LAST-J) /= ' ' .OR. J == LB) THEN L = LAST - J WRITE (KW,FORM) (CMBUFF(K),K=1,L) NCALL = NCALL - 1 RETURN ENDIF ENDDO NCALL = NCALL - 1 RETURN END SUBROUTINE FMPRNT SUBROUTINE FMPWR(MA,MB,MC) ! MC = MA ** MB ! If MB can be expressed exactly as a one word integer, then FMIPWR is ! used. This is much faster when MB is small, and using FMIPWR allows ! MA to be negative. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MXSAVE INTEGER IEXTRA,INTMB,J,K,KASAVE,KFL,KOVUN,KRESLT,KWRNSV,NDSAVE ! Convert MB to an integer before changing NDIG. KWRNSV = KWARN KWARN = 0 CALL FMMI(MB,INTMB) KWARN = KWRNSV KFL = KFLAG IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. & MA(2) == 0 .OR. MA(-1) < 0) THEN CALL FMENTR('FMPWR ',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMPWR ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MB,MC,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF ! If the exponent is large or the base is very large, ! raise the precision. IF (MA(1) /= 0) THEN IEXTRA = MAX(0,INT(MB(1)))+INT(LOG(ABS(REAL(MA(1))))/ALOGMB) ELSE IEXTRA = MAX(0,INT(MB(1))) ENDIF IF (MB(1)-NDIG > LOG(ALOGMB*REAL(MXEXP2))) THEN IEXTRA = 0 ENDIF NDIG = NDIG + IEXTRA IF (NDIG > NDG2MX) THEN IF (NCALL == 1) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MC) DO J = -1, NDIG+1 M01(J) = MC(J) ENDDO CALL FMEXIT(M01,MC,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN ELSE NDIG = NDG2MX ENDIF ENDIF IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10)) ENDIF ! If the exponent is a small integer, call FMIPWR. KWRNSV = KWARN KWARN = 0 MACCA = MA(0) MACCB = NINT(NDIG*ALOGM2) CALL FMEQ2(MA,M06,NDSAVE,NDIG) M06(0) = NINT(NDIG*ALOGM2) IF (KFL == 0) THEN CALL FMIPWR(M06,INTMB,MC) ELSE IF (M06(2) == 0 .OR. M06(-1) < 0) THEN CALL FMST2M('UNKNOWN',MC) KFLAG = -4 ELSE CALL FMLN(M06,M13) CALL FMEQ(M13,M06) MACCB = MB(0) CALL FMEQ2(MB,M02,NDSAVE,NDIG) M02(0) = NINT(NDIG*ALOGM2) CALL FMMPY_R1(M06,M02) CALL FMEXP(M06,MC) ENDIF KWARN = KWRNSV ! Round the result and return. MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315) MC(0) = MIN(MC(0),MACCA,MACCB,MACMAX) DO J = -1, NDIG+1 M01(J) = MC(J) ENDDO CALL FMEXIT(M01,MC,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMPWR SUBROUTINE FM_RANDOM_NUMBER(VALUE) ! FM_RANDOM_NUMBER generates pseudo-random numbers uniform on (0,1). ! VALUE is returned as the next random (double precision) number. ! Neither zero nor one will be returned in VALUE. ! This version uses the FM package to implement a multiplicative congruential ! generator. Both the modulus and the multiplier are 49-digit primes, and ! the period is over 1.0E+49. This generator passes the spectral test, with ! mu(2), ..., mu(6) = 3.40, 4.35, 3.98, 3.19, 3.20. ! Then the numbers are shuffled before returning them to the calling program. ! See the discussion of Bays and Durham shuffling in Knuth, V. 2. ! Both the basic multiplicative congruential generator and the shuffled ! version have passed Marsaglia's DieHard test suite for generators. ! The typical usage is to call FM_RANDOM_SEED once with PUT defined as an ! integer array of length 7 containing seven seed values used to initialize ! the generator. This initializes the table used by the mixed congruential ! generator. Then each call to FM_RANDOM_NUMBER gets the next random value. ! The calling program must USE FMZM to call FM_RANDOM_SEED. FM_RANDOM_NUMBER ! can be used with a default seed without any calls to FM_RANDOM_SEED. ! This example seeds the generator and then fills the array R with random ! values between 0 and 1. ! SEED = (/ 314159,265358,979323,846264,338327,950288,419716 /) ! CALL FM_RANDOM_SEED(PUT=SEED) ! DO J = 1, N ! CALL FM_RANDOM_NUMBER(R(J)) ! ENDDO ! In a GET= call, the seed array is returned that would later restart the ! multiplicative congruential generator in FM_RANDOM_NUMBER at the same place ! in the sequence, but since the table used to shuffle the output values is ! not saved in a GET= call, the sequence may not repeat exactly. ! SEED = (/ 314159,265358,979323,846264,338327,950288,419716 /) ! CALL FM_RANDOM_SEED(PUT=SEED) ! DO J = 1, 100 ! CALL FM_RANDOM_NUMBER(R(J)) ! ENDDO ! CALL FM_RANDOM_SEED(GET=SEED) ! DO J = 101, 200 ! CALL FM_RANDOM_NUMBER(R(J)) ! ENDDO ! CALL FM_RANDOM_SEED(PUT=SEED) ! DO J = 201, 300 ! CALL FM_RANDOM_NUMBER(R(J)) ! ENDDO ! CALL FM_RANDOM_SEED(PUT=SEED) ! DO J = 301, 400 ! CALL FM_RANDOM_NUMBER(R(J)) ! ENDDO ! Here the seed is saved after 100 calls. The seed is used to re-set the ! generator after 200 calls to the same state it had after 100 calls, but ! R(201), ..., R(300) is not the same sequence as R(101), ..., R(200) ! because the shuffling is different. ! However, re-setting again after 300 calls will reinitialize the shuffling ! the same way as after 200 calls, so R(301), ..., R(400) is exactly the ! same sequence as R(201), ..., R(300). USE FMVALS USE FMZM IMPLICIT NONE DOUBLE PRECISION VALUE,DPM,DPX,Y SAVE DPM,Y INTEGER POS_OF_LAST_DIGIT,J,JBASE,LAST_DIGIT_OF_X,LAST_DIGIT_OF_M_M1 INTEGER :: SEED(7) = (/314159,265358,979323,846264,338327,950288,419716/) SAVE JBASE,LAST_DIGIT_OF_M_M1,SEED DOUBLE PRECISION :: MSAVE LOGICAL IMCOMP ! Keep a table of recently generated numbers and shuffle the ! order before returning them. INTEGER, PARAMETER :: TABLE_SIZE = 100 DOUBLE PRECISION, SAVE :: TABLE(0:TABLE_SIZE-1) MSAVE = MBASE MBASE = MBRAND ! START_RANDOM_SEQUENCE = 0 for normal operation. ! Get the next random value. ! = 1 for an initializing call after ! the user has called FM_RANDOM_SEED. ! Use that value in MRNX to initialize. ! = -1 for the first user call if there ! was no initializing call to ! FM_RANDOM_SEED. Use a default ! seed to initialize MRNX. IF (START_RANDOM_SEQUENCE /= 0) THEN IF (START_RANDOM_SEQUENCE == -1) THEN CALL FM_RANDOM_SEED(PUT=SEED) ENDIF START_RANDOM_SEQUENCE = 0 CALL IMST2M('1424133622579837639401183671018194926834820238197',MRNA) CALL IMST2M('2070613773952029032014000773560846464373793273739',MRNM) LAST_DIGIT_OF_M_M1 = INT(MRNM(INT(MRNM(1))+1)) - 1 JBASE = INT(MBASE) - 1 CALL IMI2M(1,MRNC) CALL IMM2DP(MRNM,DPM) DPM = 1.0D0/DPM DO J = 0, TABLE_SIZE-1 110 CALL IMMPYM(MRNA,MRNX,MRNM,M13) CALL IMADD(M13,MRNC,M10) CALL IMMOD(M10,MRNM,MRNX) CALL IMM2DP(MRNX,DPX) VALUE = DPX*DPM IF (VALUE >= 1.0D0 .OR. VALUE <= 0.0D0) GO TO 110 TABLE(J) = VALUE ENDDO CALL IMMPYM(MRNA,MRNX,MRNM,M13) CALL IMADD(M13,MRNC,M10) CALL IMMOD(M10,MRNM,MRNX) CALL IMM2DP(MRNX,DPX) Y = DPX*DPM ENDIF ! Get the next number in the sequence. 120 CALL IMMPYM(MRNA,MRNX,MRNM,M13) POS_OF_LAST_DIGIT = INT(MRNX(1)) + 1 DO J = -1, POS_OF_LAST_DIGIT MRNX(J) = M13(J) ENDDO LAST_DIGIT_OF_X = INT(MRNX(POS_OF_LAST_DIGIT)) IF (LAST_DIGIT_OF_X == LAST_DIGIT_OF_M_M1) THEN CALL IMADD(MRNX,MRNC,M10) CALL IMEQ(M10,MRNX) IF (IMCOMP(MRNX,'GE',MRNM)) THEN CALL IMSUB(MRNX,MRNM,M10) CALL IMEQ(M10,MRNX) ENDIF ELSE IF (LAST_DIGIT_OF_X < JBASE) THEN MRNX(POS_OF_LAST_DIGIT) = MRNX(POS_OF_LAST_DIGIT) + 1 ELSE CALL IMADD(MRNX,MRNC,M10) CALL IMEQ(M10,MRNX) ENDIF ! Convert to double precision. DPX = MRNX(2) DO J = 3, POS_OF_LAST_DIGIT DPX = MBASE*DPX + MRNX(J) ENDDO DPX = DPX*DPM IF (DPX >= 1.0D0 .OR. DPX <= 0.0D0) GO TO 120 ! Shuffling. J = Y*TABLE_SIZE Y = TABLE(J) VALUE = Y TABLE(J) = DPX MBASE = MSAVE RETURN END SUBROUTINE FM_RANDOM_NUMBER SUBROUTINE FMRDC(MA,JSIN,JCOS,JSWAP) ! Reduce MA using various trigonometric identities to an equivalent ! angle between 0 and 45 degrees. The reduction is done in radians ! if KRAD (in module FMVALS) is 1, in degrees if KRAD is 0. ! JSIN and JCOS are returned +1 or -1 and JSWAP is returned to indicate ! that the sin and cos functions have been interchanged as follows: ! JSWAP = 0 means SIN(MA) = JSIN*SIN(returned value of MA) ! COS(MA) = JCOS*COS(returned value of MA) ! JSWAP = 1 means SIN(MA) = JSIN*COS(returned value of MA) ! COS(MA) = JCOS*SIN(returned value of MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER JSIN,JCOS,JSWAP REAL (KIND(1.0D0)) :: MA0 DOUBLE PRECISION X INTEGER J,KASAVE,NDSAVE,NDSV LOGICAL FMCOMP IF (MBLOGS /= MBASE) CALL FMCONS JSIN = 1 JCOS = 1 JSWAP = 0 NDSAVE = NDIG NDIG = NDIG + MAX(0,INT(MA(1))) ! If the argument is too big, return UNKNOWN. IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MA) RETURN ENDIF MA0 = MA(0) + NINT(ALOGM2*REAL(MAX(0,INT(MA(1))))) ! If MA is less than 1/MBASE, no reduction is needed. IF (MA(1) < 0) THEN NDIG = NDSAVE IF (MA(-1) < 0) THEN MA(-1) = 1 JSIN = -1 ENDIF RETURN ENDIF J = 1 IF (KRAD == 1) THEN 110 IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN NDSV = NDIG NDIG = MIN(NDIG+2,NDG2MX) KASAVE = KACCSW KACCSW = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'NOEQ ' CALL FMPI(MPISAV) NCALL = NCALL - 1 KACCSW = KASAVE NDIG = NDSV ENDIF CALL FMEQ2(MA,M04,NDSAVE,NDIG) M04(0) = MA0 IF (MA(-1) < 0) JSIN = -1 M04(-1) = 1 IF (M04(1) == 0) THEN CALL FMM2DP(M04,X) IF (X <= 0.75) THEN NDIG = NDSAVE CALL FMEQ(M04,MA) RETURN ENDIF ENDIF CALL FMADD(MPISAV,MPISAV,M02) IF (FMCOMP(M04,'GE',M02)) THEN CALL FMDIV(M04,M02,M01) CALL FMINT(M01,M08) CALL FMEQ(M08,M01) CALL FMMPY_R1(M01,M02) CALL FMSUB_R1(M04,M01) ENDIF CALL FMEQ(MPISAV,M03) IF (FMCOMP(M04,'GE',M03)) THEN JSIN = -JSIN CALL FMSUB_R2(M02,M04) ENDIF CALL FMDIVI_R1(M02,4) IF (FMCOMP(M04,'GE',M02)) THEN JCOS = -JCOS CALL FMSUB_R2(M03,M04) ENDIF CALL FMDIVI_R1(M03,4) IF (FMCOMP(M04,'GE',M03)) THEN JSWAP = 1 CALL FMSUB_R2(M02,M04) ENDIF ! If the reduced argument is close to zero, then ! cancellation has produced an inaccurate value. ! Raise NDIG and do the reduction again. IF (J == 1 .AND. (M04(1) < 0 .OR. M04(2) == 0)) THEN J = 2 IF (M04(2) == 0) THEN NDIG = MIN(2*NDIG,NDG2MX) ELSE NDIG = NDIG - INT(M04(1)) ENDIF IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MA) RETURN ENDIF JSIN = 1 JCOS = 1 JSWAP = 0 MA0 = MA(0) + NINT(ALOGM2*REAL(-M04(1))) GO TO 110 ENDIF ELSE CALL FMEQ2(MA,M04,NDSAVE,NDIG) M04(0) = MA0 IF (MA(-1) < 0) JSIN = -1 M04(-1) = 1 IF (M04(1) == 0) THEN CALL FMM2DP(M04,X) IF (X <= 44.0) THEN NDIG = NDSAVE CALL FMEQ(M04,MA) RETURN ENDIF ENDIF CALL FMI2M(360,M02) IF (FMCOMP(M04,'GE',M02)) THEN CALL FMDIV(M04,M02,M01) CALL FMINT(M01,M08) CALL FMEQ(M08,M01) CALL FMMPY_R1(M01,M02) CALL FMSUB_R1(M04,M01) ENDIF CALL FMI2M(180,M03) IF (FMCOMP(M04,'GE',M03)) THEN JSIN = -JSIN CALL FMSUB_R2(M02,M04) ENDIF CALL FMI2M(90,M02) IF (FMCOMP(M04,'GE',M02)) THEN JCOS = -JCOS CALL FMSUB_R2(M03,M04) ENDIF CALL FMI2M(45,M03) IF (FMCOMP(M04,'GE',M03)) THEN JSWAP = 1 CALL FMSUB_R2(M02,M04) ENDIF ENDIF ! Round the result and return. CALL FMEQ2(M04,MA,NDIG,NDSAVE) NDIG = NDSAVE RETURN END SUBROUTINE FMRDC SUBROUTINE FMREAD(KREAD,MA) ! Read MA on unit KREAD. Multi-line numbers will have '&' as the ! last nonblank character on all but the last line. Only one ! number is allowed on the line(s). USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER KREAD CHARACTER LINE(80) INTEGER J,LB,NDSAVE IF (MBLOGS /= MBASE) CALL FMCONS NCALL = NCALL + 1 NAMEST(NCALL) = 'FMREAD' NDSAVE = NDIG NDIG = MIN(NDG2MX,MAX(NDIG+NGRD52,2)) LB = 0 110 READ (KREAD,"(80A1)",ERR=120,END=120) LINE ! Scan the line and look for '&' DO J = 1, 80 IF (LINE(J) == '&') GO TO 110 IF (LINE(J) /= ' ') THEN LB = LB + 1 IF (LB > LMBUFF) THEN KFLAG = -8 GO TO 130 ENDIF CMBUFF(LB) = LINE(J) ENDIF ENDDO CALL FMINP(CMBUFF,M01,1,LB) CALL FMEQ2(M01,MA,NDIG,NDSAVE) NDIG = NDSAVE NCALL = NCALL - 1 RETURN ! If there is an error, return UNKNOWN. 120 KFLAG = -4 130 CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MA) NCALL = NCALL - 1 RETURN END SUBROUTINE FMREAD SUBROUTINE FMRND(MW,ND,NGUARD,KSHIFT) ! Round MW to ND digits (base MBASE). ! MW is non-negative and has ND+NGUARD+KSHIFT digits. ! NGUARD is the number of guard digits carried. ! KSHIFT is 1 if a left shift is pending when MW(2)=0. ! Round to position MW(ND+1+KSHIFT) using the guard digits ! MW(ND+2+KSHIFT), ..., MW(ND+1+NGUARD+KSHIFT). ! This routine is designed to be called only from within the FM ! package. The user should call FMEQU to round numbers. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MW(LMWA) INTEGER ND,NGUARD,KSHIFT REAL (KIND(1.0D0)) :: M2,MFACTR,MKT INTEGER J,K,KB,L IF (KROUND == -1 .AND. NCALL <= 1) THEN IF (JRSIGN == 1) RETURN DO J = ND+2+KSHIFT, ND+1+NGUARD+KSHIFT IF (MW(J) > 0) THEN MW(ND+1+KSHIFT) = MW(ND+1+KSHIFT) + 1 MW(ND+2+KSHIFT) = 0 IF (MW(ND+1+KSHIFT) < MBASE) RETURN L = ND + 2 + KSHIFT GO TO 120 ENDIF ENDDO RETURN ENDIF IF (KROUND == 2 .AND. NCALL <= 1) THEN IF (JRSIGN == -1) RETURN DO J = ND+2+KSHIFT, ND+1+NGUARD+KSHIFT IF (MW(J) > 0) THEN MW(ND+1+KSHIFT) = MW(ND+1+KSHIFT) + 1 MW(ND+2+KSHIFT) = 0 IF (MW(ND+1+KSHIFT) < MBASE) RETURN L = ND + 2 + KSHIFT GO TO 120 ENDIF ENDDO RETURN ENDIF IF (KROUND == 0 .AND. NCALL <= 1) RETURN L = ND + 2 + KSHIFT IF (2*(MW(L)+1) < MBASE) RETURN IF (2*MW(L) > MBASE) THEN MW(L-1) = MW(L-1) + 1 MW(L) = 0 IF (MW(L-1) < MBASE) RETURN GO TO 120 ENDIF ! If the first guard digit gives a value close to 1/2 then ! further guard digits must be examined. M2 = 2 IF (INT(MBASE-AINT (MBASE/M2)*M2) == 0) THEN IF (2*MW(L) < MBASE) RETURN IF (2*MW(L) == MBASE) THEN IF (NGUARD >= 2) THEN IF (MBASE >= 1000) THEN IF (MBASE < 1000000) THEN MFACTR = INT(0.5D0+0.6883D0*MBASE) ELSE MFACTR = INT(0.5D0+0.687783D0*MBASE) ENDIF IF (MW(L+1) == MFACTR) RETURN ENDIF DO J = 2, NGUARD IF (MW(L+J-1) > 0) GO TO 110 ENDDO ENDIF ! Round to even. IF (INT(MW(L-1)-AINT (MW(L-1)/M2)*M2) == 0) RETURN ENDIF ELSE IF (2*MW(L)+1 == MBASE) THEN IF (NGUARD >= 2) THEN DO J = 2, NGUARD IF (2*(MW(L+J-1)+1) < MBASE) RETURN IF (2*MW(L+J-1) > MBASE) GO TO 110 ENDDO IF (NGUARD <= NDIG) RETURN M2 = 2 IF (INT(MW(L-1)-AINT (MW(L-1)/M2)*M2) == 0) THEN RETURN ELSE GO TO 110 ENDIF ENDIF ENDIF ENDIF 110 MW(L-1) = MW(L-1) + 1 MW(L) = 0 ! Check whether there was a carry in the rounded digit. 120 KB = L - 1 IF (KB >= 3) THEN K = KB + 1 DO J = 3, KB K = K - 1 IF (MW(K) < MBASE) RETURN MKT = AINT (MW(K)/MBASE) MW(K-1) = MW(K-1) + MKT MW(K) = MW(K) - MKT*MBASE ENDDO ENDIF ! If there is a carry in the first digit then the exponent ! must be adjusted and the number shifted right. IF (MW(2) >= MBASE) THEN IF (KB >= 4) THEN K = KB + 1 DO J = 4, KB K = K - 1 MW(K) = MW(K-1) ENDDO ENDIF MKT = AINT (MW(2)/MBASE) IF (KB >= 3) MW(3) = MW(2) - MKT*MBASE MW(2) = MKT MW(1) = MW(1) + 1 ENDIF RETURN END SUBROUTINE FMRND SUBROUTINE FMRPWR(MA,IVAL,JVAL,MB) ! MB = MA ** (IVAL/JVAL) rational exponentiation. ! This routine is faster than FMPWR when IVAL and JVAL are ! small integers. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER IVAL,JVAL DOUBLE PRECISION X,F REAL (KIND(1.0D0)) :: MA1,MA2,MAS,MACCA,MACMAX,MXSAVE INTEGER NSTACK(19),IJSIGN,INVERT,IVAL2,J,JVAL2,K,KASAVE,KOVUN, & KRESLT,KST,KWRNSV,L,LVAL,NDSAVE REAL XVAL IF (MBLOGS /= MBASE) CALL FMCONS NCALL = NCALL + 1 NAMEST(NCALL) = 'FMRPWR' IF (NTRACE /= 0) THEN CALL FMNTR(2,MA,MA,1,1) CALL FMNTRI(2,IVAL,0) CALL FMNTRI(2,JVAL,0) ENDIF KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN XVAL = MAX(ABS(IVAL),ABS(JVAL)) IF (XVAL == 0.0) XVAL = 1.0 K = INT((5.0*REAL(DLOGTN) + 2.0*LOG(XVAL))/ALOGMB + 2.0) NDIG = MAX(NDIG+K,2) IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10)) ENDIF ELSE XVAL = MAX(ABS(IVAL),ABS(JVAL)) IF (XVAL == 0.0) XVAL = 1.0 K = INT(LOG(XVAL)/ALOGMB + 1.0) NDIG = NDIG + K ENDIF IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 MAS = MA(-1) MA1 = MA(1) MA2 = MA(2) MACCA = MA(0) CALL FMEQ2(MA,M02,NDSAVE,NDIG) M02(0) = NINT(NDIG*ALOGM2) ! Use GCD-reduced positive exponents. IJSIGN = 1 IVAL2 = ABS(IVAL) JVAL2 = ABS(JVAL) IF (IVAL > 0 .AND. JVAL < 0) IJSIGN = -1 IF (IVAL < 0 .AND. JVAL > 0) IJSIGN = -1 IF (IVAL2 > 0 .AND. JVAL2 > 0) CALL FMGCDI(IVAL2,JVAL2) ! Check for special cases. 110 IF (MA1 == MUNKNO .OR. JVAL2 == 0 .OR. & (IJSIGN <= 0 .AND. MA2 == 0)) THEN CALL FMST2M('UNKNOWN',MB) KFLAG = -4 GO TO 120 ENDIF IF (IVAL2 == 0) THEN CALL FMIM(1,MB) GO TO 120 ENDIF IF (JVAL2 == 1) THEN CALL FMIPWR(M02,IJSIGN*IVAL2,MB) GO TO 120 ENDIF IF (MA2 == 0) THEN CALL FMEQ(MA,MB) GO TO 120 ENDIF IF (MAS < 0) THEN IF (MOD(JVAL2,2) == 0) THEN JVAL2 = 0 GO TO 110 ENDIF ENDIF IF (MA1 == MEXPOV) THEN IF (IVAL2 < JVAL2) THEN JVAL2 = 0 GO TO 110 ENDIF CALL FMIM(0,MB) IF (IJSIGN == 1 .AND. MAS > 0) THEN CALL FMST2M('OVERFLOW',MB) KFLAG = -5 ELSE IF (IJSIGN == -1 .AND. MAS > 0) THEN CALL FMST2M('UNDERFLOW',MB) KFLAG = -6 ELSE IF (IJSIGN == 1 .AND. MAS < 0) THEN IF (MOD(IVAL2,2) == 0) THEN CALL FMST2M('OVERFLOW',MB) KFLAG = -5 ELSE CALL FMST2M('-OVERFLOW',MB) KFLAG = -5 ENDIF ELSE IF (IJSIGN == -1 .AND. MAS < 0) THEN IF (MOD(IVAL2,2) == 0) THEN CALL FMST2M('UNDERFLOW',MB) KFLAG = -6 ELSE CALL FMST2M('-UNDERFLOW',MB) KFLAG = -6 ENDIF ENDIF GO TO 120 ENDIF IF (MA1 == MEXPUN) THEN IF (IVAL2 < JVAL2) THEN JVAL2 = 0 GO TO 110 ENDIF CALL FMIM(0,MB) IF (IJSIGN == 1 .AND. MAS > 0) THEN CALL FMST2M('UNDERFLOW',MB) KFLAG = -6 ELSE IF (IJSIGN == -1 .AND. MAS > 0) THEN CALL FMST2M('OVERFLOW',MB) KFLAG = -5 ELSE IF (IJSIGN == 1 .AND. MAS < 0) THEN IF (MOD(IVAL2,2) == 0) THEN CALL FMST2M('UNDERFLOW',MB) KFLAG = -6 ELSE CALL FMST2M('-UNDERFLOW',MB) KFLAG = -6 ENDIF ELSE IF (IJSIGN == -1 .AND. MAS < 0) THEN IF (MOD(IVAL2,2) == 0) THEN CALL FMST2M('OVERFLOW',MB) KFLAG = -5 ELSE CALL FMST2M('-OVERFLOW',MB) KFLAG = -5 ENDIF ENDIF GO TO 120 ENDIF ! Invert MA if MA > 1 and IVAL or JVAL is large. INVERT = 0 IF (MA(1) > 0) THEN IF (IVAL > 5 .OR. JVAL > 5) THEN INVERT = 1 CALL FMI2M(1,M01) CALL FMDIV_R2(M01,M02) ENDIF ENDIF ! Generate the first approximation to ABS(MA)**(1/JVAL2). MA1 = M02(1) M02(1) = 0 M02(-1) = 1 CALL FMM2DP(M02,X) L = INT(MA1/JVAL2) F = MA1/DBLE(JVAL2) - L X = X**(1.0D0/JVAL2) * DBLE(MBASE)**F CALL FMDPM(X,MB) MB(1) = MB(1) + L M02(1) = MA1 ! Initialize. CALL FMDIG(NSTACK,KST) ! Newton iteration. DO J = 1, KST NDIG = NSTACK(J) IF (J < KST) NDIG = NDIG + 1 LVAL = JVAL2 - 1 CALL FMIPWR(MB,LVAL,M03) CALL FMDIV_R2(M02,M03) CALL FMMPYI_R1(MB,LVAL) CALL FMADD_R1(MB,M03) CALL FMDIVI_R1(MB,JVAL2) ENDDO IF (MB(1) /= MUNKNO .AND. MB(2) /= 0 .AND. MAS < 0) MB(-1) = -MB(-1) CALL FMIPWR(MB,IJSIGN*IVAL2,M03) CALL FMEQ(M03,MB) IF (INVERT == 1) THEN CALL FMI2M(1,M01) CALL FMDIV_R2(M01,MB) ENDIF ! Round the result and return. 120 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MACCA,MACMAX) KWRNSV = KWARN IF (MA1 == MUNKNO) KWARN = 0 DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) KWARN = KWRNSV RETURN END SUBROUTINE FMRPWR SUBROUTINE FMRSLT(MA,MB,MC,KRESLT) ! Handle results that are special cases, such as overflow, ! underflow, and unknown. ! MA and MB are the input arguments to an FM subroutine. ! MC is the result that is returned. ! KRESLT is the result code from FMARGS. Result codes handled here: ! 0 - Perform the normal operation ! 1 - The result is the first input argument ! 2 - The result is the second input argument ! 3 - The result is -OVERFLOW ! 4 - The result is +OVERFLOW ! 5 - The result is -UNDERFLOW ! 6 - The result is +UNDERFLOW ! 7 - The result is -1.0 ! 8 - The result is +1.0 ! 11 - The result is 0.0 ! 12 - The result is UNKNOWN USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) INTEGER KRESLT REAL (KIND(1.0D0)) :: MACCAB,MACCSV INTEGER KFSAVE KFSAVE = KFLAG MACCAB = MIN(MA(0),MB(0)) IF (KRESLT == 1) THEN MACCSV = MA(0) CALL FMEQ(MA,MC) MC(0) = MACCAB IF (NAMEST(NCALL) == 'FMADD ' .OR. & NAMEST(NCALL) == 'FMSUB ') THEN KFLAG = 1 MC(0) = MACCSV ELSE KFLAG = KFSAVE ENDIF RETURN ENDIF IF (KRESLT == 2) THEN MACCSV = MB(0) CALL FMEQ(MB,MC) MC(0) = MACCAB IF (NAMEST(NCALL) == 'FMADD ') THEN KFLAG = 1 MC(0) = MACCSV ELSE KFLAG = KFSAVE ENDIF IF (NAMEST(NCALL) == 'FMSUB ') THEN IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1) KFLAG = KFSAVE MC(0) = MACCSV ENDIF RETURN ENDIF IF (KRESLT == 3 .OR. KRESLT == 4) THEN CALL FMIM(0,MC) MC(1) = MEXPOV MC(2) = 1 MC(0) = NINT(NDIG*ALOGM2) IF (KRESLT == 3) MC(-1) = -1 MC(0) = MACCAB KFLAG = KFSAVE RETURN ENDIF IF (KRESLT == 5 .OR. KRESLT == 6) THEN CALL FMIM(0,MC) MC(1) = MEXPUN MC(2) = 1 MC(0) = NINT(NDIG*ALOGM2) IF (KRESLT == 5) MC(-1) = -1 MC(0) = MACCAB KFLAG = KFSAVE RETURN ENDIF IF (KRESLT == 7) THEN CALL FMIM(-1,MC) MC(0) = MACCAB KFLAG = KFSAVE RETURN ENDIF IF (KRESLT == 8) THEN CALL FMIM(1,MC) MC(0) = MACCAB KFLAG = KFSAVE RETURN ENDIF IF (KRESLT == 11) THEN CALL FMIM(0,MC) MC(0) = MACCAB KFLAG = KFSAVE RETURN ENDIF IF (KRESLT == 12 .OR. KRESLT < 0 .OR. KRESLT > 15) THEN CALL FMIM(0,MC) MC(1) = MUNKNO MC(2) = 1 MC(0) = NINT(NDIG*ALOGM2) MC(0) = MACCAB KFLAG = KFSAVE RETURN ENDIF RETURN END SUBROUTINE FMRSLT SUBROUTINE FMSETVAR(STRING) ! Change the value of one of the internal FM variables. ! STRING must have the format ' variablename = value ', with no ! embedded blanks in variablename. USE FMVALS IMPLICIT NONE CHARACTER(*) :: STRING CHARACTER(6) :: VARNAME INTEGER IVAL,J,KPTEQ,KPT1,KPT2 DOUBLE PRECISION DVAL REAL (KIND(1.0D0)) :: MVAL CHARACTER(52) :: LETTERS = & 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' ! Find the equal sign. KPTEQ = INDEX(STRING,'=') IF (KPTEQ <= 0) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' Cannot find the equal sign in FMSETVAR.' WRITE (KW,*) ' Input string: ',STRING RETURN ENDIF ! Find the variable name. KPT1 = 0 KPT2 = 0 DO J = 1, KPTEQ-1 IF (KPT1 == 0 .AND. STRING(J:J) /= ' ') KPT1 = J ENDDO DO J = KPTEQ-1, 1, -1 IF (KPT2 == 0 .AND. STRING(J:J) /= ' ') KPT2 = J ENDDO IF (KPT1 == 0) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' Cannot find the variable name in FMSETVAR.' WRITE (KW,*) ' Input string: ',STRING RETURN ENDIF VARNAME = ' ' DO J = KPT1, KPT2 IVAL = INDEX(LETTERS,STRING(J:J)) IF (IVAL > 26 .AND. IVAL <= 52) THEN VARNAME(J-KPT1+1:J-KPT1+1) = LETTERS(IVAL-26:IVAL-26) ELSE VARNAME(J-KPT1+1:J-KPT1+1) = STRING(J:J) ENDIF ENDDO ! CMCHAR is a special case, since the value is a character. IF (VARNAME == 'CMCHAR') THEN KPT1 = 0 KPT2 = 0 DO J = KPTEQ+1, LEN(STRING) IF (KPT1 == 0 .AND. STRING(J:J) /= ' ') KPT1 = J ENDDO DO J = LEN(STRING), KPTEQ+1, -1 IF (KPT2 == 0 .AND. STRING(J:J) /= ' ') KPT2 = J ENDDO IF (KPT1 == KPT2 .AND. INDEX(LETTERS,STRING(KPT1:KPT2)) > 0) THEN CMCHAR = STRING(KPT1:KPT2) ELSE WRITE (KW,*) ' ' WRITE (KW,*) ' Only a single letter is allowed after the', & ' equal sign in FMSETVAR.' WRITE (KW,*) ' Input string: ',STRING RETURN ENDIF ENDIF ! Convert the value after the equal sign. IF (KPTEQ+1 <= LEN(STRING)) THEN IF (INDEX(STRING(KPTEQ+1:LEN(STRING)),'=') /= 0) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' Only a single equal sign is allowed in FMSETVAR.' WRITE (KW,*) ' Input string: ',STRING RETURN ENDIF CALL FMST2D(STRING(KPTEQ+1:LEN(STRING)),DVAL) IF (KFLAG /= 0) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' Invalid value after the equal sign in', & ' FMSETVAR.' WRITE (KW,*) ' Input string: ',STRING RETURN ENDIF ELSE WRITE (KW,*) ' ' WRITE (KW,*) ' Cannot find a value after the equal sign in', & ' FMSETVAR.' WRITE (KW,*) ' Input string: ',STRING RETURN ENDIF ! Check the list of variable names. IF (VARNAME == 'JFORM1') THEN JFORM1 = NINT(DVAL) IF (JFORM1 < 0 .OR. JFORM1 > 2) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',JFORM1, & ' is an invalid value for JFORM1' JFORM1 = 1 WRITE (KW,*) ' Valid values are 0,1,2.', & ' JFORM1 was set to ',JFORM1 ENDIF ELSE IF (VARNAME == 'JFORM2') THEN JFORM2 = NINT(DVAL) IF (JFORM2 < 0) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',JFORM2, & ' is an invalid value for JFORM2' JFORM2 = 1 WRITE (KW,*) ' It should be nonegative.', & ' JFORM2 was set to ',JFORM2 ENDIF ELSE IF (VARNAME == 'JFORMZ') THEN JFORMZ = NINT(DVAL) IF (JFORMZ < 1 .OR. JFORMZ > 3) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',JFORMZ, & ' is an invalid value for JFORMZ' JFORMZ = 1 WRITE (KW,*) ' Valid values are 1,2,3.', & ' JFORMZ was set to ',JFORMZ ENDIF ELSE IF (VARNAME == 'JPRNTZ') THEN JPRNTZ = NINT(DVAL) IF (JPRNTZ < 1 .OR. JPRNTZ > 2) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',JPRNTZ, & ' is an invalid value for JPRNTZ' JPRNTZ = 1 WRITE (KW,*) ' Valid values are 1,2.', & ' JPRNTZ was set to ',JPRNTZ ENDIF ELSE IF (VARNAME == 'KACCSW') THEN KACCSW = NINT(DVAL) IF (KACCSW < 0 .OR. KACCSW > 1) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',KACCSW, & ' is an invalid value for KACCSW' KACCSW = 0 WRITE (KW,*) ' Valid values are 0,1.', & ' KACCSW was set to ',KACCSW ENDIF ELSE IF (VARNAME == 'KDEBUG') THEN KDEBUG = NINT(DVAL) IF (KDEBUG < 0 .OR. KDEBUG > 1) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',KDEBUG, & ' is an invalid value for KDEBUG' KDEBUG = 1 WRITE (KW,*) ' Valid values are 0,1.', & ' KDEBUG was set to ',KDEBUG ENDIF ELSE IF (VARNAME == 'KESWCH') THEN KESWCH = NINT(DVAL) IF (KESWCH < 0 .OR. KESWCH > 1) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',KESWCH, & ' is an invalid value for KESWCH' KESWCH = 1 WRITE (KW,*) ' Valid values are 0,1.', & ' KESWCH was set to ',KESWCH ENDIF ELSE IF (VARNAME == 'KRAD ') THEN KRAD = NINT(DVAL) IF (KRAD < 0 .OR. KRAD > 1) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',KRAD, & ' is an invalid value for KRAD' KRAD = 1 WRITE (KW,*) ' Valid values are 0,1.', & ' KRAD was set to ',KRAD ENDIF ELSE IF (VARNAME == 'KROUND') THEN KROUND = NINT(DVAL) IF (KROUND < -1 .OR. KROUND > 2) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',KROUND, & ' is an invalid value for KROUND' KROUND = 1 WRITE (KW,*) ' Valid values are -1,0,1,2.', & ' KROUND was set to ',KROUND ENDIF ELSE IF (VARNAME == 'KRPERF') THEN KRPERF = NINT(DVAL) IF (KRPERF < 0 .OR. KRPERF > 1) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',KRPERF, & ' is an invalid value for KRPERF' KRPERF = 0 WRITE (KW,*) ' Valid values are 0,1.', & ' KRPERF was set to ',KRPERF ENDIF ELSE IF (VARNAME == 'KSWIDE') THEN KSWIDE = NINT(DVAL) IF (KSWIDE < 10) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',KSWIDE, & ' is an invalid value for KSWIDE' KSWIDE = 80 WRITE (KW,*) ' It should be 10 or more.', & ' KSWIDE was set to ',KSWIDE ENDIF ELSE IF (VARNAME == 'KW ') THEN KW = NINT(DVAL) ELSE IF (VARNAME == 'KWARN ') THEN KWARN = NINT(DVAL) IF (KWARN < 0 .OR. KWARN > 2) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',KWARN, & ' is an invalid value for KWARN' KWARN = 1 WRITE (KW,*) ' Valid values are 0,1,2.', & ' KWARN was set to ',KWARN ENDIF ELSE IF (VARNAME == 'LVLTRC') THEN LVLTRC = NINT(DVAL) IF (LVLTRC < 0) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',LVLTRC, & ' is an invalid value for LVLTRC' LVLTRC = 1 WRITE (KW,*) ' It should be nonegative.', & ' LVLTRC was set to ',LVLTRC ENDIF ELSE IF (VARNAME == 'NDIG ') THEN IVAL = NDIG NDIG = NINT(DVAL) IF (NDIG < 2) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',NDIG, & ' is an invalid value for NDIG' NDIG = IVAL WRITE (KW,*) ' It should be > 1.', & ' NDIG was not changed from ',NDIG ENDIF IF (NDIG > NDIGMX) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',NDIG, & ' is an invalid value for NDIG' NDIG = NDIGMX WRITE (KW,*) ' It should be <=',NDIGMX, & '. NDIG was set to ',NDIG ENDIF ELSE IF (VARNAME == 'NTRACE') THEN NTRACE = NINT(DVAL) IF (NTRACE < -2 .OR. NTRACE > 2) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',NTRACE, & ' is an invalid value for NTRACE' NTRACE = 0 WRITE (KW,*) ' Valid values are -2,-1,0,1,2.', & ' NTRACE was set to ',NTRACE ENDIF ELSE IF (VARNAME == 'MBASE ') THEN MVAL = MBASE MBASE = ANINT (DVAL) IF (MBASE < 2) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',MBASE, & ' is an invalid value for MBASE' MBASE = MVAL WRITE (KW,*) ' It should be > 1.', & ' MBASE was not changed from ',MBASE ENDIF ELSE IF (VARNAME == 'MXEXP ') THEN MXEXP = AINT (DVAL) IF (MXEXP < 10 .OR. MXEXP > MXEXP2/2.01D0) THEN WRITE (KW,*) ' ' WRITE (KW,*) ' FMSETVAR: Input string: ',STRING WRITE (KW,*) ' ',MXEXP, & ' is an invalid value for MXEXP' MXEXP = INT(MXEXP2/2.01D0) WRITE (KW,*) ' Valid values are 10 to ', & INT(MXEXP2/2.01D0),' MXEXP was set to ',MXEXP ENDIF ELSE WRITE (KW,*) ' Variable name not recognized in FMSETVAR.' WRITE (KW,*) ' Input string: ',STRING RETURN ENDIF CALL FMCONS RETURN END SUBROUTINE FMSETVAR SUBROUTINE FMSIGN(MA,MB,MC) ! MC = SIGN(MA,MB) ! MC is set to ABS(MA) if MB is positive or zero, ! or -ABS(MA) if MB is negative. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) INTEGER KWRNSV KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMSIGN' IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1) KWRNSV = KWARN KWARN = 0 IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN CALL FMST2M('UNKNOWN',MC) KFLAG = -4 ELSE IF (MB(-1) >= 0) THEN CALL FMEQ(MA,MC) MC(-1) = 1 ELSE CALL FMEQ(MA,MC) IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1 ENDIF KWARN = KWRNSV IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMSIGN SUBROUTINE FMSIN(MA,MB) ! MB = SIN(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE INTEGER J,JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NDSV IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN CALL FMENTR('FMSIN ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMSIN ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF MACCA = MA(0) MAS = MA(-1) CALL FMEQ2(MA,MB,NDSAVE,NDIG) MB(0) = NINT(NDIG*ALOGM2) MB(-1) = 1 CALL FMEQ(MB,MWE) KWRNSV = KWARN KWARN = 0 ! Reduce the argument, convert to radians if the input is ! in degrees, and evaluate the function. CALL FMRDC(MB,JSIN,JCOS,JSWAP) KWARN = KWRNSV IF (MB(1) == MUNKNO) THEN IF (KRAD /= 1 .OR. JSWAP == 0) THEN CALL FMEQ(MWE,MB) CALL FMRDC(MB,JSIN,JCOS,JSWAP) GO TO 110 ENDIF IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN NDSV = NDIG NDIG = MIN(NDIG+2,NDG2MX) NCALL = NCALL + 1 NAMEST(NCALL) = 'NOEQ ' CALL FMPI(MPISAV) NCALL = NCALL - 1 NDIG = NDSV ENDIF CALL FMDIV(MWE,MPISAV,M04) CALL FMMPYI_R1(M04,2) CALL FMNINT(M04,M03) CALL FMMPY(M03,MPISAV,M02) CALL FMDIVI_R1(M02,2) CALL FMSUB_R2(MWE,M02) IF (M02(2) == 0) CALL FMULP(MWE,M02) CALL FMI2M(1,M04) CALL FMSQR_R1(M02) CALL FMDIVI_R1(M02,2) CALL FMSUB_R2(M04,M02) CALL FMSUB_R1(M02,M04) IF (M02(2) == 0) THEN CALL FMI2M(JSIN,MB) ELSE CALL FMEQ(MWE,MB) CALL FMRDC(MB,JSIN,JCOS,JSWAP) ENDIF GO TO 110 ENDIF IF (KRAD == 0) THEN IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN NDSV = NDIG NDIG = MIN(NDIG+2,NDG2MX) NCALL = NCALL + 1 NAMEST(NCALL) = 'NOEQ ' CALL FMPI(MPISAV) NCALL = NCALL - 1 NDIG = NDSV ENDIF CALL FMMPY_R1(MB,MPISAV) CALL FMDIVI_R1(MB,180) ENDIF IF (MB(1) /= MUNKNO) THEN IF (JSWAP == 0) THEN IF (MB(1) < 0 .OR. NDIG <= 50) THEN CALL FMSIN2(MB,M09) CALL FMEQ(M09,MB) ELSE CALL FMCOS2(MB,M09) CALL FMEQ(M09,MB) CALL FMI2M(1,M03) CALL FMSQR_R1(MB) CALL FMSUB_R2(M03,MB) CALL FMSQRT_R1(MB) ENDIF ELSE CALL FMCOS2(MB,M09) CALL FMEQ(M09,MB) ENDIF ENDIF ! Append the sign, round, and return. IF (JSIN == -1 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1) 110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MACCA,MACMAX) IF (MAS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1) DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMSIN SUBROUTINE FMSIN2(MA,MB) ! Internal subroutine for MB = SIN(MA) where 0 <= MA <= 1. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) ! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent ! sums. Increasing this value will begin to improve the ! speed of SIN when the base is large and precision exceeds ! about 1,500 decimal digits. REAL (KIND(1.0D0)) :: MAXVAL INTEGER J,J2,K,K2,KPT,KTHREE,KWRNSV,L,L2,LARGE,N2,NBOT,NDSAV1, & NDSAVE,NTERM REAL ALOG3,ALOGT,B,T,TJ IF (MBLOGS /= MBASE) CALL FMCONS IF (MA(2) == 0) THEN CALL FMEQ(MA,MB) RETURN ENDIF NDSAVE = NDIG KWRNSV = KWARN KWARN = 0 ! Use the direct series ! SIN(X) = X - X**3/3! + X**5/5! - ... ! The argument will be divided by 3**K2 before the series ! is summed. The series will be added as J2 concurrent ! series. The approximately optimal values of K2 and J2 ! are now computed to try to minimize the time required. ! N2/2 is the approximate number of terms of the series ! that will be needed, and L2 guard digits will be carried. B = REAL(MBASE) K = NGRD52 T = MAX(NDIG-K,2) ALOG3 = LOG(3.0) ALOGT = LOG(T) TJ = 0.05*ALOGMB*T**0.3333 + 1.85 J2 = INT(TJ) J2 = MAX(1,MIN(J2,LJSUMS/NDG2MX)) K2 = INT(0.1*SQRT(T*ALOGMB/TJ) - 0.05*ALOGT + 2.5) L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B + & REAL(MA(3))/(B*B)))/ALOG3 - 0.3) K2 = K2 - L IF (L < 0) L = 0 IF (K2 < 0) THEN K2 = 0 J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG3)) + .33) ENDIF IF (J2 <= 1) J2 = 1 N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG3)) L2 = INT(LOG(REAL(N2)+3.0**K2)/ALOGMB) NDIG = NDIG + L2 IF (NDIG > NDG2MX) THEN IF (NCALL == 1) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MB) KWARN = KWRNSV RETURN ELSE NDIG = NDG2MX ENDIF ENDIF NDSAV1 = NDIG ! Divide the argument by 3**K2. CALL FMEQ2(MA,M02,NDSAVE,NDIG) KTHREE = 1 MAXVAL = MXBASE/3 IF (K2 > 0) THEN DO J = 1, K2 KTHREE = 3*KTHREE IF (KTHREE > MAXVAL) THEN CALL FMDIVI_R1(M02,KTHREE) KTHREE = 1 ENDIF ENDDO IF (KTHREE > 1) CALL FMDIVI_R1(M02,KTHREE) ENDIF ! Split into J2 concurrent sums and reduce NDIG while ! computing each term in the sum as the terms get smaller. CALL FMEQ(M02,M03) NTERM = 1 DO J = 1, J2 NBOT = NTERM*(NTERM-1) IF (NBOT > 1) CALL FMDIVI_R1(M03,NBOT) NTERM = NTERM + 2 KPT = (J-1)*(NDIG+3) CALL FMEQ(M03,MJSUMS(KPT-1)) IF (M03(1) /= MUNKNO .AND. M03(2) /= 0) M03(-1) = -M03(-1) ENDDO CALL FMSQR_R1(M02) IF (M02(1) < -NDIG) GO TO 120 CALL FMIPWR(M02,J2,MB) 110 CALL FMMPY_R1(M03,MB) LARGE = INT(INTMAX/NTERM) DO J = 1, J2 NBOT = NTERM*(NTERM-1) IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN CALL FMDIVI_R1(M03,NTERM) NBOT = NTERM - 1 CALL FMDIVI_R1(M03,NBOT) ELSE CALL FMDIVI_R1(M03,NBOT) ENDIF KPT = (J-1)*(NDSAV1+3) NDIG = NDSAV1 CALL FMADD_R1(MJSUMS(KPT-1),M03) IF (KFLAG /= 0) GO TO 120 NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1)) IF (NDIG < 2) NDIG = 2 IF (M03(1) /= MUNKNO .AND. M03(2) /= 0) M03(-1) = -M03(-1) NTERM = NTERM + 2 ENDDO GO TO 110 ! Next put the J2 separate sums back together. 120 KFLAG = 0 KPT = (J2-1)*(NDIG+3) CALL FMEQ(MJSUMS(KPT-1),MB) IF (J2 >= 2) THEN DO J = 2, J2 CALL FMMPY_R2(M02,MB) KPT = (J2-J)*(NDIG+3) CALL FMADD_R1(MB,MJSUMS(KPT-1)) ENDDO ENDIF ! Reverse the effect of reducing the argument to ! compute SIN(MA). NDIG = NDSAV1 IF (K2 > 0) THEN CALL FMI2M(3,M02) DO J = 1, K2 CALL FMSQR(MB,M03) CALL FMMPYI_R1(M03,-4) CALL FMADD_R2(M02,M03) CALL FMMPY_R2(M03,MB) ENDDO ENDIF CALL FMEQ2_R1(MB,NDSAV1,NDSAVE) NDIG = NDSAVE KWARN = KWRNSV RETURN END SUBROUTINE FMSIN2 SUBROUTINE FMSINH(MA,MB) ! MB = SINH(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE INTEGER J,K,KASAVE,KOVUN,KRESLT,NDSAVE,NMETHD IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB) THEN CALL FMENTR('FMSINH',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMSINH' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF MACCA = MA(0) MAS = MA(-1) CALL FMEQ2(MA,MB,NDSAVE,NDIG) IF (MA(2) == 0) THEN GO TO 120 ENDIF MB(0) = NINT(NDIG*ALOGM2) MB(-1) = 1 ! Use a series for small arguments, FMEXP for large ones. IF (MB(1) == MUNKNO) GO TO 120 IF (MBASE > 99) THEN IF (MB(1) <= 0) THEN NMETHD = 1 ELSE IF (MB(1) >= 2) THEN NMETHD = 2 ELSE IF (ABS(MB(2)) < 10) THEN NMETHD = 1 ELSE NMETHD = 2 ENDIF ELSE IF (MB(1) <= 0) THEN NMETHD = 1 ELSE NMETHD = 2 ENDIF ENDIF IF (NMETHD == 2) GO TO 110 IF (MB(1) < 0 .OR. NDIG <= 50) THEN CALL FMSNH2(MB,M09) CALL FMEQ(M09,MB) ELSE CALL FMCSH2(MB,M09) CALL FMEQ(M09,MB) CALL FMI2M(1,M03) CALL FMSQR_R1(MB) CALL FMSUB_R1(MB,M03) CALL FMSQRT_R1(MB) ENDIF GO TO 120 110 CALL FMEXP(MB,M12) CALL FMEQ(M12,MB) IF (MB(1) == MEXPOV) THEN GO TO 120 ELSE IF (MB(1) == MEXPUN) THEN MB(1) = MEXPOV GO TO 120 ENDIF IF (INT(MB(1)) <= (NDIG+1)/2) THEN CALL FMI2M(1,M01) CALL FMDIV_R1(M01,MB) CALL FMSUB_R1(MB,M01) ENDIF CALL FMDIVI_R1(MB,2) ! Round and return. 120 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MACCA,MACMAX) IF (MAS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1) DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMSINH SUBROUTINE FMSNH2(MA,MB) ! Internal subroutine for MB = SINH(MA). USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) ! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent ! sums. Increasing this value will begin to improve the ! speed of SINH when the base is large and precision exceeds ! about 1,500 decimal digits. REAL (KIND(1.0D0)) :: MAXVAL INTEGER J,J2,K,K2,KPT,KTHREE,KWRNSV,L,L2,LARGE,N2,NBOT,NDSAV1, & NDSAVE,NTERM REAL ALOG3,ALOGT,B,T,TJ IF (MBLOGS /= MBASE) CALL FMCONS IF (MA(2) == 0) THEN CALL FMEQ(MA,MB) RETURN ENDIF NDSAVE = NDIG KWRNSV = KWARN KWARN = 0 ! Use the direct series ! SINH(X) = X + X**3/3! + X**5/5! - ... ! The argument will be divided by 3**K2 before the series ! is summed. The series will be added as J2 concurrent ! series. The approximately optimal values of K2 and J2 ! are now computed to try to minimize the time required. ! N2/2 is the approximate number of terms of the series ! that will be needed, and L2 guard digits will be carried. B = REAL(MBASE) K = NGRD52 T = MAX(NDIG-K,2) ALOG3 = LOG(3.0) ALOGT = LOG(T) TJ = 0.05*ALOGMB*T**0.3333 + 1.85 J2 = INT(TJ) J2 = MAX(1,MIN(J2,LJSUMS/NDG2MX)) K2 = INT(0.1*SQRT(T*ALOGMB/TJ) - 0.05*ALOGT + 2.5) L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B + & REAL(MA(3))/(B*B)))/ALOG3 - 0.3) K2 = K2 - L IF (L < 0) L = 0 IF (K2 < 0) THEN K2 = 0 J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG3)) + .33) ENDIF IF (J2 <= 1) J2 = 1 N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG3)) L2 = INT(LOG(REAL(N2)+3.0**K2)/ALOGMB) NDIG = NDIG + L2 IF (NDIG > NDG2MX) THEN IF (NCALL == 1) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE CALL FMST2M('UNKNOWN',MB) KWARN = KWRNSV RETURN ELSE NDIG = NDG2MX ENDIF ENDIF NDSAV1 = NDIG ! Divide the argument by 3**K2. CALL FMEQ2(MA,M02,NDSAVE,NDIG) KTHREE = 1 MAXVAL = MXBASE/3 IF (K2 > 0) THEN DO J = 1, K2 KTHREE = 3*KTHREE IF (KTHREE > MAXVAL) THEN CALL FMDIVI_R1(M02,KTHREE) KTHREE = 1 ENDIF ENDDO IF (KTHREE > 1) CALL FMDIVI_R1(M02,KTHREE) ENDIF ! Split into J2 concurrent sums and reduce NDIG while ! computing each term in the sum as the terms get smaller. CALL FMEQ(M02,M03) NTERM = 1 DO J = 1, J2 NBOT = NTERM*(NTERM-1) IF (NBOT > 1) CALL FMDIVI_R1(M03,NBOT) NTERM = NTERM + 2 KPT = (J-1)*(NDIG+3) CALL FMEQ(M03,MJSUMS(KPT-1)) ENDDO CALL FMSQR_R1(M02) IF (M02(1) < -NDIG) GO TO 120 CALL FMIPWR(M02,J2,MB) 110 CALL FMMPY_R1(M03,MB) LARGE = INT(INTMAX/NTERM) DO J = 1, J2 NBOT = NTERM*(NTERM-1) IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN CALL FMDIVI_R1(M03,NTERM) NBOT = NTERM - 1 CALL FMDIVI_R1(M03,NBOT) ELSE CALL FMDIVI_R1(M03,NBOT) ENDIF KPT = (J-1)*(NDSAV1+3) NDIG = NDSAV1 CALL FMADD_R1(MJSUMS(KPT-1),M03) IF (KFLAG /= 0) GO TO 120 NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1)) IF (NDIG < 2) NDIG = 2 NTERM = NTERM + 2 ENDDO GO TO 110 ! Next put the J2 separate sums back together. 120 KFLAG = 0 KPT = (J2-1)*(NDIG+3) CALL FMEQ(MJSUMS(KPT-1),MB) IF (J2 >= 2) THEN DO J = 2, J2 CALL FMMPY_R2(M02,MB) KPT = (J2-J)*(NDIG+3) CALL FMADD_R1(MB,MJSUMS(KPT-1)) ENDDO ENDIF ! Reverse the effect of reducing the argument to ! compute SINH(MA). NDIG = NDSAV1 IF (K2 > 0) THEN CALL FMI2M(3,M02) DO J = 1, K2 CALL FMSQR(MB,M03) CALL FMMPYI_R1(M03,4) CALL FMADD_R2(M02,M03) CALL FMMPY_R2(M03,MB) ENDDO ENDIF CALL FMEQ2_R1(MB,NDSAV1,NDSAVE) NDIG = NDSAVE KWARN = KWRNSV RETURN END SUBROUTINE FMSNH2 SUBROUTINE FMSP2M(X,MA) ! MA = X ! Convert a single precision number to FM format. ! This version tries to convert the single precision machine ! number to FM with accuracy of nearly full FM precision. ! If conversion to FM with approximately double precision accuracy ! is good enough, it is faster to CALL FMDPM(DBLE(X),MA) USE FMVALS IMPLICIT NONE REAL X REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) DOUBLE PRECISION XDP,Y,YT INTEGER K NCALL = NCALL + 1 NAMEST(NCALL) = 'FMSP2M' XDP = DBLE(X) IF (NTRACE /= 0) CALL FMNTRR(2,XDP,1) ! Check to see if X is exactly a small integer. If so, ! converting as an integer is better. ! Also see if X is exactly a small integer divided by ! a small power of two. Y = MXEXP2 IF (ABS(XDP) < Y) THEN K = INT(XDP) Y = K IF (Y == XDP) THEN CALL FMIM(K,MA) GO TO 110 ENDIF ENDIF IF (ABS(XDP) < 1.0D0) THEN Y = 4096.0D0 * XDP K = INT(Y) YT = K IF (Y == YT) THEN CALL FMIM(K,MA) CALL FMDIVI_R1(MA,4096) GO TO 110 ENDIF ENDIF CALL FMDM2(XDP,MA) 110 IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMSP2M SUBROUTINE FMSQR(MA,MB) ! MB = MA*MA Faster than using FMMPY. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMSQR ' CALL FMNTR(2,MA,MA,1,1) CALL FMSQR2(MA,MB) CALL FMNTR(1,MB,MB,1,1) ELSE CALL FMSQR2(MA,MB) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMSQR SUBROUTINE FMSQR2(MA,MB) ! MB = MA*MA. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MAXMAX,MAXMWA,MBJ,MBKJ,MBM1, & MBNORM,MD2B,MK,MKA,MKT,MMAX,MR,MT INTEGER J,JM1,JRSSAV,K,KB,KI,KJ,KL,KNZ,KOVUN,KSHIFT,KWA, & L,N1,NGUARD IF (MBLOGS /= MBASE) CALL FMCONS JRSSAV = JRSIGN IF (ABS(MA(1)) > MEXPAB .OR. KDEBUG == 1 .OR. & MBASE*MBASE <= MXBASE/(4*MBASE)) THEN KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 IF (MA(1) == MUNKNO) KOVUN = 2 NCALL = NCALL + 1 CALL FMMPY2(MA,MA,MB) NCALL = NCALL - 1 IF ((KFLAG < 0 .AND. KOVUN == 0) .OR. & (KFLAG == -4 .AND. KOVUN == 1)) THEN NAMEST(NCALL) = 'FMSQR ' CALL FMWARN ENDIF GO TO 120 ELSE IF (MA(2) == 0) THEN CALL FMEQ(MA,MB) GO TO 120 ENDIF KFLAG = 0 MAXMAX = 0 MACCA = MA(0) N1 = NDIG + 1 MWA(1) = MA(1) + MA(1) ! NGUARD is the number of guard digits used. IF (NCALL > 1) THEN NGUARD = NGRD22 IF (NGUARD > NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 IF (NGUARD > NDIG) NGUARD = NDIG IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 10 ENDIF ENDIF IF (MA(2)*MA(2) < MBASE .AND. NGUARD < 3) NGUARD = 3 L = N1 + NGUARD MWA(L+1) = 0 ! The multiplication loop begins here. ! MBNORM is the minimum number of digits that can be ! multiplied before normalization is required. ! MAXMWA is an upper bound on the size of values in MWA ! divided by (MBASE-1). It is used to determine ! whether to normalize before the next digit is ! multiplied. MBM1 = MBASE - 1 MBNORM = AINT (MAXINT/(MBM1*MBM1)) MMAX = INTMAX - MBASE MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX) IF (MBNORM > 1) THEN MBJ = MA(2) ! Count the trailing zeros in MA. IF (MA(N1) /= 0) THEN KNZ = N1 ELSE DO J = NDIG, 2, -1 IF (MA(J) /= 0) THEN KNZ = J GO TO 110 ENDIF ENDDO ENDIF 110 MWA(2) = 0 MWA(3) = 0 DO K = NDIG+2, L MWA(K) = 0 ENDDO ! (Inner Loop) DO K = 3, N1 MWA(K+1) = MA(K)*MBJ ENDDO MAXMWA = MBJ DO J = 3, MIN(L/2,N1) MBJ = MA(J) IF (MBJ /= 0) THEN MAXMWA = MAXMWA + MBJ JM1 = J - 1 KL = MIN(KNZ,L-JM1) ! Major (Inner Loop) DO K = 2*J, JM1+KL MWA(K) = MWA(K) + MA(K-JM1)*MBJ ENDDO ENDIF IF (MAXMWA > MMAX) THEN MAXMAX = MAX(MAXMAX,MAXMWA) MAXMWA = 0 ! Normalization is only required for the ! range of digits currently changing in MWA. DO KB = JM1+KL, 2*J, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE ENDDO ENDIF ENDDO ! Double MWA, add the square terms, and perform ! the final normalization. (Inner Loop) IF (2*MAX(MAXMAX,MAXMWA)+MBASE > MMAX) THEN DO KB = L, 4, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE ENDDO ENDIF DO J = 3, L-1, 2 IF ((J+1)/2 <= N1) THEN MKA = MA((J+1)/2) MWA(J) = 2*MWA(J) + MKA*MKA MWA(J+1) = 2*MWA(J+1) ELSE MWA(J) = 2*MWA(J) MWA(J+1) = 2*MWA(J+1) ENDIF ENDDO IF (MOD(L,2) == 1) THEN IF ((L+1)/2 <= N1) THEN MKA = MA((L+1)/2) MWA(L) = 2*MWA(L) + MKA*MKA ELSE MWA(L) = 2*MWA(L) ENDIF ENDIF DO KB = L, 3, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE ENDDO ELSE ! If normalization must be done for each digit, combine ! the two loops and normalize as the digits are multiplied. DO J = 2, L MWA(J) = 0 ENDDO KJ = NDIG + 2 DO J = 2, N1 KJ = KJ - 1 MBKJ = MA(KJ) IF (MBKJ == 0) CYCLE KL = L - KJ + 1 IF (KL > N1) KL = N1 KI = KL + 2 KWA = KL+ KJ + 1 MK = 0 DO K = 2, KL MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MK MK = INT (MT/MBASE) MWA(KWA-K) = MT - MBASE*MK ENDDO MWA(KWA-KL-1) = MK ENDDO ENDIF ! Set KSHIFT = 1 if a shift left is necessary. IF (MWA(2) == 0) THEN KSHIFT = 1 ELSE KSHIFT = 0 ENDIF ! The multiplication is complete. ! Round the result and move it to MB. JRSIGN = 1 MR = 2*MWA(NDIG+2+KSHIFT) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ELSE IF (MR >= MBASE) THEN IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1 MWA(N1+1+KSHIFT) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ENDIF ENDIF CALL FMMOVE(MWA,MB) IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMSQR ' CALL FMWARN ENDIF IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MACCA,MD2B) ELSE MB(0) = MACCA ENDIF 120 MB(-1) = 1 JRSIGN = JRSSAV RETURN END SUBROUTINE FMSQR2 SUBROUTINE FMSQR_R1(MA) ! MA = MA*MA Faster than using FMMPY. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMSQR ' CALL FMNTR(2,MA,MA,1,1) CALL FMSQR2_R1(MA) CALL FMNTR(1,MA,MA,1,1) ELSE CALL FMSQR2_R1(MA) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMSQR_R1 SUBROUTINE FMSQR2_R1(MA) ! MA = MA*MA. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MAXMAX,MAXMWA,MBJ,MBKJ,MBM1, & MBNORM,MD2B,MK,MKA,MKT,MMAX,MR,MT INTEGER J,JM1,JRSSAV,K,KB,KI,KJ,KL,KNZ,KOVUN,KSHIFT,KWA, & L,N1,NGUARD IF (MBLOGS /= MBASE) CALL FMCONS JRSSAV = JRSIGN IF (ABS(MA(1)) > MEXPAB .OR. KDEBUG == 1 .OR. & MBASE*MBASE <= MXBASE/(4*MBASE)) THEN KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 IF (MA(1) == MUNKNO) KOVUN = 2 NCALL = NCALL + 1 CALL FMMPY2(MA,MA,M07) CALL FMEQ(M07,MA) NCALL = NCALL - 1 IF ((KFLAG < 0 .AND. KOVUN == 0) .OR. & (KFLAG == -4 .AND. KOVUN == 1)) THEN NAMEST(NCALL) = 'FMSQR ' CALL FMWARN ENDIF GO TO 120 ELSE IF (MA(2) == 0) THEN GO TO 120 ENDIF KFLAG = 0 MAXMAX = 0 MACCA = MA(0) N1 = NDIG + 1 MWA(1) = MA(1) + MA(1) ! NGUARD is the number of guard digits used. IF (NCALL > 1) THEN NGUARD = NGRD22 IF (NGUARD > NDIG) NGUARD = NDIG ELSE NGUARD = NGRD52 IF (NGUARD > NDIG) NGUARD = NDIG IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN NGUARD = NDIG + 10 ENDIF ENDIF IF (MA(2)*MA(2) < MBASE .AND. NGUARD < 3) NGUARD = 3 L = N1 + NGUARD MWA(L+1) = 0 ! The multiplication loop begins here. ! MBNORM is the minimum number of digits that can be ! multiplied before normalization is required. ! MAXMWA is an upper bound on the size of values in MWA ! divided by (MBASE-1). It is used to determine ! whether to normalize before the next digit is ! multiplied. MBM1 = MBASE - 1 MBNORM = AINT (MAXINT/(MBM1*MBM1)) MMAX = INTMAX - MBASE MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX) IF (MBNORM > 1) THEN MBJ = MA(2) ! Count the trailing zeros in MA. IF (MA(N1) /= 0) THEN KNZ = N1 ELSE DO J = NDIG, 2, -1 IF (MA(J) /= 0) THEN KNZ = J GO TO 110 ENDIF ENDDO ENDIF 110 MWA(2) = 0 MWA(3) = 0 DO K = NDIG+2, L MWA(K) = 0 ENDDO ! (Inner Loop) DO K = 3, N1 MWA(K+1) = MA(K)*MBJ ENDDO MAXMWA = MBJ DO J = 3, MIN(L/2,N1) MBJ = MA(J) IF (MBJ /= 0) THEN MAXMWA = MAXMWA + MBJ JM1 = J - 1 KL = MIN(KNZ,L-JM1) ! Major (Inner Loop) DO K = 2*J, JM1+KL MWA(K) = MWA(K) + MA(K-JM1)*MBJ ENDDO ENDIF IF (MAXMWA > MMAX) THEN MAXMAX = MAX(MAXMAX,MAXMWA) MAXMWA = 0 ! Normalization is only required for the ! range of digits currently changing in MWA. DO KB = JM1+KL, 2*J, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE ENDDO ENDIF ENDDO ! Double MWA, add the square terms, and perform ! the final normalization. (Inner Loop) IF (2*MAX(MAXMAX,MAXMWA)+MBASE > MMAX) THEN DO KB = L, 4, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE ENDDO ENDIF DO J = 3, L-1, 2 IF ((J+1)/2 <= N1) THEN MKA = MA((J+1)/2) MWA(J) = 2*MWA(J) + MKA*MKA MWA(J+1) = 2*MWA(J+1) ELSE MWA(J) = 2*MWA(J) MWA(J+1) = 2*MWA(J+1) ENDIF ENDDO IF (MOD(L,2) == 1) THEN IF ((L+1)/2 <= N1) THEN MKA = MA((L+1)/2) MWA(L) = 2*MWA(L) + MKA*MKA ELSE MWA(L) = 2*MWA(L) ENDIF ENDIF DO KB = L, 3, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE ENDDO ELSE ! If normalization must be done for each digit, combine ! the two loops and normalize as the digits are multiplied. DO J = 2, L MWA(J) = 0 ENDDO KJ = NDIG + 2 DO J = 2, N1 KJ = KJ - 1 MBKJ = MA(KJ) IF (MBKJ == 0) CYCLE KL = L - KJ + 1 IF (KL > N1) KL = N1 KI = KL + 2 KWA = KL+ KJ + 1 MK = 0 DO K = 2, KL MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MK MK = INT (MT/MBASE) MWA(KWA-K) = MT - MBASE*MK ENDDO MWA(KWA-KL-1) = MK ENDDO ENDIF ! Set KSHIFT = 1 if a shift left is necessary. IF (MWA(2) == 0) THEN KSHIFT = 1 ELSE KSHIFT = 0 ENDIF ! The multiplication is complete. ! Round the result and move it to MA. JRSIGN = 1 MR = 2*MWA(NDIG+2+KSHIFT) + 1 IF (KROUND == -1 .OR. KROUND == 2) THEN CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ELSE IF (MR >= MBASE) THEN IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN IF (KROUND /= 0 .OR. NCALL > 1) THEN MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1 MWA(N1+1+KSHIFT) = 0 ENDIF ELSE CALL FMRND(MWA,NDIG,NGUARD,KSHIFT) ENDIF ENDIF CALL FMMOVE(MWA,MA) IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMSQR ' CALL FMWARN ENDIF IF (KACCSW == 1) THEN MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315) MA(0) = MIN(MACCA,MD2B) ELSE MA(0) = MACCA ENDIF 120 MA(-1) = 1 JRSIGN = JRSSAV RETURN END SUBROUTINE FMSQR2_R1 SUBROUTINE FMSQRT(MA,MB) ! MB = SQRT(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) DOUBLE PRECISION X,XB REAL (KIND(1.0D0)) :: MA1,MACCA,MD2B,MKE,MXSAVE INTEGER NSTACK(19),J,K,KASAVE,KMA1,KOVUN,KRESLT,KST,NDSAVE IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0 .OR. MA(-1) < 0) THEN CALL FMENTR('FMSQRT',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMSQRT' CALL FMNTR(2,MA,MA,1,1) ENDIF NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN NAMEST(NCALL) = 'FMSQRT' KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10)) ENDIF MA1 = MA(1) MACCA = MA(0) CALL FMEQ2(MA,M02,NDSAVE,NDIG) M02(0) = NINT(NDIG*ALOGM2) ! Generate the first approximation. M02(1) = 0 CALL FMM2DP(M02,X) X = SQRT(X) MKE = MA1/2 KMA1 = INT(ABS(MA1)) IF (MOD(KMA1,2) == 1) THEN XB = MBASE X = X*SQRT(XB) MKE = (MA1-1)/2 ENDIF CALL FMDPM(X,MB) MB(1) = MB(1) + MKE ! Initialize. M02(1) = MA1 CALL FMDIG(NSTACK,KST) ! Newton iteration. DO J = 1, KST NDIG = NSTACK(J) CALL FMDIV(M02,MB,M01) CALL FMADD_R1(MB,M01) CALL FMDIVI_R1(MB,2) ENDDO ! Round the result and return. IF (KASAVE == 1) THEN MD2B = NINT((NDSAVE-1)*ALOGM2+LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MACCA,MD2B) ELSE MB(0) = MACCA ENDIF MB(-1) = 1 DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,0) RETURN END SUBROUTINE FMSQRT SUBROUTINE FMSQRT_R1(MA) ! MA = SQRT(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) DOUBLE PRECISION X,XB REAL (KIND(1.0D0)) :: MA1,MACCA,MD2B,MKE,MXSAVE INTEGER NSTACK(19),J,K,KASAVE,KMA1,KOVUN,KRESLT,KST,NDSAVE IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0 .OR. MA(-1) < 0) THEN CALL FMENTR('FMSQRT',MA,MA,1,1,M07,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) THEN CALL FMEQ(M07,MA) RETURN ENDIF ELSE NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMSQRT' CALL FMNTR(2,MA,MA,1,1) ENDIF NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN NAMEST(NCALL) = 'FMSQRT' KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,M07,KRESLT) CALL FMEQ(M07,MA) IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10)) ENDIF MA1 = MA(1) MACCA = MA(0) CALL FMEQ2(MA,M02,NDSAVE,NDIG) M02(0) = NINT(NDIG*ALOGM2) ! Generate the first approximation. M02(1) = 0 CALL FMM2DP(M02,X) X = SQRT(X) MKE = MA1/2 KMA1 = INT(ABS(MA1)) IF (MOD(KMA1,2) == 1) THEN XB = MBASE X = X*SQRT(XB) MKE = (MA1-1)/2 ENDIF CALL FMDPM(X,MA) MA(1) = MA(1) + MKE ! Initialize. M02(1) = MA1 CALL FMDIG(NSTACK,KST) ! Newton iteration. DO J = 1, KST NDIG = NSTACK(J) CALL FMDIV(M02,MA,M01) CALL FMADD_R1(MA,M01) CALL FMDIVI_R1(MA,2) ENDDO ! Round the result and return. IF (KASAVE == 1) THEN MD2B = NINT((NDSAVE-1)*ALOGM2+LOG(REAL(ABS(MA(2))+1))/0.69315) MA(0) = MIN(MACCA,MD2B) ELSE MA(0) = MACCA ENDIF MA(-1) = 1 DO J = -1, NDIG+1 M01(J) = MA(J) ENDDO CALL FMEXIT(M01,MA,NDSAVE,MXSAVE,KASAVE,0) RETURN END SUBROUTINE FMSQRT_R1 SUBROUTINE FMST2D(STRING,X) ! STRING contains a free-format number that is converted to double ! precision and returned in X. ! The input number may be in integer or any real format. ! The convention is made that if no digits appear before 'E' then 1.0 ! is assumed. For example 'E6' is converted as '1.0E+6'. USE FMVALS IMPLICIT NONE CHARACTER(*) :: STRING INTEGER J,JSTATE,KDIGFL,KEXP,KPT,KSIGN,KSIGNX,KSTART,KSTOP, & KTYPE,KVAL,N2 DOUBLE PRECISION X,F1,F2 INTEGER :: JTRANS(8,4) = RESHAPE( (/ & 2, 9, 9, 9, 9, 7, 9, 9, & 3, 3, 3, 5, 5, 8, 8, 8, & 4, 4, 4, 9, 9, 9, 9, 9, & 6, 6, 6, 6, 6, 9, 9, 9 /) & , (/ 8,4 /) ) CHARACTER :: KBLANK = ' ' JSTATE = 1 KSIGN = 1 F1 = 0.0D0 F2 = 0.0D0 N2 = 0 KSIGNX = 1 KEXP = 0 KSTART = 1 KSTOP = LEN(STRING) KFLAG = 0 ! KDIGFL will be 1 if any digits are found before 'E'. KDIGFL = 0 ! Initialize two hash tables that are used for character ! look-up during input conversion. IF (LHASH == 0) CALL FMHTBL ! Scan the number. DO J = KSTART, KSTOP IF (STRING(J:J) == KBLANK) CYCLE KPT = ICHAR(STRING(J:J)) IF (KPT < LHASH1 .OR. KPT > LHASH2) THEN WRITE (KW, & "(/' Error in input conversion.'/" // & "' ICHAR function was out of range for the current'," // & "' dimensions.'/' ICHAR(''',A,''') gave the value '," // & "I12,', which is outside the currently'/' dimensioned'," // & "' bounds of (',I5,':',I5,') for variables KHASHT '," // & "'and KHASHV.'/' Re-define the two parameters '," // & "'LHASH1 and LHASH2 so the dimensions will'/' contain'," // & "' all possible output values from ICHAR.'//)" & ) STRING(J:J),KPT,LHASH1,LHASH2 KTYPE = 5 KVAL = 0 ELSE KTYPE = KHASHT(KPT) KVAL = KHASHV(KPT) ENDIF IF (KTYPE >= 5) GO TO 110 JSTATE = JTRANS(JSTATE,KTYPE) SELECT CASE (JSTATE) ! State 2. Sign of the number. CASE (2) KSIGN = KVAL ! State 3. Digits before a decimal point. CASE (3) KDIGFL = 1 F1 = 10.0D0*F1 + KVAL ! State 4. Decimal point CASE (4) CYCLE ! State 5. Digits after a decimal point. CASE (5) KDIGFL = 1 F2 = 10.0D0*F2 + KVAL N2 = N2 + 1 ! State 6. Precision indicator. CASE (6) IF (KDIGFL == 0) F1 = 1.0D0 ! State 7. Sign of the exponent. CASE (7) KSIGNX = KVAL ! State 8. Digits of the exponent. CASE (8) KEXP = 10*KEXP + KVAL CASE DEFAULT GO TO 110 END SELECT ENDDO ! Form the number and return. KEXP = KSIGNX*KEXP X = KSIGN*(F1 + F2/10.0D0**N2)*10.0D0**KEXP RETURN ! Error in converting the number. 110 X = -1.0D+31 KFLAG = -4 RETURN END SUBROUTINE FMST2D SUBROUTINE FMST2M(STRING,MA) ! MA = STRING ! Convert a character string to FM format. ! This is often more convenient than using FMINP, which converts an ! array of CHARACTER*1 values. USE FMVALS IMPLICIT NONE CHARACTER(*) :: STRING REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER J,LB,KFSAVE IF (MBLOGS /= MBASE) CALL FMCONS NCALL = NCALL + 1 NAMEST(NCALL) = 'FMST2M' LB = MIN(LEN(STRING),LMBUFF) KFSAVE = KFLAG DO J = 1, LB CMBUFF(J) = STRING(J:J) ENDDO CALL FMINP(CMBUFF,MA,1,LB) IF (KFSAVE /= 0) KFLAG = KFSAVE NCALL = NCALL - 1 RETURN END SUBROUTINE FMST2M SUBROUTINE FMSUB(MA,MB,MC) ! MC = MA - MB USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) INTEGER KFLG1 NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMSUB ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1) KFLG1 = 0 IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1 IF (MB(2) == 0) KFLG1 = 0 ! FMADD2 will negate MB and add. KSUB = 1 CALL FMADD2(MA,MB,MC) KSUB = 0 ! If MA was smaller than MB, then KFLAG = 1 returned from ! FMADD means the result from FMSUB is the opposite of the ! input argument of larger magnitude, so reset KFLAG. IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0 IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1) ELSE KFLG1 = 0 IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1 IF (MB(2) == 0) KFLG1 = 0 KSUB = 1 CALL FMADD2(MA,MB,MC) KSUB = 0 IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0 ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMSUB SUBROUTINE FMSUB_R1(MA,MB) ! MA = MA - MB USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER KFLG1 NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMSUB ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1) KFLG1 = 0 IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1 IF (MB(2) == 0) KFLG1 = 0 ! FMADD2 will negate MB and add. KSUB = 1 CALL FMADD2_R1(MA,MB) KSUB = 0 ! If MA was smaller than MB, then KFLAG = 1 returned from ! FMADD means the result from FMSUB is the opposite of the ! input argument of larger magnitude, so reset KFLAG. IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0 IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1) ELSE KFLG1 = 0 IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1 IF (MB(2) == 0) KFLG1 = 0 KSUB = 1 CALL FMADD2_R1(MA,MB) KSUB = 0 IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0 ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMSUB_R1 SUBROUTINE FMSUB_R2(MA,MB) ! MB = MA - MB USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER KFLG1 NCALL = NCALL + 1 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'FMSUB ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1) KFLG1 = 0 IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1 IF (MB(2) == 0) KFLG1 = 0 ! FMADD2 will negate MB and add. KSUB = 1 CALL FMADD2_R2(MA,MB) KSUB = 0 ! If MA was smaller than MB, then KFLAG = 1 returned from ! FMADD means the result from FMSUB is the opposite of the ! input argument of larger magnitude, so reset KFLAG. IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0 IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) ELSE KFLG1 = 0 IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1 IF (MB(2) == 0) KFLG1 = 0 KSUB = 1 CALL FMADD2_R2(MA,MB) KSUB = 0 IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0 ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE FMSUB_R2 SUBROUTINE FMTAN(MA,MB) ! MB = TAN(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE INTEGER J,JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,NDSAVE,NDSV IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN CALL FMENTR('FMTAN ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMTAN ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF MACCA = MA(0) MAS = MA(-1) CALL FMEQ2(MA,MB,NDSAVE,NDIG) MB(0) = NINT(NDIG*ALOGM2) MB(-1) = 1 ! Reduce the argument, convert to radians if the input is ! in degrees, and evaluate the function. CALL FMRDC(MB,JSIN,JCOS,JSWAP) IF (MB(1) == MUNKNO) GO TO 110 IF (MB(2) == 0) THEN IF (JSWAP == 1) THEN KFLAG = -4 CALL FMWARN CALL FMST2M('UNKNOWN',MB) ENDIF GO TO 110 ENDIF IF (KRAD == 0) THEN IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN NDSV = NDIG NDIG = MIN(NDIG+2,NDG2MX) NCALL = NCALL + 1 NAMEST(NCALL) = 'NOEQ ' CALL FMPI(MPISAV) NCALL = NCALL - 1 NDIG = NDSV ENDIF CALL FMMPY_R1(MB,MPISAV) CALL FMDIVI_R1(MB,180) ENDIF IF (MB(1) /= MUNKNO) THEN IF (JSWAP == 0) THEN IF (MB(1) < 0) THEN CALL FMSIN2(MB,M09) CALL FMEQ(M09,MB) MB(-1) = JSIN*MB(-1) CALL FMSQR(MB,M03) CALL FMI2M(1,M02) CALL FMSUB_R2(M02,M03) CALL FMSQRT(M03,M04) M04(-1) = JCOS*M04(-1) CALL FMDIV_R1(MB,M04) ELSE CALL FMCOS2(MB,M09) CALL FMEQ(M09,MB) MB(-1) = JCOS*MB(-1) CALL FMSQR(MB,M03) CALL FMI2M(1,M02) CALL FMSUB_R2(M02,M03) CALL FMSQRT(M03,M04) M04(-1) = JSIN*M04(-1) CALL FMDIV_R2(M04,MB) ENDIF ELSE IF (MB(1) < 0) THEN CALL FMSIN2(MB,M09) CALL FMEQ(M09,MB) MB(-1) = JCOS*MB(-1) CALL FMSQR(MB,M03) CALL FMI2M(1,M02) CALL FMSUB_R2(M02,M03) CALL FMSQRT(M03,M04) M04(-1) = JSIN*M04(-1) CALL FMDIV_R2(M04,MB) ELSE CALL FMCOS2(MB,M09) CALL FMEQ(M09,MB) MB(-1) = JSIN*MB(-1) CALL FMSQR(MB,M03) CALL FMI2M(1,M02) CALL FMSUB_R2(M02,M03) CALL FMSQRT(M03,M04) M04(-1) = JCOS*M04(-1) CALL FMDIV_R1(MB,M04) ENDIF ENDIF ENDIF ! Round and return. 110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MACCA,MACMAX) IF (MAS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1) DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMTAN SUBROUTINE FMTANH(MA,MB) ! MB = TANH(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE INTEGER J,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE REAL X,XT IF (MBLOGS /= MBASE) CALL FMCONS IF (ABS(MA(1)) > MEXPAB) THEN CALL FMENTR('FMTANH',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, & KOVUN) IF (KRESLT /= 0) RETURN ELSE NCALL = NCALL + 1 NAMEST(NCALL) = 'FMTANH' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) KOVUN = 0 IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1 NDSAVE = NDIG IF (NCALL == 1) THEN K = MAX(NGRD52-1,2) NDIG = MAX(NDIG+K,2) IF (NDIG > NDG2MX) THEN KFLAG = -9 CALL FMWARN NDIG = NDSAVE KRESLT = 12 CALL FMRSLT(MA,MA,MB,KRESLT) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 ENDIF KWRNSV = KWARN KWARN = 0 MAS = MA(-1) MACCA = MA(0) CALL FMEQ2(MA,MB,NDSAVE,NDIG) IF (MA(2) == 0) THEN GO TO 110 ENDIF MB(0) = NINT(NDIG*ALOGM2) MB(-1) = 1 IF (MA(1) >= 1) THEN XT = REAL((NDIG+1)/2)*ALOGMB K = INT(LOG(XT)/ALOGMB) IF (MA(1) > K+1) THEN CALL FMI2M(1,MB) GO TO 110 ELSE X = REAL(MB(2)*MBASE+MB(3)+1)*REAL(MBASE)**INT(MB(1)-2) IF (X > XT+5.0) THEN CALL FMI2M(1,MB) GO TO 110 ENDIF ENDIF ENDIF IF (MB(1) == 0 .AND. NDIG < 50) THEN CALL FMEXP2(MB,M09) CALL FMEQ(M09,MB) CALL FMSQR_R1(MB) CALL FMI2M(1,M02) CALL FMSUB(MB,M02,M03) CALL FMADD_R2(MB,M02) CALL FMDIV(M03,M02,MB) GO TO 110 ENDIF IF (MB(1) >= 0 .AND. MB(2) /= 0) THEN CALL FMCOSH(MB,M13) CALL FMEQ(M13,MB) IF (MB(1) > NDIG) THEN IF (MAS > 0) THEN CALL FMI2M(1,MB) GO TO 110 ELSE CALL FMI2M(-1,MB) GO TO 110 ENDIF ENDIF CALL FMSQR(MB,M03) CALL FMI2M(-1,M02) CALL FMADD_R1(M03,M02) CALL FMSQRT_R1(M03) CALL FMDIV_R2(M03,MB) ELSE CALL FMSINH(MB,M13) CALL FMEQ(M13,MB) CALL FMSQR(MB,M03) CALL FMI2M(1,M02) CALL FMADD_R1(M03,M02) CALL FMSQRT_R1(M03) CALL FMDIV_R1(MB,M03) ENDIF ! Round and return. 110 KWARN = KWRNSV MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315) MB(0) = MIN(MB(0),MACCA,MACMAX) IF (MAS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1) DO J = -1, NDIG+1 M01(J) = MB(J) ENDDO CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN) RETURN END SUBROUTINE FMTANH SUBROUTINE FMTRAP(MA) ! If MA has overflowed or underflowed, replace it by the appropriate ! symbol. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) IF (NCALL <= 0) RETURN IF (MA(1) > MXEXP+1) THEN IF (MA(-1) > 0) THEN CALL FMIM(0,MA) MA(1) = MEXPOV MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) ELSE CALL FMIM(0,MA) MA(1) = MEXPOV MA(2) = 1 MA(-1) = -1 MA(0) = NINT(NDIG*ALOGM2) ENDIF KFLAG = -5 ENDIF IF (MA(1) < -MXEXP) THEN IF (MA(-1) > 0) THEN CALL FMIM(0,MA) MA(1) = MEXPUN MA(2) = 1 MA(0) = NINT(NDIG*ALOGM2) ELSE CALL FMIM(0,MA) MA(1) = MEXPUN MA(2) = 1 MA(-1) = -1 MA(0) = NINT(NDIG*ALOGM2) ENDIF KFLAG = -6 ENDIF RETURN END SUBROUTINE FMTRAP SUBROUTINE FMULP(MA,MB) ! MB = The value of one Unit in the Last Place of MA at the current ! base and precision. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MA1 INTEGER J,KWRNSV,N1 IF (MBLOGS /= MBASE) CALL FMCONS KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'FMULP ' IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1) MA1 = MA(1) N1 = NDIG + 1 DO J = 3, N1 MWA(J) = 0 ENDDO MWA(2) = 1 MWA(1) = MA(1) - NDIG + 1 IF (MA(2) == 0 .OR. MA(1) >= MEXPOV) THEN KFLAG = -4 IF (MA1 /= MUNKNO) CALL FMWARN CALL FMST2M('UNKNOWN',MB) ELSE KWRNSV = KWARN IF (MA1 == MEXPUN) KWARN = 0 IF (MA(-1) < 0) THEN CALL FMMOVE(MWA,MB) MB(-1) = 1 IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1 ELSE CALL FMMOVE(MWA,MB) MB(-1) = 1 ENDIF IF (KFLAG < 0) THEN NAMEST(NCALL) = 'FMULP ' CALL FMWARN ENDIF KWARN = KWRNSV ENDIF MB(0) = NINT(NDIG*ALOGM2) IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1) NCALL = NCALL - 1 RETURN END SUBROUTINE FMULP SUBROUTINE FMUNPK(MP,MA) ! MP is unpacked and the value returned in MA. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MP(-1:LPACK) INTEGER J,KP KP = 2 MA(-1) = MP(-1) MA(0) = MP(0) MA(1) = MP(1) MA(2) = AINT (ABS(MP(2))/MBASE) MA(3) = ABS(MP(2)) - MA(2)*MBASE IF (NDIG >= 4) THEN DO J = 4, NDIG, 2 KP = KP + 1 MA(J) = AINT (MP(KP)/MBASE) MA(J+1) = MP(KP) - MA(J)*MBASE ENDDO ENDIF IF (MOD(NDIG,2) == 1) THEN MA(NDIG+1) = AINT (MP(KP+1)/MBASE) ENDIF RETURN END SUBROUTINE FMUNPK SUBROUTINE FMVARS ! Write the values of the FM global variables in module FMVALS. USE FMVALS IMPLICIT NONE WRITE (KW,*) ' ' WRITE (KW,*) ' Current values of the FM global variables.' WRITE (KW,*) ' ' WRITE (KW,*) ' ALOGM2 = ',ALOGM2 WRITE (KW,*) ' ALOGMB = ',ALOGMB WRITE (KW,*) ' ALOGMT = ',ALOGMT WRITE (KW,*) ' ALOGMX = ',ALOGMX WRITE (KW,*) ' CMCHAR = ',CMCHAR WRITE (KW,*) ' DLOGEB = ',DLOGEB WRITE (KW,*) ' DLOGMB = ',DLOGMB WRITE (KW,*) ' DLOGPI = ',DLOGPI WRITE (KW,*) ' DLOGTN = ',DLOGTN WRITE (KW,*) ' DLOGTP = ',DLOGTP WRITE (KW,*) ' DLOGTW = ',DLOGTW WRITE (KW,*) ' DPEPS = ',DPEPS WRITE (KW,*) ' DPMAX = ',DPMAX WRITE (KW,*) ' DPPI = ',DPPI WRITE (KW,*) ' INTMAX = ',INTMAX WRITE (KW,*) ' IUNKNO = ',IUNKNO WRITE (KW,*) ' JFORM1 = ',JFORM1 WRITE (KW,*) ' JFORM2 = ',JFORM2 WRITE (KW,*) ' JFORMZ = ',JFORMZ WRITE (KW,*) ' JPRNTZ = ',JPRNTZ WRITE (KW,*) ' KACCSW = ',KACCSW WRITE (KW,*) ' KDEBUG = ',KDEBUG WRITE (KW,*) ' KESWCH = ',KESWCH WRITE (KW,*) ' KFLAG = ',KFLAG WRITE (KW,*) ' KPTIMP = ',KPTIMP WRITE (KW,*) ' KPTIMU = ',KPTIMU WRITE (KW,*) ' KRAD = ',KRAD WRITE (KW,*) ' KROUND = ',KROUND WRITE (KW,*) ' KRPERF = ',KRPERF WRITE (KW,*) ' KSUB = ',KSUB WRITE (KW,*) ' KSWIDE = ',KSWIDE WRITE (KW,*) ' KW = ',KW WRITE (KW,*) ' KWARN = ',KWARN WRITE (KW,*) ' LHASH = ',LHASH WRITE (KW,*) ' LHASH1 = ',LHASH1 WRITE (KW,*) ' LHASH2 = ',LHASH2 WRITE (KW,*) ' LJSUMS = ',LJSUMS WRITE (KW,*) ' LMBERN = ',LMBERN WRITE (KW,*) ' LMBUFF = ',LMBUFF WRITE (KW,*) ' LMBUFZ = ',LMBUFZ WRITE (KW,*) ' LMWA = ',LMWA WRITE (KW,*) ' LPACK = ',LPACK WRITE (KW,*) ' LPACKZ = ',LPACKZ WRITE (KW,*) ' LUNPCK = ',LUNPCK WRITE (KW,*) ' LUNPKZ = ',LUNPKZ WRITE (KW,*) ' LVLTRC = ',LVLTRC WRITE (KW,*) ' MAXINT = ',MAXINT WRITE (KW,*) ' MBASE = ',MBASE WRITE (KW,*) ' MBLOGS = ',MBLOGS WRITE (KW,*) ' MBS2PI = ',MBS2PI WRITE (KW,*) ' MBSBRN = ',MBSBRN WRITE (KW,*) ' MBSE = ',MBSE WRITE (KW,*) ' MBSEUL = ',MBSEUL WRITE (KW,*) ' MBSGAM = ',MBSGAM WRITE (KW,*) ' MBSLB = ',MBSLB WRITE (KW,*) ' MBSLI = ',MBSLI WRITE (KW,*) ' MBSPI = ',MBSPI WRITE (KW,*) ' MEXPAB = ',MEXPAB WRITE (KW,*) ' MEXPOV = ',MEXPOV WRITE (KW,*) ' MEXPUN = ',MEXPUN WRITE (KW,*) ' MUNKNO = ',MUNKNO WRITE (KW,*) ' MXBASE = ',MXBASE WRITE (KW,*) ' MXEXP = ',MXEXP WRITE (KW,*) ' MXEXP2 = ',MXEXP2 WRITE (KW,*) ' NBITS = ',NBITS WRITE (KW,*) ' NCALL = ',NCALL WRITE (KW,*) ' NDG2MX = ',NDG2MX WRITE (KW,*) ' NDG2PI = ',NDG2PI WRITE (KW,*) ' NDGEUL = ',NDGEUL WRITE (KW,*) ' NDGGAM = ',NDGGAM WRITE (KW,*) ' NDIG = ',NDIG WRITE (KW,*) ' NDIGE = ',NDIGE WRITE (KW,*) ' NDIGLB = ',NDIGLB WRITE (KW,*) ' NDIGLI = ',NDIGLI WRITE (KW,*) ' NDIGMX = ',NDIGMX WRITE (KW,*) ' NDIGPI = ',NDIGPI WRITE (KW,*) ' NGRD21 = ',NGRD21 WRITE (KW,*) ' NGRD22 = ',NGRD22 WRITE (KW,*) ' NGRD52 = ',NGRD52 WRITE (KW,*) ' NTRACE = ',NTRACE WRITE (KW,*) ' NUMBRN = ',NUMBRN WRITE (KW,*) ' NWDBRN = ',NWDBRN WRITE (KW,*) ' RUNKNO = ',RUNKNO WRITE (KW,*) ' SPMAX = ',SPMAX WRITE (KW,*) ' ' RETURN END SUBROUTINE FMVARS SUBROUTINE FMWARN ! Called by one of the FM routines to print a warning message ! if any error condition arises in that routine. USE FMVALS IMPLICIT NONE CHARACTER(6) :: NAME INTEGER NCS IF (KFLAG >= 0 .OR. NCALL /= 1 .OR. KWARN <= 0) RETURN NCS = NCALL NAME = NAMEST(NCALL) WRITE (KW, & "(/' Error of type KFLAG =',I3," // & "' in FM package in routine ',A6/)" & ) KFLAG,NAME 110 NCALL = NCALL - 1 IF (NCALL > 0) THEN NAME = NAMEST(NCALL) WRITE (KW,"( ' called from ',A6)") NAME GO TO 110 ENDIF IF (KFLAG == -1) THEN WRITE (KW,"(' NDIG must be between 2 and',I10/)") NDIGMX ELSE IF (KFLAG == -2) THEN WRITE (KW,"(' MBASE must be between 2 and',I10/)") INT(MXBASE) ELSE IF (KFLAG == -3) THEN WRITE (KW, & "(' An input argument is not a valid FM number.'," // & "' Its exponent is out of range.'/)" & ) WRITE (KW,"(' UNKNOWN has been returned.'/)") ELSE IF (KFLAG == -4 .OR. KFLAG == -7) THEN WRITE (KW,"(' Invalid input argument for this routine.'/)") WRITE (KW,"(' UNKNOWN has been returned.'/)") ELSE IF (KFLAG == -5) THEN WRITE (KW,"(' The result has overflowed.'/)") ELSE IF (KFLAG == -6) THEN WRITE (KW,"(' The result has underflowed.'/)") ELSE IF (KFLAG == -8 .AND. NAME == 'FMOUT ') THEN WRITE (KW, & "(' The result array is not big enough to hold the'," // & "' output character string'/' in the current format.'/" // & "' The result ''***...***'' has been returned.'/)" & ) ELSE IF (KFLAG == -8 .AND. NAME == 'FMREAD') THEN WRITE (KW, & "(' The CMBUFF array is not big enough to hold the'," // & "' input character string'/" // & "' UNKNOWN has been returned.'/)" & ) ELSE IF (KFLAG == -9) THEN WRITE (KW, & "(' Precision could not be raised enough to'" // & ",' provide all requested guard digits.'/)" & ) WRITE (KW, & "(I23,' digits were requested (NDIG).'/" // & "' Maximum number of digits currently available'," // & "' (NDG2MX) is',I7,'.'/)" & ) NDIG,NDG2MX WRITE (KW,"(' UNKNOWN has been returned.'/)") ELSE IF (KFLAG == -10) THEN IF (NAMEST(NCS) == 'FMM2SP') THEN WRITE (KW, & "(' An FM number was too small in magnitude to '," // & "'convert to single precision.'/)" & ) ELSE WRITE (KW, & "(' An FM number was too small in magnitude to '," // & "'convert to double precision.'/)" & ) ENDIF WRITE (KW,"(' Zero has been returned.'/)") ENDIF NCALL = NCS IF (KWARN >= 2) THEN STOP ENDIF RETURN END SUBROUTINE FMWARN SUBROUTINE FMWRIT(KWRITE,MA) ! Write MA on unit KWRITE. Multi-line numbers will have '&' as the ! last nonblank character on all but the last line. These numbers can ! then be read easily using FMREAD. USE FMVALS IMPLICIT NONE INTEGER KWRITE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER J,JF1SAV,JF2SAV,K,KSAVE,L,LAST,LB,ND,NDSAVE,NEXP NCALL = NCALL + 1 NAMEST(NCALL) = 'FMWRIT' NDSAVE = NDIG NDIG = MIN(NDG2MX,MAX(NDIG+NGRD52,2)) CALL FMEQ2(MA,M01,NDSAVE,NDIG) KSAVE = KFLAG ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1 IF (ND < 2) ND = 2 NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6 LB = MIN(ND+NEXP,LMBUFF) JF1SAV = JFORM1 JF2SAV = JFORM2 JFORM1 = 1 JFORM2 = ND + 6 CALL FMOUT(M01,CMBUFF,LB) KFLAG = KSAVE NDIG = NDSAVE JFORM1 = JF1SAV JFORM2 = JF2SAV LAST = LB + 1 DO J = 1, LB IF (CMBUFF(LAST-J) /= ' ' .OR. J == LB) THEN L = LAST - J IF (MOD(L,73) /= 0) THEN WRITE (KWRITE,"(4X,73A1,' &')") (CMBUFF(K),K=1,L) ELSE IF (L > 73) WRITE (KWRITE,"(4X,73A1,' &')") & (CMBUFF(K),K=1,L-73) WRITE (KWRITE,"(4X,73A1)") (CMBUFF(K),K=L-72,L) ENDIF NCALL = NCALL - 1 RETURN ENDIF ENDDO NCALL = NCALL - 1 RETURN END SUBROUTINE FMWRIT ! Here are the routines that work with packed FM numbers. All names ! are the same as unpacked versions with 'FM' replaced by 'FP'. ! To convert a program using the FM package from unpacked calls to ! packed calls make these changes to the program: ! '(-1:LUNPCK)' to '(-1:LPACK)' in dimensions. ! 'CALL FM' to 'CALL FP' ! 'FMCOMP' to 'FPCOMP'. ! This packed format is not available when using the FM, IM, or ZM ! derived types. SUBROUTINE FPABS(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMABS(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPABS SUBROUTINE FPACOS(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMACOS(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPACOS SUBROUTINE FPADD(MA,MB,MC) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMADD(MPA,MPB,MPC) CALL FMPACK(MPC,MC) RETURN END SUBROUTINE FPADD SUBROUTINE FPADD_R1(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMADD(MPA,MPB,MPC) CALL FMPACK(MPC,MA) RETURN END SUBROUTINE FPADD_R1 SUBROUTINE FPADD_R2(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMADD(MPA,MPB,MPC) CALL FMPACK(MPC,MB) RETURN END SUBROUTINE FPADD_R2 SUBROUTINE FPADDI(MA,L) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK) INTEGER L CALL FMUNPK(MA,MPA) CALL FMADDI(MPA,L) CALL FMPACK(MPA,MA) RETURN END SUBROUTINE FPADDI SUBROUTINE FPASIN(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMASIN(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPASIN SUBROUTINE FPATAN(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMATAN(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPATAN SUBROUTINE FPATN2(MA,MB,MC) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMATN2(MPA,MPB,MPC) CALL FMPACK(MPC,MC) RETURN END SUBROUTINE FPATN2 SUBROUTINE FPBIG(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMBIG(MPA) CALL FMPACK(MPA,MA) RETURN END SUBROUTINE FPBIG SUBROUTINE FPCHSH(MA,MB,MC) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMCHSH(MPA,MPB,MPC) CALL FMPACK(MPB,MB) CALL FMPACK(MPC,MC) RETURN END SUBROUTINE FPCHSH FUNCTION FPCOMP(MA,LREL,MB) USE FMVALS IMPLICIT NONE LOGICAL FPCOMP,FMCOMP CHARACTER(*) :: LREL REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) FPCOMP = FMCOMP(MPA,LREL,MPB) RETURN END FUNCTION FPCOMP SUBROUTINE FPCOS(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMCOS(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPCOS SUBROUTINE FPCOSH(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMCOSH(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPCOSH SUBROUTINE FPCSSN(MA,MB,MC) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMCSSN(MPA,MPB,MPC) CALL FMPACK(MPB,MB) CALL FMPACK(MPC,MC) RETURN END SUBROUTINE FPCSSN SUBROUTINE FPDIG(NSTACK,KST) USE FMVALS IMPLICIT NONE INTEGER NSTACK(19),KST CALL FMDIG(NSTACK,KST) RETURN END SUBROUTINE FPDIG SUBROUTINE FPDIM(MA,MB,MC) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMDIM(MPA,MPB,MPC) CALL FMPACK(MPC,MC) RETURN END SUBROUTINE FPDIM SUBROUTINE FPDIV(MA,MB,MC) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMDIV(MPA,MPB,MPC) CALL FMPACK(MPC,MC) RETURN END SUBROUTINE FPDIV SUBROUTINE FPDIV_R1(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMDIV(MPA,MPB,MPC) CALL FMPACK(MPC,MA) RETURN END SUBROUTINE FPDIV_R1 SUBROUTINE FPDIV_R2(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMDIV(MPA,MPB,MPC) CALL FMPACK(MPC,MB) RETURN END SUBROUTINE FPDIV_R2 SUBROUTINE FPDIVI(MA,IVAL,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) INTEGER IVAL CALL FMUNPK(MA,MPA) CALL FMDIVI(MPA,IVAL,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPDIVI SUBROUTINE FPDIVI_R1(MA,IVAL) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK) INTEGER IVAL CALL FMUNPK(MA,MPA) CALL FMDIVI(MPA,IVAL,MPB) CALL FMPACK(MPB,MA) RETURN END SUBROUTINE FPDIVI_R1 SUBROUTINE FPDP2M(X,MA) USE FMVALS IMPLICIT NONE DOUBLE PRECISION X REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMDP2M(X,MPA) CALL FMPACK(MPA,MA) RETURN END SUBROUTINE FPDP2M SUBROUTINE FPDPM(X,MA) USE FMVALS IMPLICIT NONE DOUBLE PRECISION X REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMDPM(X,MPA) CALL FMPACK(MPA,MA) RETURN END SUBROUTINE FPDPM SUBROUTINE FPEQ(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMEQ(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPEQ SUBROUTINE FPEQ2_R1(MA,NDA,NDB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK) INTEGER NDA,NDB INTEGER NDASAV,NDBSAV,NDGSAV NDASAV = NDA NDBSAV = NDB NDGSAV = NDIG NDIG = NDASAV CALL FMUNPK(MA,MPA) CALL FMEQ2_R1(MPA,NDASAV,NDBSAV) NDIG = NDBSAV CALL FMPACK(MPA,MA) NDA = NDASAV NDB = NDBSAV NDIG = NDGSAV RETURN END SUBROUTINE FPEQ2_R1 SUBROUTINE FPEQU(MA,MB,NDA,NDB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) INTEGER NDA,NDB INTEGER NDASAV,NDBSAV,NDGSAV NDASAV = NDA NDBSAV = NDB NDGSAV = NDIG NDIG = NDASAV CALL FMUNPK(MA,MPA) CALL FMEQ2_R1(MPA,NDASAV,NDBSAV) NDIG = NDBSAV CALL FMPACK(MPA,MB) NDA = NDASAV NDB = NDBSAV NDIG = NDGSAV RETURN END SUBROUTINE FPEQU SUBROUTINE FPEXP(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMEXP(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPEXP SUBROUTINE FPFLAG(K) USE FMVALS IMPLICIT NONE INTEGER K K = KFLAG RETURN END SUBROUTINE FPFLAG SUBROUTINE FPFORM(FORM,MA,STRING) USE FMVALS IMPLICIT NONE CHARACTER(*) :: FORM,STRING REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMFORM(FORM,MPA,STRING) RETURN END SUBROUTINE FPFORM SUBROUTINE FPFPRT(FORM,MA) USE FMVALS IMPLICIT NONE CHARACTER(*) :: FORM REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMFPRT(FORM,MPA) RETURN END SUBROUTINE FPFPRT SUBROUTINE FPI2M(IVAL,MA) USE FMVALS IMPLICIT NONE INTEGER IVAL REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMI2M(IVAL,MPA) CALL FMPACK(MPA,MA) RETURN END SUBROUTINE FPI2M SUBROUTINE FPINP(LINE,MA,LA,LB) USE FMVALS IMPLICIT NONE INTEGER LA,LB CHARACTER LINE(LB) REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMINP(LINE,MPA,LA,LB) CALL FMPACK(MPA,MA) RETURN END SUBROUTINE FPINP SUBROUTINE FPINT(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMINT(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPINT SUBROUTINE FPIPWR(MA,IVAL,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) INTEGER IVAL CALL FMUNPK(MA,MPA) CALL FMIPWR(MPA,IVAL,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPIPWR SUBROUTINE FPLG10(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMLG10(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPLG10 SUBROUTINE FPLN(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMLN(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPLN SUBROUTINE FPLNI(IVAL,MA) USE FMVALS IMPLICIT NONE INTEGER IVAL REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMLNI(IVAL,MPA) CALL FMPACK(MPA,MA) RETURN END SUBROUTINE FPLNI SUBROUTINE FPM2DP(MA,X) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK) DOUBLE PRECISION X CALL FMUNPK(MA,MPA) CALL FMM2DP(MPA,X) RETURN END SUBROUTINE FPM2DP SUBROUTINE FPM2I(MA,IVAL) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK) INTEGER IVAL CALL FMUNPK(MA,MPA) CALL FMM2I(MPA,IVAL) RETURN END SUBROUTINE FPM2I SUBROUTINE FPM2SP(MA,X) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK) REAL X CALL FMUNPK(MA,MPA) CALL FMM2SP(MPA,X) RETURN END SUBROUTINE FPM2SP SUBROUTINE FPMAX(MA,MB,MC) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMMAX(MPA,MPB,MPC) CALL FMPACK(MPC,MC) RETURN END SUBROUTINE FPMAX SUBROUTINE FPMIN(MA,MB,MC) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMMIN(MPA,MPB,MPC) CALL FMPACK(MPC,MC) RETURN END SUBROUTINE FPMIN SUBROUTINE FPMOD(MA,MB,MC) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMMOD(MPA,MPB,MPC) CALL FMPACK(MPC,MC) RETURN END SUBROUTINE FPMOD SUBROUTINE FPMPY(MA,MB,MC) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMMPY(MPA,MPB,MPC) CALL FMPACK(MPC,MC) RETURN END SUBROUTINE FPMPY SUBROUTINE FPMPY_R1(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMMPY(MPA,MPB,MPC) CALL FMPACK(MPC,MA) RETURN END SUBROUTINE FPMPY_R1 SUBROUTINE FPMPY_R2(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMMPY(MPA,MPB,MPC) CALL FMPACK(MPC,MB) RETURN END SUBROUTINE FPMPY_R2 SUBROUTINE FPMPYI(MA,IVAL,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) INTEGER IVAL CALL FMUNPK(MA,MPA) CALL FMMPYI(MPA,IVAL,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPMPYI SUBROUTINE FPMPYI_R1(MA,IVAL) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK) INTEGER IVAL CALL FMUNPK(MA,MPA) CALL FMMPYI(MPA,IVAL,MPB) CALL FMPACK(MPB,MA) RETURN END SUBROUTINE FPMPYI_R1 SUBROUTINE FPNINT(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMNINT(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPNINT SUBROUTINE FPOUT(MA,LINE,LB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK) INTEGER LB CHARACTER LINE(LB) CALL FMUNPK(MA,MPA) CALL FMOUT(MPA,LINE,LB) RETURN END SUBROUTINE FPOUT SUBROUTINE FPPI(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMPI(MPA) CALL FMPACK(MPA,MA) RETURN END SUBROUTINE FPPI SUBROUTINE FPPRNT(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMPRNT(MPA) RETURN END SUBROUTINE FPPRNT SUBROUTINE FPPWR(MA,MB,MC) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMPWR(MPA,MPB,MPC) CALL FMPACK(MPC,MC) RETURN END SUBROUTINE FPPWR SUBROUTINE FPREAD(KREAD,MA) USE FMVALS IMPLICIT NONE INTEGER KREAD REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMREAD(KREAD,MPA) CALL FMPACK(MPA,MA) RETURN END SUBROUTINE FPREAD SUBROUTINE FPRPWR(MA,KVAL,JVAL,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) INTEGER KVAL,JVAL CALL FMUNPK(MA,MPA) CALL FMRPWR(MPA,KVAL,JVAL,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPRPWR SUBROUTINE FPSET(NPREC) USE FMVALS IMPLICIT NONE INTEGER NPREC CALL FMSET(NPREC) RETURN END SUBROUTINE FPSET SUBROUTINE FPSETVAR(STRING) USE FMVALS IMPLICIT NONE CHARACTER(*) :: STRING CALL FMSETVAR(STRING) RETURN END SUBROUTINE FPSETVAR SUBROUTINE FPSIGN(MA,MB,MC) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMSIGN(MPA,MPB,MPC) CALL FMPACK(MPC,MC) RETURN END SUBROUTINE FPSIGN SUBROUTINE FPSIN(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMSIN(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPSIN SUBROUTINE FPSINH(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMSINH(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPSINH SUBROUTINE FPSP2M(X,MA) USE FMVALS IMPLICIT NONE REAL X REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMSP2M(X,MPA) CALL FMPACK(MPA,MA) RETURN END SUBROUTINE FPSP2M SUBROUTINE FPSQR(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMSQR(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPSQR SUBROUTINE FPSQR_R1(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMSQR(MPA,MPB) CALL FMPACK(MPB,MA) RETURN END SUBROUTINE FPSQR_R1 SUBROUTINE FPSQRT(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMSQRT(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPSQRT SUBROUTINE FPSQRT_R1(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMSQRT(MPA,MPB) CALL FMPACK(MPB,MA) RETURN END SUBROUTINE FPSQRT_R1 SUBROUTINE FPST2M(STRING,MA) USE FMVALS IMPLICIT NONE CHARACTER(*) :: STRING REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMST2M(STRING,MPA) CALL FMPACK(MPA,MA) RETURN END SUBROUTINE FPST2M SUBROUTINE FPSUB(MA,MB,MC) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMSUB(MPA,MPB,MPC) CALL FMPACK(MPC,MC) RETURN END SUBROUTINE FPSUB SUBROUTINE FPSUB_R1(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMSUB(MPA,MPB,MPC) CALL FMPACK(MPC,MA) RETURN END SUBROUTINE FPSUB_R1 SUBROUTINE FPSUB_R2(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMUNPK(MB,MPB) CALL FMSUB(MPA,MPB,MPC) CALL FMPACK(MPC,MB) RETURN END SUBROUTINE FPSUB_R2 SUBROUTINE FPTAN(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMTAN(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPTAN SUBROUTINE FPTANH(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMTANH(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPTANH SUBROUTINE FPULP(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMULP(MPA,MPB) CALL FMPACK(MPB,MB) RETURN END SUBROUTINE FPULP SUBROUTINE FPVARS CALL FMVARS RETURN END SUBROUTINE FPVARS SUBROUTINE FPWRIT(KWRITE,MA) USE FMVALS IMPLICIT NONE INTEGER KWRITE REAL (KIND(1.0D0)) :: MA(-1:LPACK) CALL FMUNPK(MA,MPA) CALL FMWRIT(KWRITE,MPA) RETURN END SUBROUTINE FPWRIT ! The IM routines perform integer multiple-precision arithmetic. SUBROUTINE IMABS(MA,MB) ! MB = ABS(MA) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER KWRNSV,NDSAVE NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMABS ',1,MA,MA) NDSAVE = NDIG IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMABS ' CALL IMNTR(2,MA,MA,1) ENDIF KFLAG = 0 KWRNSV = KWARN KWARN = 0 CALL IMEQ(MA,MB) MB(-1) = 1 KWARN = KWRNSV IF (NTRACE /= 0) CALL IMNTR(1,MB,MB,1) NCALL = NCALL - 1 NDIG = NDSAVE RETURN END SUBROUTINE IMABS SUBROUTINE IMADD(MA,MB,MC) ! MC = MA + MB USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) REAL (KIND(1.0D0)) :: MDA,MDAB,MDB INTEGER NDSAVE NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMADD ',2,MA,MB) NDSAVE = NDIG IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMADD ' CALL IMNTR(2,MA,MB,2) ENDIF KFLAG = 0 IF (MA(1) <= 2) THEN IF (MB(1) > 2 .OR. MA(1) < 0 .OR. MB(1) < 0) GO TO 110 IF (MA(1) <= 1) THEN MDA = MA(-1) * MA(2) ELSE MDA = MA(-1) * (MA(2)*MBASE + MA(3)) ENDIF IF (MB(1) <= 1) THEN MDB = MB(-1) * MB(2) ELSE MDB = MB(-1) * (MB(2)*MBASE + MB(3)) ENDIF MDAB = MDA + MDB IF (ABS(MDAB) < MBASE) THEN MC(0) = MIN(MA(0),MB(0)) MC(1) = 1 IF (MDAB == 0) MC(1) = 0 IF (MDAB < 0) THEN MC(2) = -MDAB MC(-1) = -1 ELSE MC(2) = MDAB MC(-1) = 1 ENDIF MC(3) = 0 IF (MDA == 0 .OR. MDB == 0) KFLAG = 1 GO TO 120 ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN MC(0) = MIN(MA(0),MB(0)) MC(1) = 2 IF (MDAB < 0) THEN MC(2) = AINT (-MDAB/MBASE) MC(3) = ABS(-MDAB - MBASE*MC(2)) MC(-1) = -1 ELSE MC(2) = AINT (MDAB/MBASE) MC(3) = ABS(MDAB - MBASE*MC(2)) MC(-1) = 1 ENDIF IF (MDA == 0 .OR. MDB == 0) KFLAG = 1 GO TO 120 ENDIF ENDIF ! Check for special cases. 110 IF (MA(1) > NDG2MX .OR. MB(1) > NDG2MX .OR. & MA(1) < 0 .OR. MB(1) < 0) THEN IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN CALL IMST2M('UNKNOWN',MC) KFLAG = -4 GO TO 130 ENDIF IF (MA(1) == MEXPOV) THEN IF (MA(-1) == MB(-1) .OR. MB(2) == 0) THEN MC(-1) = MA(-1) MC(0) = MA(0) MC(1) = MA(1) MC(2) = MA(2) MC(3) = MA(3) KFLAG = -5 GO TO 130 ELSE KFLAG = -4 NAMEST(NCALL) = 'IMADD ' CALL FMWARN CALL IMST2M('UNKNOWN',MC) GO TO 130 ENDIF ENDIF IF (MB(1) == MEXPOV) THEN IF (MB(-1) == MA(-1) .OR. MA(2) == 0) THEN MC(-1) = MB(-1) MC(0) = MB(0) MC(1) = MB(1) MC(2) = MB(2) MC(3) = MB(3) KFLAG = -5 GO TO 130 ELSE KFLAG = -4 NAMEST(NCALL) = 'IMADD ' CALL FMWARN CALL IMST2M('UNKNOWN',MC) GO TO 130 ENDIF ENDIF KFLAG = -4 NAMEST(NCALL) = 'IMADD ' CALL FMWARN CALL IMST2M('UNKNOWN',MC) GO TO 130 ENDIF CALL IMADD2(MA,MB,MC) 120 IF (MC(1) > NDIGMX) THEN IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN IF (MC(-1) > 0) THEN CALL IMST2M('OVERFLOW',MC) ELSE CALL IMST2M('-OVERFLOW',MC) ENDIF KFLAG = -5 NAMEST(NCALL) = 'IMADD ' CALL FMWARN ENDIF ENDIF 130 IF (MC(1) <= 1) MC(3) = 0 IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1) NCALL = NCALL - 1 NDIG = NDSAVE RETURN END SUBROUTINE IMADD SUBROUTINE IMADD2(MA,MB,MC) ! Internal addition routine. MC = MA + MB USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) REAL (KIND(1.0D0)) :: MAS,MBS INTEGER J,JCOMP,JSIGN,N1 IF (MBLOGS /= MBASE) CALL FMCONS IF (MA(2) == 0) THEN CALL IMEQ(MB,MC) KFLAG = 1 IF (KSUB == 1) THEN IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1) KFLAG = 0 ENDIF RETURN ENDIF IF (MB(2) == 0) THEN CALL IMEQ(MA,MC) KFLAG = 1 RETURN ENDIF KFLAG = 0 N1 = MAX(MA(1),MB(1)) + 1 ! JSIGN is the sign of the result of MA + MB. JSIGN = 1 MAS = MA(-1) MBS = MB(-1) IF (KSUB == 1) MBS = -MBS ! See which one is larger in absolute value. JCOMP = 2 IF (MA(1) > MB(1)) THEN JCOMP = 1 ELSE IF (MB(1) > MA(1)) THEN JCOMP = 3 ELSE DO J = 2, N1 IF (MA(J) > MB(J)) THEN JCOMP = 1 EXIT ENDIF IF (MB(J) > MA(J)) THEN JCOMP = 3 EXIT ENDIF ENDDO ENDIF IF (JCOMP < 3) THEN IF (MAS < 0) JSIGN = -1 IF (MAS*MBS > 0) THEN CALL IMADDP(MA,MB) ELSE CALL IMADDN(MA,MB) ENDIF ELSE IF (MBS < 0) JSIGN = -1 IF (MAS*MBS > 0) THEN CALL IMADDP(MB,MA) ELSE CALL IMADDN(MB,MA) ENDIF ENDIF ! Transfer to MC and fix the sign of the result. NDIG = MWA(1) IF (NDIG < 2) NDIG = 2 IF (NDIG > NDG2MX) NDIG = NDG2MX CALL FMMOVE(MWA,MC) MC(0) = NINT(NDIGMX*ALOGM2) MC(-1) = 1 IF (JSIGN < 0 .AND. MC(2) /= 0) MC(-1) = -1 IF (KFLAG < 0) THEN IF (KSUB == 1) THEN NAMEST(NCALL) = 'IMSUB ' ELSE NAMEST(NCALL) = 'IMADD ' ENDIF CALL FMWARN ENDIF RETURN END SUBROUTINE IMADD2 SUBROUTINE IMADDN(MA,MB) ! Internal addition routine. MWA = MA - MB ! The arguments are such that MA >= MB >= 0. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MK INTEGER J,K,KL,KP1,KP2,KPT,KSH,N1 IF (MA(1) == MEXPOV .OR. MB(1) == MEXPOV) THEN KFLAG = -4 MWA(1) = MUNKNO MWA(2) = 1 MWA(3) = 0 RETURN ENDIF N1 = MA(1) + 1 MK = MA(1) - MB(1) K = INT(MK) ! Subtract MB from MA. KP1 = MIN(N1,K+1) DO J = 1, KP1 MWA(J) = MA(J) ENDDO KP2 = K + 2 ! (Inner Loop) DO J = KP2, N1 MWA(J) = MA(J) - MB(J-K) ENDDO ! Normalize. Fix the sign of any negative digit. IF (K > 0) THEN DO J = N1, KP2, -1 IF (MWA(J) < 0) THEN MWA(J) = MWA(J) + MBASE MWA(J-1) = MWA(J-1) - 1 ENDIF ENDDO KPT = KP2 - 1 110 IF (MWA(KPT) < 0 .AND. KPT >= 3) THEN MWA(KPT) = MWA(KPT) + MBASE MWA(KPT-1) = MWA(KPT-1) - 1 KPT = KPT - 1 GO TO 110 ENDIF ELSE DO J = N1, 3, -1 IF (MWA(J) < 0) THEN MWA(J) = MWA(J) + MBASE MWA(J-1) = MWA(J-1) - 1 ENDIF ENDDO ENDIF ! Shift left if there are any leading zeros in the mantissa. DO J = 2, N1 IF (MWA(J) > 0) THEN KSH = J - 2 GO TO 120 ENDIF ENDDO MWA(1) = 0 MWA(3) = 0 RETURN 120 IF (KSH > 0) THEN KL = N1 - KSH DO J = 2, KL MWA(J) = MWA(J+KSH) ENDDO DO J = KL+1, N1 MWA(J) = 0 ENDDO MWA(1) = MWA(1) - KSH ENDIF RETURN END SUBROUTINE IMADDN SUBROUTINE IMADDP(MA,MB) ! Internal addition routine. MWA = MA + MB ! The arguments are such that MA >= MB >= 0. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MK INTEGER J,K,KP2,KPT,N1 N1 = MA(1) + 1 MK = MA(1) - MB(1) K = INT(MK) ! Add MA and MB. MWA(1) = MA(1) + 1 MWA(2) = 0 DO J = 2, K+1 MWA(J+1) = MA(J) ENDDO KP2 = K + 2 ! (Inner Loop) DO J = KP2, N1 MWA(J+1) = MA(J) + MB(J-K) ENDDO ! Normalize. Fix any digit not less than MBASE. IF (K > 0) THEN DO J = N1+1, KP2, -1 IF (MWA(J) >= MBASE) THEN MWA(J) = MWA(J) - MBASE MWA(J-1) = MWA(J-1) + 1 ENDIF ENDDO KPT = KP2 - 1 110 IF (MWA(KPT) >= MBASE .AND. KPT >= 3) THEN MWA(KPT) = MWA(KPT) - MBASE MWA(KPT-1) = MWA(KPT-1) + 1 KPT = KPT - 1 GO TO 110 ENDIF ELSE DO J = N1+1, 3, -1 IF (MWA(J) >= MBASE) THEN MWA(J) = MWA(J) - MBASE MWA(J-1) = MWA(J-1) + 1 ENDIF ENDDO ENDIF RETURN END SUBROUTINE IMADDP SUBROUTINE IMARGS(KROUTN,NARGS,MA,MB) ! Check the input arguments to a routine for special cases. ! KROUTN - Name of the subroutine that was called ! NARGS - The number of input arguments (1 or 2) ! MA - First input argument ! MB - Second input argument (if NARGS is 2) USE FMVALS IMPLICIT NONE CHARACTER(6) :: KROUTN REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER NARGS REAL (KIND(1.0D0)) :: MBS INTEGER J,KWRNSV,LAST KFLAG = -4 IF (MA(1) == MUNKNO) RETURN IF (NARGS == 2) THEN IF (MB(1) == MUNKNO) RETURN ENDIF IF (MBLOGS /= MBASE) CALL FMCONS KFLAG = 0 ! Check the validity of parameters. IF (NCALL > 1 .AND. KDEBUG == 0) RETURN NAMEST(NCALL) = KROUTN ! Check MBASE. IF (MBASE < 2 .OR. MBASE > MXBASE) THEN KFLAG = -2 CALL FMWARN MBS = MBASE IF (MBASE < 2) MBASE = 2 IF (MBASE > MXBASE) MBASE = MXBASE WRITE (KW, & "(' MBASE was',I10,'. It has been changed to',I10,'.')" & ) INT(MBS),INT(MBASE) CALL FMCONS RETURN ENDIF ! Check exponent range. IF (MA(1) > LUNPCK .OR. MA(1) < 0) THEN IF (ABS(MA(1)) /= MEXPOV .OR. ABS(MA(2)) /= 1) THEN KFLAG = -3 CALL FMWARN CALL IMST2M('UNKNOWN',MA) RETURN ENDIF ENDIF IF (NARGS == 2) THEN IF (MB(1) > LUNPCK .OR. MB(1) < 0) THEN IF (ABS(MB(1)) /= MEXPOV .OR. ABS(MB(2)) /= 1) THEN KFLAG = -3 CALL FMWARN CALL IMST2M('UNKNOWN',MB) RETURN ENDIF ENDIF ENDIF ! Check for properly normalized digits in the ! input arguments. IF (ABS(MA(1)-INT(MA(1))) /= 0) KFLAG = 1 IF (MA(2) <= (-1) .OR. MA(2) >= MBASE .OR. & ABS(MA(2)-INT(MA(2))) /= 0) KFLAG = 2 IF (KDEBUG == 0) GO TO 110 LAST = INT(MA(1)) + 1 IF (MA(1) > LUNPCK) LAST = 3 DO J = 3, LAST IF (MA(J) < 0 .OR. MA(J) >= MBASE .OR. & ABS(MA(J)-INT(MA(J))) /= 0) THEN KFLAG = J GO TO 110 ENDIF ENDDO 110 IF (KFLAG /= 0) THEN J = KFLAG KFLAG = -4 KWRNSV = KWARN IF (KWARN >= 2) KWARN = 1 CALL FMWARN KWARN = KWRNSV IF (KWARN >= 1) THEN WRITE (KW,*) ' First invalid array element: MA(', & J,') = ',MA(J) ENDIF CALL IMST2M('UNKNOWN',MA) IF (KWARN >= 2) THEN STOP ENDIF RETURN ENDIF IF (NARGS == 2) THEN IF (ABS(MB(1)-INT(MB(1))) /= 0) KFLAG = 1 IF (MB(2) <= (-1) .OR. MB(2) >= MBASE .OR. & ABS(MB(2)-INT(MB(2))) /= 0) KFLAG = 2 IF (KDEBUG == 0) GO TO 120 LAST = INT(MB(1)) + 1 IF (MB(1) > LUNPCK) LAST = 3 DO J = 3, LAST IF (MB(J) < 0 .OR. MB(J) >= MBASE .OR. & ABS(MB(J)-INT(MB(J))) /= 0) THEN KFLAG = J GO TO 120 ENDIF ENDDO 120 IF (KFLAG /= 0) THEN J = KFLAG KFLAG = -4 KWRNSV = KWARN IF (KWARN >= 2) KWARN = 1 CALL FMWARN KWARN = KWRNSV IF (KWARN >= 1) THEN WRITE (KW,*) ' First invalid array element: MB(', & J,') = ',MB(J) ENDIF CALL IMST2M('UNKNOWN',MB) IF (KWARN >= 2) THEN STOP ENDIF RETURN ENDIF ENDIF RETURN END SUBROUTINE IMARGS SUBROUTINE IMBIG(MA) ! MA = The biggest representable IM integer. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER J NCALL = NCALL + 1 NAMEST(NCALL) = 'IMBIG ' IF (MBLOGS /= MBASE) CALL FMCONS KFLAG = 0 DO J = 2, NDIGMX+1 MA(J) = MBASE - 1 ENDDO MA(1) = NDIGMX MA(0) = NINT(NDIGMX*ALOGM2) MA(-1) = 1 IF (NTRACE /= 0) CALL IMNTR(1,MA,MA,1) NCALL = NCALL - 1 RETURN END SUBROUTINE IMBIG FUNCTION IMCOMP(MA,LREL,MB) ! Logical comparison of FM numbers MA and MB. ! LREL is a CHARACTER description of the comparison to be done: ! LREL = 'EQ' returns IMCOMP = .TRUE. if MA == MB ! = 'NE', 'GE', 'GT', 'LE', 'LT' also work like a logical IF. ! = '==', '/=', '<', '<=', '>', '>=' may be used. ! Some compilers object to functions with side effects such as ! changing KFLAG or other module FMVALS variables. Blocks of ! code that modify these variables are identified by: ! C DELETE START ! ... ! C DELETE STOP ! These may be removed or commented out to produce a function without ! side effects. This disables trace printing in IMCOMP, and error ! codes are not returned in KFLAG. USE FMVALS IMPLICIT NONE LOGICAL IMCOMP CHARACTER(*) :: LREL CHARACTER(2) :: JREL REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER J,JCOMP,NDSAVE,NLAST,NTRSAV ! DELETE START NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMCOMP',2,MA,MB) NAMEST(NCALL) = 'IMCOMP' IF (NCALL <= LVLTRC .AND. ABS(NTRACE) >= 2) THEN WRITE (KW,"(' Input to IMCOMP')") NDSAVE = NDIG IF (NTRACE > 0) THEN CALL IMPRNT(MA) IF (INDEX('=/<>',LREL(1:1)) > 0) THEN WRITE (KW,"(8X,A)") LREL ELSE WRITE (KW,"(7X,'.',A,'.')") LREL ENDIF CALL IMPRNT(MB) ELSE NDIG = MAX(2,INT(MA(1))) IF (NDIG > NDG2MX) NDIG = 2 NTRSAV = NTRACE IF (NTRACE < -2) NTRACE = -2 CALL IMNTRJ(MA,NDIG) IF (INDEX('=/<>',LREL(1:1)) > 0) THEN WRITE (KW,"(8X,A)") LREL ELSE WRITE (KW,"(7X,'.',A,'.')") LREL ENDIF NDIG = MAX(2,INT(MB(1))) IF (NDIG > NDG2MX) NDIG = 2 CALL IMNTRJ(MB,NDIG) NTRACE = NTRSAV ENDIF NDIG = NDSAVE ENDIF ! DELETE STOP ! JCOMP will be 1 if MA > MB ! 2 if MA == MB ! 3 if MA < MB ! Check for special cases. JREL = LREL IF (LREL /= 'EQ' .AND. LREL /= 'NE' .AND. LREL /= 'LT' .AND. & LREL /= 'GT' .AND. LREL /= 'LE' .AND. LREL /= 'GE') THEN IF (LREL == 'eq' .OR. LREL == '==') THEN JREL = 'EQ' ELSE IF (LREL == 'ne' .OR. LREL == '/=') THEN JREL = 'NE' ELSE IF (LREL == 'lt' .OR. LREL == '<') THEN JREL = 'LT' ELSE IF (LREL == 'gt' .OR. LREL == '>') THEN JREL = 'GT' ELSE IF (LREL == 'le' .OR. LREL == '<=') THEN JREL = 'LE' ELSE IF (LREL == 'ge' .OR. LREL == '>=') THEN JREL = 'GE' ELSE IMCOMP = .FALSE. ! DELETE START KFLAG = -4 IF (NCALL /= 1 .OR. KWARN <= 0) GO TO 120 ! DELETE STOP IF (KWARN <= 0) GO TO 120 WRITE (KW, & "(/' Error of type KFLAG = -4 in FM package in'," // & "' routine IMCOMP'//1X,A,' is not one of the six'," // & "' recognized comparisons.'//' .FALSE. has been'," // & "' returned.'/)" & ) LREL IF (KWARN >= 2) THEN STOP ENDIF GO TO 120 ENDIF ENDIF IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN IMCOMP = .FALSE. ! DELETE START KFLAG = -4 ! DELETE STOP GO TO 120 ENDIF IF (ABS(MA(1)) == MEXPOV .AND. MA(1) == MB(1) .AND. & MA(2) == MB(2) .AND. MA(-1) == MB(-1)) THEN IMCOMP = .FALSE. ! DELETE START KFLAG = -4 IF (NCALL /= 1 .OR. KWARN <= 0) GO TO 120 ! DELETE STOP IF (KWARN <= 0) GO TO 120 WRITE (KW, & "(/' Error of type KFLAG = -4 in FM package in '," // & "'routine IMCOMP'//' Two numbers in the same '," // & "'overflow category cannot be compared.'//" // & "' .FALSE. has been returned.'/)" & ) IF (KWARN >= 2) THEN STOP ENDIF GO TO 120 ENDIF ! Check for zero. ! DELETE START KFLAG = 0 ! DELETE STOP IF (MA(2) == 0) THEN JCOMP = 2 IF (MB(2) == 0) GO TO 110 IF (MB(-1) < 0) JCOMP = 1 IF (MB(-1) > 0) JCOMP = 3 GO TO 110 ENDIF IF (MB(2) == 0) THEN JCOMP = 1 IF (MA(-1) < 0) JCOMP = 3 GO TO 110 ENDIF ! Check for opposite signs. IF (MA(-1) > 0 .AND. MB(-1) < 0) THEN JCOMP = 1 GO TO 110 ENDIF IF (MB(-1) > 0 .AND. MA(-1) < 0) THEN JCOMP = 3 GO TO 110 ENDIF ! See which one is larger in absolute value. IF (MA(1) > MB(1)) THEN JCOMP = 1 GO TO 110 ENDIF IF (MB(1) > MA(1)) THEN JCOMP = 3 GO TO 110 ENDIF NLAST = INT(MA(1)) + 1 IF (NLAST > NDG2MX+1) NLAST = 2 DO J = 2, NLAST IF (ABS(MA(J)) > ABS(MB(J))) THEN JCOMP = 1 GO TO 110 ENDIF IF (ABS(MB(J)) > ABS(MA(J))) THEN JCOMP = 3 GO TO 110 ENDIF ENDDO JCOMP = 2 ! Now match the JCOMP value to the requested comparison. 110 IF (JCOMP == 1 .AND. MA(-1) < 0) THEN JCOMP = 3 ELSE IF (JCOMP == 3 .AND. MB(-1) < 0) THEN JCOMP = 1 ENDIF IMCOMP = .FALSE. IF (JCOMP == 1 .AND. (JREL == 'GT' .OR. JREL == 'GE' .OR. & JREL == 'NE')) IMCOMP = .TRUE. IF (JCOMP == 2 .AND. (JREL == 'EQ' .OR. JREL == 'GE' .OR. & JREL == 'LE')) IMCOMP = .TRUE. IF (JCOMP == 3 .AND. (JREL == 'NE' .OR. JREL == 'LT' .OR. & JREL == 'LE')) IMCOMP = .TRUE. 120 CONTINUE ! DELETE START IF (NTRACE /= 0) THEN IF (NCALL <= LVLTRC .AND. ABS(NTRACE) >= 1) THEN IF (KFLAG == 0) THEN WRITE (KW, & "(' IMCOMP',15X,'Call level =',I2,5X," // & "'MBASE =',I10)" & ) NCALL,INT(MBASE) ELSE WRITE (KW, & "(' IMCOMP',6X,'Call level =',I2,4X," // & "'MBASE =',I10,4X,'KFLAG =',I3)" & ) NCALL,INT(MBASE),KFLAG ENDIF IF (IMCOMP) THEN WRITE (KW,"(7X,'.TRUE.')") ELSE WRITE (KW,"(7X,'.FALSE.')") ENDIF ENDIF ENDIF NCALL = NCALL - 1 ! DELETE STOP RETURN END FUNCTION IMCOMP SUBROUTINE IMDIM(MA,MB,MC) ! MC = DIM(MA,MB) ! Positive difference. MC = MA - MB if MA >= MB, ! = 0 otherwise. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) INTEGER KOVFL LOGICAL IMCOMP KFLAG = 0 NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMDIM ',2,MA,MB) IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMDIM ' CALL IMNTR(2,MA,MB,2) ENDIF IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN CALL IMST2M('UNKNOWN',MC) KFLAG = -4 GO TO 110 ENDIF IF (MA(1) < 0 .OR. MB(1) < 0) THEN KFLAG = -4 NAMEST(NCALL) = 'IMDIM ' CALL FMWARN CALL IMST2M('UNKNOWN',MC) GO TO 110 ENDIF KOVFL = 0 IF (MA(1) == MEXPOV .OR. MB(1) == MEXPOV) THEN KOVFL = 1 IF (MA(1) == MEXPOV .AND. MB(1) == MEXPOV .AND. & MA(2) == MB(2) .AND. MA(-1) == MB(-1)) THEN KFLAG = -4 NAMEST(NCALL) = 'IMDIM ' CALL FMWARN CALL IMST2M('UNKNOWN',MC) GO TO 110 ENDIF ENDIF IF (IMCOMP(MA,'GE',MB)) THEN CALL IMSUB(MA,MB,MC) IF (KFLAG == 1) KFLAG = 0 ELSE MC(1) = 0 MC(2) = 0 MC(3) = 0 MC(-1) = 1 MC(0) = NINT(NDG2MX*ALOGM2) ENDIF IF (MC(1) > NDIGMX) THEN IF (MC(1) == MUNKNO) THEN KFLAG = -4 NAMEST(NCALL) = 'IMDIM ' CALL FMWARN ELSE IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN IF (MC(-1) > 0) THEN CALL IMST2M('OVERFLOW',MC) ELSE CALL IMST2M('-OVERFLOW',MC) ENDIF KFLAG = -5 NAMEST(NCALL) = 'IMDIM ' IF (KOVFL /= 1) CALL FMWARN ENDIF ENDIF 110 IF (MC(1) <= 1) MC(3) = 0 IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN END SUBROUTINE IMDIM SUBROUTINE IMDIV(MA,MB,MC) ! MC = INT(MA/MB) ! Use IMDIVR if both INT(MA/MB) and MOD(MA,MB) are needed. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) INTEGER NDSAVE NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMDIV ',2,MA,MB) KFLAG = 0 NDSAVE = NDIG IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMDIV ' CALL IMNTR(2,MA,MB,2) ENDIF IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN CALL IMST2M('UNKNOWN',MC) KFLAG = -4 GO TO 110 ENDIF CALL IMDIVR(MA,MB,MC,M03) IF (MC(1) == MUNKNO) THEN KFLAG = -4 NAMEST(NCALL) = 'IMDIV ' CALL FMWARN ENDIF 110 IF (MC(1) <= 1) MC(3) = 0 IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1) NCALL = NCALL - 1 NDIG = NDSAVE RETURN END SUBROUTINE IMDIV SUBROUTINE IMDIVI(MA,IDIV,MB) ! MB = INT(MA/IDIV) ! Use IMDVIR if both INT(MA/IDIV) and MOD(MA,IDIV) are needed. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER IDIV,IREM,NDSAVE NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMDIVI',1,MA,MA) KFLAG = 0 NDSAVE = NDIG IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMDIVI' CALL IMNTR(2,MA,MA,1) CALL IMNTRI(2,IDIV,0) ENDIF IF (MA(1) == MUNKNO) THEN CALL IMST2M('UNKNOWN',MB) KFLAG = -4 GO TO 110 ENDIF CALL IMDVIR(MA,IDIV,MB,IREM) IF (MB(1) == MUNKNO) THEN KFLAG = -4 NAMEST(NCALL) = 'IMDIVI' CALL FMWARN ENDIF 110 IF (MB(1) <= 1) MB(3) = 0 IF (NTRACE /= 0) CALL IMNTR(1,MB,MB,1) NCALL = NCALL - 1 NDIG = NDSAVE RETURN END SUBROUTINE IMDIVI SUBROUTINE IMDIVR(MA,MB,MC,MD) ! MC = INT(MA / MB), MD = Remainder from the division. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK), & MD(-1:LUNPCK) REAL (KIND(1.0D0)) :: MDA,MDAB,MDB,MDR DOUBLE PRECISION XB,XBR,XBASE,XMWA REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MAXMWA,MB1, & MBM1,MBS,MCARRY,MKT,MLMAX,MQD INTEGER J,JB,JL,K,KA,KB,KL,KLTFLG,KPTMWA,LCRRCT,NA1,NB1, & NDSAVE,NGUARD,NL,NMBWDS,NTRSAV LOGICAL IMCOMP NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMDIVR',2,MA,MB) NDSAVE = NDIG IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMDIVR' CALL IMNTR(2,MA,MB,2) ENDIF KFLAG = 0 NTRSAV = NTRACE NTRACE = 0 IF (MBLOGS /= MBASE) CALL FMCONS ! Check for special cases. IF (MB(1) == 1 .AND. MA(1) /= MUNKNO) THEN IF (MB(-1)*MB(2) == 1) THEN CALL IMEQ(MA,MC) MD(1) = 0 MD(2) = 0 MD(3) = 0 MD(-1) = 1 MD(0) = NINT(NDG2MX*ALOGM2) GO TO 170 ELSE IF (MB(-1)*MB(2) == -1) THEN CALL IMEQ(MA,MC) IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1) MD(1) = 0 MD(2) = 0 MD(3) = 0 MD(-1) = 1 MD(0) = NINT(NDG2MX*ALOGM2) GO TO 170 ENDIF ENDIF IF (MA(1) < MB(1) .AND. MB(1) /= MUNKNO) GO TO 110 IF (MA(1) > NDG2MX .OR. MB(1) > NDG2MX .OR. & MA(1) < 0 .OR. MB(1) < 0 .OR. MB(2) == 0) THEN KFLAG = -4 IF (MA(1) /= MUNKNO .AND. MB(1) /= MUNKNO) THEN NAMEST(NCALL) = 'IMDIVR' CALL FMWARN ENDIF CALL IMST2M('UNKNOWN',MC) CALL IMST2M('UNKNOWN',MD) GO TO 170 ENDIF IF (MA(1) <= 2) THEN IF (MB(1) > 2) GO TO 110 IF (MB(2) == 0) GO TO 110 IF (MA(1) <= 1) THEN MDA = MA(-1) * MA(2) ELSE MDA = MA(-1) * (MA(2)*MBASE + MA(3)) ENDIF IF (MB(1) <= 1) THEN MDB = MB(-1) * MB(2) ELSE MDB = MB(-1) * (MB(2)*MBASE + MB(3)) ENDIF MDAB = AINT (MDA / MDB) MDR = MDA - MDAB*MDB IF (ABS(MDAB) < MBASE) THEN MC(0) = NINT(NDG2MX*ALOGM2) MC(1) = 1 IF (MDAB == 0) MC(1) = 0 IF (MDAB >= 0) THEN MC(2) = MDAB MC(-1) = 1 ELSE MC(2) = -MDAB MC(-1) = -1 ENDIF MC(3) = 0 ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN MC(0) = NINT(NDG2MX*ALOGM2) MC(1) = 2 IF (MDAB >= 0) THEN MC(2) = AINT (MDAB/MBASE) MC(3) = ABS(MDAB - MBASE*MC(2)) MC(-1) = 1 ELSE MC(2) = AINT (-MDAB/MBASE) MC(3) = ABS(-MDAB - MBASE*MC(2)) MC(-1) = -1 ENDIF ELSE GO TO 110 ENDIF IF (ABS(MDR) < MBASE) THEN MD(0) = MC(0) MD(1) = 1 IF (MDR == 0) MD(1) = 0 IF (MDR >= 0) THEN MD(2) = MDR MD(-1) = 1 ELSE MD(2) = -MDR MD(-1) = -1 ENDIF MD(3) = 0 GO TO 170 ELSE IF (ABS(MDR) < MBASE*MBASE) THEN MD(0) = MC(0) MD(1) = 2 IF (MDR >= 0) THEN MD(2) = AINT (MDR/MBASE) MD(3) = ABS(MDR - MBASE*MD(2)) MD(-1) = 1 ELSE MD(2) = AINT (-MDR/MBASE) MD(3) = ABS(-MDR - MBASE*MD(2)) MD(-1) = -1 ENDIF GO TO 170 ENDIF ENDIF 110 KLTFLG = 0 MAS = MA(-1) MBS = MB(-1) KL = INT(MB(1)) IF (KL > NDG2MX) KL = 2 DO J = 0, KL+1 M01(J) = MB(J) ENDDO M01(-1) = 1 IF (KL == 1) M01(3) = 0 IF (MA(1) == M01(1) .AND. ABS(MA(2)) <= M01(2)) THEN DO J = 2, KL+1 IF (MA(J) /= M01(J)) GO TO 120 ENDDO KLTFLG = 2 120 IF (KLTFLG == 0) THEN DO J = 2, KL+1 IF (MA(J) < M01(J)) THEN KLTFLG = 1 EXIT ELSE IF (MA(J) > M01(J)) THEN EXIT ENDIF ENDDO ENDIF ENDIF IF (MA(1) < MB(1) .OR. KLTFLG >= 1) THEN IF (KLTFLG /= 2) THEN CALL IMEQ(MA,MD) MD(-1) = ABS(MD(-1)) CALL IMI2M(0,MC) ELSE CALL IMI2M(1,MC) CALL IMI2M(0,MD) ENDIF GO TO 160 ENDIF NDIG = INT(MA(1)) IF (NDIG < 2) NDIG = 2 MACCA = MA(0) MACCB = MB(0) ! NGUARD is the number of guard digits used. NGUARD = 1 NA1 = INT(MA(1)) + 1 NB1 = INT(MB(1)) + 1 ! Copy MA into the working array. DO J = 3, NA1 MWA(J+1) = MA(J) ENDDO MWA(1) = MA(1) - MB(1) + 1 MWA(2) = 0 NL = NA1 + NGUARD + 3 DO J = NA1+2, NL MWA(J) = 0 ENDDO ! Save the sign of MA and MB and then work only with ! positive numbers. MAS = MA(-1) MB1 = MB(1) MBS = MB(-1) MWA(3) = MA(2) ! NMBWDS is the number of words of MB used to ! compute the estimated quotient digit MQD. NMBWDS = 4 IF (MBASE < 100) NMBWDS = 7 ! XB is an approximation of MB used in ! estimating the quotient digits. XBASE = DBLE(MBASE) XB = 0 JL = NMBWDS IF (JL <= NB1) THEN DO J = 2, JL XB = XB*XBASE + DBLE(MB(J)) ENDDO ELSE DO J = 2, JL IF (J <= NB1) THEN XB = XB*XBASE + DBLE(MB(J)) ELSE XB = XB*XBASE ENDIF ENDDO ENDIF IF (JL+1 <= NB1) XB = XB + DBLE(MB(JL+1))/XBASE XBR = 1.0D0/XB ! MLMAX determines when to normalize all of MWA. MBM1 = MBASE - 1 MLMAX = MAXINT/MBM1 MKT = INTMAX - MBASE MLMAX = MIN(MLMAX,MKT) ! MAXMWA is an upper bound on the size of values in MWA ! divided by MBASE-1. It is used to determine whether ! normalization can be postponed. MAXMWA = 0 ! KPTMWA points to the next digit in the quotient. KPTMWA = 2 ! This is the start of the division loop. ! XMWA is an approximation of the active part of MWA ! used in estimating quotient digits. 130 KL = KPTMWA + NMBWDS - 1 IF (KL <= NL) THEN XMWA = ((DBLE(MWA(KPTMWA))*XBASE & + DBLE(MWA(KPTMWA+1)))*XBASE & + DBLE(MWA(KPTMWA+2)))*XBASE & + DBLE(MWA(KPTMWA+3)) DO J = KPTMWA+4, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) ENDDO ELSE XMWA = DBLE(MWA(KPTMWA)) DO J = KPTMWA+1, KL IF (J <= NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) ELSE XMWA = XMWA*XBASE ENDIF ENDDO ENDIF ! MQD is the estimated quotient digit. MQD = AINT(XMWA*XBR) IF (MQD < 0) MQD = MQD - 1 IF (MQD > 0) THEN MAXMWA = MAXMWA + MQD ELSE MAXMWA = MAXMWA - MQD ENDIF ! See if MWA must be normalized. KA = KPTMWA + 1 KB = KA + INT(MB1) - 1 IF (MAXMWA >= MLMAX) THEN DO J = KB, KA, -1 IF (MWA(J) < 0) THEN MCARRY = INT((-MWA(J)-1)/MBASE) + 1 MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ELSE IF (MWA(J) >= MBASE) THEN MCARRY = -INT(MWA(J)/MBASE) MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ENDIF ENDDO XMWA = 0 IF (KL <= NL) THEN DO J = KPTMWA, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) ENDDO ELSE DO J = KPTMWA, KL IF (J <= NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) ELSE XMWA = XMWA*XBASE ENDIF ENDDO ENDIF MQD = AINT(XMWA*XBR) IF (MQD < 0) MQD = MQD - 1 IF (MQD > 0) THEN MAXMWA = MQD ELSE MAXMWA = -MQD ENDIF ENDIF ! Subtract MQD*MB from MWA. JB = KA - 2 IF (MQD /= 0) THEN ! Major (Inner Loop) DO J = KA, KB MWA(J) = MWA(J) - MQD*MB(J-JB) ENDDO ENDIF MWA(KA) = MWA(KA) + MWA(KA-1)*MBASE MWA(KPTMWA) = MQD KPTMWA = KPTMWA + 1 IF (KPTMWA-2 < MWA(1)) GO TO 130 ! Final normalization. KPTMWA = KPTMWA - 1 DO J = KPTMWA, 3, -1 IF (MWA(J) < 0) THEN MCARRY = INT((-MWA(J)-1)/MBASE) + 1 MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ELSE IF (MWA(J) >= MBASE) THEN MCARRY = -INT(MWA(J)/MBASE) MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ENDIF ENDDO LCRRCT = 0 140 DO J = KPTMWA+INT(MB1), KPTMWA+2, -1 IF (MWA(J) < 0) THEN MCARRY = INT((-MWA(J)-1)/MBASE) + 1 MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ELSE IF (MWA(J) >= MBASE) THEN MCARRY = -INT(MWA(J)/MBASE) MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ENDIF ENDDO ! Due to rounding, the remainder may not be between ! 0 and ABS(MB) here. Correct if necessary. IF (MWA(KA) < 0) THEN LCRRCT = LCRRCT - 1 DO J = KA, KB MWA(J) = MWA(J) + MB(J-JB) ENDDO GO TO 140 ELSE IF (MWA(KA) >= MBASE) THEN LCRRCT = LCRRCT + 1 DO J = KA, KB MWA(J) = MWA(J) - MB(J-JB) ENDDO GO TO 140 ENDIF IF (MWA(2) /= 0 .OR. KPTMWA == 2) THEN DO J = 1, INT(MWA(1))+1 MC(J) = MWA(J) ENDDO ELSE DO J = 3, INT(MWA(1))+1 MC(J-1) = MWA(J) ENDDO IF (MC(2) /= 0) THEN MC(1) = MWA(1) - 1 ELSE MC(1) = 0 ENDIF ENDIF IF (MC(1) <= 1) MC(3) = 0 MC(0) = MIN(MACCA,MACCB) MC(-1) = 1 IF (MWA(KPTMWA+1) /= 0) THEN DO J = 1, INT(MB1) MD(J+1) = MWA(KPTMWA+J) ENDDO MD(1) = MB1 ELSE DO J = 1, INT(MB1) IF (MWA(KPTMWA+J) /= 0) THEN DO K = J, INT(MB1) MD(K-J+2) = MWA(KPTMWA+K) ENDDO MD(1) = MB1 + 1 - J GO TO 150 ENDIF ENDDO MD(1) = 0 MD(2) = 0 ENDIF 150 IF (MD(1) <= 1) MD(3) = 0 MD(0) = MIN(MACCA,MACCB) MD(-1) = 1 ! If the remainder had to be corrected, make the ! corresponding adjustment in the quotient. IF (MD(1) > M01(1) .OR. & (MD(1) == M01(1) .AND. ABS(MD(2)) >= M01(2))) THEN IF (IMCOMP(MD,'GE',M01)) THEN CALL IMSUB(MD,M01,M10) CALL IMEQ(M10,MD) LCRRCT = LCRRCT + 1 ENDIF ENDIF IF (LCRRCT /= 0) THEN CALL IMI2M(LCRRCT,M02) CALL IMADD(M02,MC,M10) CALL IMEQ(M10,MC) ENDIF 160 MC(-1) = 1 MD(-1) = 1 IF (MAS < 0 .AND. MBS > 0) THEN IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1 IF (MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -1 ELSE IF (MAS > 0 .AND. MBS < 0) THEN IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1 ELSE IF (MAS < 0 .AND. MBS < 0) THEN IF (MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -1 ENDIF 170 IF (MC(1) <= 1) MC(3) = 0 IF (MD(1) <= 1) MD(3) = 0 NTRACE = NTRSAV IF (NTRACE /= 0) THEN CALL IMNTR(1,MC,MC,1) IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN IF (NTRACE < 0) THEN NDIG = MAX(2,INT(MD(1))) IF (NDIG > NDG2MX) NDIG = 2 NTRSAV = NTRACE IF (NTRACE < -2) NTRACE = -2 CALL IMNTRJ(MD,NDIG) NTRACE = NTRSAV ELSE CALL IMPRNT(MD) ENDIF ENDIF ENDIF NCALL = NCALL - 1 NDIG = NDSAVE RETURN END SUBROUTINE IMDIVR SUBROUTINE IMDVIR(MA,IDIV,MB,IREM) ! MB = INT(MA / IDIV), IREM = Remainder from the division. ! Division by a one word integer. The remainder is also a ! one word integer. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MAS,MDA,MDAB,MDB,MDR,MKT,MODINT,MVALP INTEGER IDIV,IREM,J,JDIV,KA,KL,KLTFLG,KPT,N1,NDSAVE, & NMVAL,NTRSAV,NV2 NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMDVIR',1,MA,MA) KFLAG = 0 NDSAVE = NDIG KLTFLG = 0 NTRSAV = NTRACE NTRACE = 0 MKT = ABS(IDIV) IF (MKT < MBASE) THEN M01(0) = MA(0) M01(1) = 1 M01(2) = ABS(IDIV) M01(-1) = 1 IF (IDIV < 0) M01(-1) = -1 M01(3) = 0 ELSE IF (MKT < MBASE*MBASE) THEN M01(0) = MA(0) M01(1) = 2 M01(2) = INT(MKT/MBASE) M01(3) = MKT - M01(2)*MBASE M01(-1) = 1 IF (IDIV < 0) M01(-1) = -1 ELSE CALL IMI2M(IDIV,M01) ENDIF NTRACE = NTRSAV IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMDVIR' CALL IMNTR(2,MA,MA,1) CALL IMNTRI(2,IDIV,0) ENDIF JDIV = ABS(IDIV) ! Check for special cases. IF (MA(1) < 0) THEN IREM = IUNKNO KFLAG = -4 NAMEST(NCALL) = 'IMDVIR' CALL FMWARN CALL IMST2M('UNKNOWN',MB) GO TO 150 ENDIF IF (JDIV == 1 .AND. MA(1) /= MUNKNO) THEN IF (IDIV == 1) THEN CALL IMEQ(MA,MB) IREM = 0 GO TO 150 ELSE CALL IMEQ(MA,MB) IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1) IREM = 0 GO TO 150 ENDIF ENDIF IF (MA(1) > NDG2MX .OR. IDIV == 0) THEN KFLAG = -4 IF (MA(1) /= MUNKNO) THEN NAMEST(NCALL) = 'IMDVIR' CALL FMWARN ENDIF CALL IMST2M('UNKNOWN',MB) IREM = IUNKNO GO TO 150 ENDIF IF (MA(1) <= 2) THEN IF (MA(1) <= 1) THEN MDA = MA(-1) * MA(2) ELSE MDA = MA(-1) * (MA(2)*MBASE + MA(3)) ENDIF MDB = IDIV MDAB = AINT (MDA/MDB) MDR = MDA - MDAB*MDB IF (ABS(MDAB) < MBASE) THEN MB(0) = MA(0) MB(1) = 1 IF (MDAB == 0) MB(1) = 0 IF (MDAB < 0) THEN MB(2) = -MDAB MB(-1) = -1 ELSE MB(2) = MDAB MB(-1) = 1 ENDIF MB(3) = 0 ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN MB(0) = MA(0) MB(1) = 2 IF (MDAB < 0) THEN MB(2) = AINT (-MDAB/MBASE) MB(3) = ABS(-MDAB - MBASE*MB(2)) MB(-1) = -1 ELSE MB(2) = AINT (MDAB/MBASE) MB(3) = ABS(MDAB - MBASE*MB(2)) MB(-1) = 1 ENDIF ELSE GO TO 110 ENDIF IREM = INT(MDR) GO TO 150 ENDIF 110 MAS = MA(-1) M01(-1) = 1 IF (MA(1) <= M01(1)) THEN IF (MA(1) == M01(1) .AND. ABS(MA(2)) <= M01(2)) THEN DO J = 2, KL+1 IF (MA(J) /= M01(J)) GO TO 120 ENDDO KLTFLG = 2 120 IF (KLTFLG == 0) THEN DO J = 2, KL+1 IF (MA(J) < M01(J)) THEN KLTFLG = 1 EXIT ENDIF ENDDO ENDIF ENDIF IF (MA(1) < M01(1) .OR. KLTFLG >= 1) THEN IF (KLTFLG /= 2) THEN CALL IMM2I(MA,IREM) IREM = ABS(IREM) CALL IMI2M(0,MB) ELSE CALL IMI2M(1,MB) IREM = 0 ENDIF GO TO 140 ENDIF ENDIF NDIG = INT(MA(1)) IF (NDIG < 2) NDIG = 2 N1 = INT(MA(1)) + 1 ! If ABS(IDIV) >= MXBASE use IMDIVR. MVALP = ABS(IDIV) NMVAL = INT(MVALP) NV2 = NMVAL - 1 IF (ABS(IDIV) > MXBASE .OR. NMVAL /= ABS(IDIV) .OR. & NV2 /= ABS(IDIV)-1) THEN CALL IMI2M(IDIV,M03) CALL IMDIVR(MA,M03,MB,M11) CALL IMEQ(M11,M03) CALL IMM2I(M03,IREM) GO TO 150 ENDIF ! Find the first significant digit of the quotient. MKT = MA(2) IF (MKT >= MVALP) THEN KPT = 2 GO TO 130 ENDIF DO J = 3, N1 MKT = MKT*MBASE + MA(J) IF (MKT >= MVALP) THEN KPT = J GO TO 130 ENDIF ENDDO CALL IMM2I(MA,IREM) CALL IMI2M(0,MB) GO TO 150 ! Do the rest of the division. 130 KA = KPT + 1 MWA(1) = MA(1) + 2 - KPT MWA(2) = INT (MKT/MVALP) MODINT = MKT - MWA(2)*MVALP IF (KA <= N1) THEN KL = 3 - KA ! (Inner Loop) DO J = KA, N1 MKT = MODINT*MBASE + MA(J) MWA(KL+J) = INT (MKT/MVALP) MODINT = MKT - MWA(KL+J)*MVALP ENDDO ENDIF MB(0) = MA(0) DO J = 1, INT(MWA(1))+1 MB(J) = MWA(J) ENDDO IREM = INT(MODINT) 140 MB(-1) = 1 IF (MAS < 0 .AND. IDIV > 0) THEN IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1 IREM = -IREM ELSE IF (MAS > 0 .AND. IDIV < 0) THEN IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1 ELSE IF (MAS < 0 .AND. IDIV < 0) THEN IREM = -IREM ENDIF 150 IF (MB(1) <= 1) MB(3) = 0 IF (NTRACE /= 0 .AND. NCALL <= LVLTRC) THEN CALL IMNTR(1,MB,MB,1) CALL IMNTRI(1,IREM,0) ENDIF NCALL = NCALL - 1 NDIG = NDSAVE RETURN END SUBROUTINE IMDVIR SUBROUTINE IMEQ(MA,MB) ! MB = MA USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER J,KDG KDG = MAX(2,INT(MA(1))) + 1 IF (KDG > LUNPCK) KDG = 3 DO J = -1, KDG MB(J) = MA(J) ENDDO RETURN END SUBROUTINE IMEQ SUBROUTINE IMFM2I(MA,MB) ! MB = INT(MA) ! Convert from real (FM) format to integer (IM) format. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER J,NTRSAV NCALL = NCALL + 1 KFLAG = 0 NTRSAV = NTRACE NTRACE = 0 CALL FMEQ(MA,MB) CALL FMINT(MB,M08) CALL FMEQ(M08,MB) IF (MB(1) > NDIGMX) THEN IF (MB(1) <= NDG2MX .OR. NCALL <= 1) THEN KFLAG = -4 NAMEST(NCALL) = 'IMFM2I' CALL FMWARN CALL IMST2M('UNKNOWN',MB) ENDIF ELSE DO J = NDIG+2, INT(MA(1))+1 MB(J) = 0 ENDDO ENDIF IF (MB(1) <= 1) MB(3) = 0 NTRACE = NTRSAV NCALL = NCALL - 1 RETURN END SUBROUTINE IMFM2I SUBROUTINE IMFORM(FORM,MA,STRING) ! Convert an IM number (MA) to a character string base 10 (STRING) ! using character string FORM format. ! FORM can be one of these types: Iw, Fw.d, Ew.d, 1PEw.d ! for positive integers w,d. USE FMVALS IMPLICIT NONE CHARACTER(*) :: FORM,STRING REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER NDSAVE NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMFORM',1,MA,MA) KFLAG = 0 NAMEST(NCALL) = 'IMFORM' NDSAVE = NDIG NDIG = INT(MA(1)) IF (NDIG < 2 .OR. NDIG > NDG2MX) NDIG = 2 CALL FMFORM(FORM,MA,STRING) NCALL = NCALL - 1 NDIG = NDSAVE RETURN END SUBROUTINE IMFORM SUBROUTINE IMFPRT(FORM,MA) ! Print an IM number (MA) on unit KW using character ! string FORM format. ! FORM can be one of these types: Iw, Fw.d, Ew.d, 1PEw.d ! for positive integers w,d. USE FMVALS IMPLICIT NONE CHARACTER(*) :: FORM REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER NDSAVE NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMFPRT',1,MA,MA) KFLAG = 0 NAMEST(NCALL) = 'IMFPRT' NDSAVE = NDIG NDIG = INT(MA(1)) IF (NDIG < 2 .OR. NDIG > NDG2MX) NDIG = 2 CALL FMFPRT(FORM,MA) NCALL = NCALL - 1 NDIG = NDSAVE RETURN END SUBROUTINE IMFPRT SUBROUTINE IMGCD(MA,MB,MC) ! MC is returned as the greatest common divisor of MA and MB. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) INTEGER NDSAVE NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMGCD ',2,MA,MB) KFLAG = 0 NDSAVE = NDIG IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMGCD ' CALL IMNTR(2,MA,MB,2) ENDIF ! Check for special cases. IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN CALL IMST2M('UNKNOWN',MC) KFLAG = -4 GO TO 120 ELSE IF (MB(2) == 0) THEN CALL IMABS(MA,MC) GO TO 120 ELSE IF (MA(2) == 0) THEN CALL IMABS(MB,MC) GO TO 120 ELSE IF (MB(1) == 1 .AND. ABS(MB(2)) == 1) THEN CALL IMI2M(1,MC) GO TO 120 ELSE IF (MA(1) == 1 .AND. ABS(MA(2)) == 1) THEN CALL IMI2M(1,MC) GO TO 120 ELSE IF (MA(1) >= NDG2MX .OR. MB(1) >= NDG2MX .OR. & MA(1) < 0 .OR. MB(1) < 0) THEN KFLAG = -4 NAMEST(NCALL) = 'IMGCD ' CALL FMWARN CALL IMST2M('UNKNOWN',MC) GO TO 120 ENDIF CALL IMABS(MA,M05) CALL IMABS(MB,M04) CALL IMMAX(M05,M04,M03) CALL IMMIN(M05,M04,M11) CALL IMEQ(M11,M04) 110 CALL IMDIVR(M03,M04,MC,M05) IF (M05(2) /= 0) THEN CALL IMEQ(M04,M03) CALL IMEQ(M05,M04) GO TO 110 ENDIF CALL IMEQ(M04,MC) IF (MC(1) == MUNKNO) THEN KFLAG = -4 NAMEST(NCALL) = 'IMGCD ' CALL FMWARN ENDIF 120 IF (MC(1) <= 1) MC(3) = 0 IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1) NCALL = NCALL - 1 NDIG = NDSAVE RETURN END SUBROUTINE IMGCD SUBROUTINE IMI2FM(MA,MB) ! MB = MA ! Convert from integer (IM) format to real (FM) format. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER KDG NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMI2FM',1,MA,MA) KFLAG = 0 KDG = MAX(2,INT(MA(1))) IF (KDG > NDG2MX) KDG = 2 CALL FMEQU(MA,MB,KDG,NDIG) MB(0) = NINT(NDG2MX*ALOGM2) NCALL = NCALL - 1 RETURN END SUBROUTINE IMI2FM SUBROUTINE IMI2M(IVAL,MA) ! MA = IVAL ! Convert a one word integer to IM format. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER IVAL INTEGER NDSAVE NCALL = NCALL + 1 KFLAG = 0 NDSAVE = NDIG IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMI2M ' CALL IMNTRI(2,IVAL,1) NDIG = 4 CALL FMIM(IVAL,MA) IF (MA(1) > 4) THEN NDIG = NDIGMX CALL FMIM(IVAL,MA) ENDIF CALL IMNTR(1,MA,MA,1) ELSE NDIG = 4 CALL FMIM(IVAL,MA) IF (MA(1) > 4) THEN NDIG = NDIGMX CALL FMIM(IVAL,MA) ENDIF ENDIF IF (MA(1) <= 1) MA(3) = 0 NDIG = NDSAVE NCALL = NCALL - 1 RETURN END SUBROUTINE IMI2M SUBROUTINE IMINP(LINE,MA,LA,LB) ! Convert an array of characters to multiple precision integer format. ! LINE is an A1 character array of length LB to be converted ! to IM format and returned in MA. ! LA is a pointer telling the routine where in the array to begin ! the conversion. ! LB is a pointer to the last character of the field for that number. USE FMVALS IMPLICIT NONE INTEGER KFSAVE,NDSAVE,LA,LB CHARACTER LINE(LB) REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) NCALL = NCALL + 1 KFLAG = 0 NDSAVE = NDIG NAMEST(NCALL) = 'IMINP ' NDIG = NDIGMX CALL FMINP(LINE,MA,LA,LB) KFSAVE = KFLAG CALL FMINT(MA,M08) CALL FMEQ(M08,MA) KFLAG = KFSAVE IF (MA(1) > NDG2MX .AND. MA(1) < MEXPOV) THEN KFLAG = -9 NDIG = INT(MA(1)) CALL FMWARN MA(-1) = 1 MA(0) = NINT(NDG2MX*ALOGM2) MA(1) = MUNKNO MA(2) = 1 MA(3) = 0 ENDIF IF (MA(1) <= 1) MA(3) = 0 NDIG = NDSAVE IF (NTRACE /= 0) CALL IMNTR(1,MA,MA,1) NCALL = NCALL - 1 RETURN END SUBROUTINE IMINP SUBROUTINE IMM2DP(MA,X) ! X = MA ! Convert an IM number to double precision. ! If KFLAG = -4 is returned for a value of MA that is in the range ! of the machine's double precision number system, change the ! definition of DPMAX in routine FMSET to reflect the current machine's ! range. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) DOUBLE PRECISION X INTEGER KRESLT,NDSAVE NCALL = NCALL + 1 KFLAG = 0 NAMEST(NCALL) = 'IMM2DP' KRESLT = 0 IF (ABS(MA(1)) > MEXPAB) THEN CALL FMARGS('IMM2DP',1,MA,MA,KRESLT) ENDIF IF (NTRACE /= 0) CALL IMNTR(2,MA,MA,1) IF (KRESLT /= 0) THEN ! Here no valid result can be returned. Set X to some ! value that the user is likely to recognize as wrong. X = DBLE(RUNKNO) KFLAG = -4 IF (MA(1) /= MUNKNO) CALL FMWARN IF (NTRACE /= 0) CALL IMNTRR(1,X,1) NCALL = NCALL - 1 RETURN ENDIF NDSAVE = NDIG NDIG = MAX(2,INT(MA(1))) IF (NDIG > NDG2MX) NDIG = 2 CALL FMMD(MA,X) IF (NTRACE /= 0) CALL IMNTRR(1,X,1) NDIG = NDSAVE NCALL = NCALL - 1 RETURN END SUBROUTINE IMM2DP SUBROUTINE IMM2I(MA,IVAL) ! IVAL = MA ! Convert an IM number to a one word integer. ! KFLAG = 0 is returned if the conversion is exact. ! = -4 is returned if MA is larger than INTMAX in magnitude. ! IVAL = IUNKNO is returned as an indication that IVAL ! could not be computed without integer overflow. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER IVAL,NDSAVE NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMM2I ',1,MA,MA) NDSAVE = NDIG IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMM2I ' CALL IMNTR(2,MA,MA,1) ENDIF NDIG = INT(MA(1)) IF (NDIG < 2) NDIG = 2 IF (NDIG > NDG2MX) NDIG = 2 KFLAG = 0 CALL FMM2I(MA,IVAL) IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN CALL IMNTRI(1,IVAL,1) ENDIF NCALL = NCALL - 1 NDIG = NDSAVE RETURN END SUBROUTINE IMM2I SUBROUTINE IMMAX(MA,MB,MC) ! MC = MAX(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) INTEGER KWRNSV LOGICAL IMCOMP KFLAG = 0 NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMMAX ',2,MA,MB) IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMMAX ' CALL IMNTR(2,MA,MB,2) ENDIF KWRNSV = KWARN KWARN = 0 IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN CALL IMST2M('UNKNOWN',MC) KFLAG = -4 ELSE IF (IMCOMP(MA,'LT',MB)) THEN CALL IMEQ(MB,MC) ELSE CALL IMEQ(MA,MC) ENDIF IF (MC(1) <= 1) MC(3) = 0 KWARN = KWRNSV IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN END SUBROUTINE IMMAX SUBROUTINE IMMIN(MA,MB,MC) ! MC = MIN(MA,MB) USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) INTEGER KWRNSV LOGICAL IMCOMP KFLAG = 0 NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMMIN ',2,MA,MB) IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMMIN ' CALL IMNTR(2,MA,MB,2) ENDIF KWRNSV = KWARN KWARN = 0 IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN CALL IMST2M('UNKNOWN',MC) KFLAG = -4 ELSE IF (IMCOMP(MA,'GT',MB)) THEN CALL IMEQ(MB,MC) ELSE CALL IMEQ(MA,MC) ENDIF IF (MC(1) <= 1) MC(3) = 0 KWARN = KWRNSV IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN END SUBROUTINE IMMIN SUBROUTINE IMMOD(MA,MB,MC) ! MC = MOD(MA,MB) ! Use IMDIVR if both INT(MA/MB) and MOD(MA,MB) are needed. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) INTEGER NDSAVE NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMMOD ',2,MA,MB) KFLAG = 0 NDSAVE = NDIG IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMMOD ' CALL IMNTR(2,MA,MB,2) ENDIF IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN CALL IMST2M('UNKNOWN',MC) KFLAG = -4 GO TO 110 ENDIF CALL IMDIVR(MA,MB,M03,MC) IF (MC(1) == MUNKNO) THEN KFLAG = -4 NAMEST(NCALL) = 'IMMOD ' CALL FMWARN ENDIF 110 IF (MC(1) <= 1) MC(3) = 0 IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1) NCALL = NCALL - 1 NDIG = NDSAVE RETURN END SUBROUTINE IMMOD SUBROUTINE IMMPY(MA,MB,MC) ! MC = MA * MB USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK) REAL (KIND(1.0D0)) :: MDAB INTEGER KOVFL,NDSAVE NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMMPY ',2,MA,MB) KFLAG = 0 NDSAVE = NDIG IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMMPY ' CALL IMNTR(2,MA,MB,2) ENDIF IF (MA(1) <= 1) THEN IF (MB(1) > 1) GO TO 110 MDAB = MA(-1) * MA(2) * MB(-1) * MB(2) IF (ABS(MDAB) < MBASE) THEN MC(0) = MIN(MA(0),MB(0)) MC(1) = 1 IF (MDAB == 0) MC(1) = 0 IF (MDAB >= 0) THEN MC(2) = MDAB MC(-1) = 1 ELSE MC(2) = -MDAB MC(-1) = -1 ENDIF MC(3) = 0 GO TO 120 ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN MC(0) = MIN(MA(0),MB(0)) MC(1) = 2 IF (MDAB >= 0) THEN MC(2) = AINT (MDAB/MBASE) MC(3) = ABS(MDAB - MBASE*MC(2)) MC(-1) = 1 ELSE MC(2) = AINT (-MDAB/MBASE) MC(3) = ABS(-MDAB - MBASE*MC(2)) MC(-1) = -1 ENDIF GO TO 120 ENDIF ENDIF ! Check for special cases. 110 KOVFL = 0 IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN KFLAG = -4 CALL IMST2M('UNKNOWN',MC) GO TO 130 ENDIF IF (MA(2) == 0 .OR. MB(2) == 0) THEN MC(-1) = 1 MC(0) = NINT(NDG2MX*ALOGM2) MC(1) = 0 MC(2) = 0 MC(3) = 0 GO TO 130 ENDIF IF (MA(1) == MEXPOV .OR. MB(1) == MEXPOV) THEN KOVFL = 1 KFLAG = -5 IF (MA(-1)*MB(-1) < 0) THEN CALL IMST2M('-OVERFLOW',MC) ELSE CALL IMST2M('OVERFLOW',MC) ENDIF GO TO 130 ENDIF IF (MA(1) < 0 .OR. MB(1) < 0) THEN KFLAG = -4 NAMEST(NCALL) = 'IMMPY ' CALL FMWARN CALL IMST2M('UNKNOWN',MC) GO TO 130 ENDIF IF (MB(1) == 1 .AND. MB(2) == 1 .AND. MB(-1) == 1) THEN CALL IMEQ(MA,MC) GO TO 120 ELSE IF (MB(1) == 1 .AND. MB(2) == 1 .AND. MB(-1) == -1) THEN CALL IMEQ(MA,MC) IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1) GO TO 120 ELSE IF (MA(1) == 1 .AND. MA(2) == 1 .AND. MA(-1) == 1) THEN CALL IMEQ(MB,MC) GO TO 120 ELSE IF (MA(1) == 1 .AND. MA(2) == 1 .AND. MA(-1) == -1) THEN CALL IMEQ(MB,MC) IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1) GO TO 120 ENDIF NDIG = INT(MA(1) + MB(1)) IF (NDIG > NDIGMX) THEN IF (NCALL == 1 .OR. NDIG > NDG2MX) THEN IF (MA(-1)*MB(-1) > 0) THEN CALL IMST2M('OVERFLOW',MC) ELSE CALL IMST2M('-OVERFLOW',MC) ENDIF KFLAG = -5 NAMEST(NCALL) = 'IMMPY ' CALL FMWARN GO TO 130 ENDIF ENDIF IF (NDIG < 2) NDIG = 2 IF (NDIG > NDG2MX) NDIG = NDG2MX CALL IMMPY2(MA,MB) ! Transfer to MC and fix the sign of the result. NDIG = MWA(1) IF (NDIG < 2) NDIG = 2 IF (NDIG > NDG2MX) NDIG = NDG2MX IF (MA(-1)*MB(-1) < 0) THEN CALL FMMOVE(MWA,MC) MC(0) = NINT(NDIGMX*ALOGM2) MC(-1) = -1 ELSE CALL FMMOVE(MWA,MC) MC(0) = NINT(NDIGMX*ALOGM2) MC(-1) = 1 ENDIF IF (NDIG > NDIGMX) NDIG = 2 120 IF (MC(1) > NDIGMX) THEN IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN IF (MC(-1) > 0) THEN CALL IMST2M('OVERFLOW',MC) ELSE CALL IMST2M('-OVERFLOW',MC) ENDIF KFLAG = -5 NAMEST(NCALL) = 'IMMPY ' IF (KOVFL /= 1) CALL FMWARN ENDIF ENDIF 130 IF (MC(1) <= 1) MC(3) = 0 IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1) NCALL = NCALL - 1 NDIG = NDSAVE RETURN END SUBROUTINE IMMPY SUBROUTINE IMMPY2(MA,MB) ! Internal multiplication of MA*MB. The result is returned in MWA. ! Both MA and MB are positive. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MAXMWA,MBJ,MBM1,MKT,MMAX INTEGER J,JM1,K,KB,KL,KLMA,KLMB,N1 N1 = NDIG + 1 MWA(1) = MA(1) + MB(1) MWA(N1+1) = 0 ! The multiplication loop begins here. ! MAXMWA is an upper bound on the size of values in MWA ! divided by (MBASE-1). It is used to determine ! whether to normalize before the next digit is ! multiplied. MBM1 = MBASE - 1 MMAX = INTMAX - MBASE MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX) MBJ = MB(2) MWA(2) = 0 KLMA = INT(MA(1)) DO K = KLMA+3, N1 MWA(K) = 0 ENDDO ! (Inner Loop) DO K = 2, KLMA+1 MWA(K+1) = MA(K)*MBJ ENDDO MAXMWA = MBJ KLMB = INT(MB(1)) DO J = 3, KLMB+1 MBJ = MB(J) IF (MBJ /= 0) THEN MAXMWA = MAXMWA + MBJ JM1 = J - 1 KL = KLMA + 1 ! Major (Inner Loop) DO K = J+1, J+KLMA MWA(K) = MWA(K) + MA(K-JM1)*MBJ ENDDO ENDIF IF (MAXMWA > MMAX) THEN MAXMWA = 0 ! Here normalization is only required for the ! range of digits currently changing in MWA. DO KB = JM1+KL, JM1+2, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE ENDDO ENDIF ENDDO ! Perform the final normalization. (Inner Loop) DO KB = N1, 3, -1 MKT = INT (MWA(KB)/MBASE) MWA(KB-1) = MWA(KB-1) + MKT MWA(KB) = MWA(KB) - MKT*MBASE ENDDO RETURN END SUBROUTINE IMMPY2 SUBROUTINE IMMPYI(MA,IVAL,MB) ! MB = MA * IVAL ! Multiplication by a one word integer. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) REAL (KIND(1.0D0)) :: MAS,MCARRY,MDAB,MKT,MVAL INTEGER IVAL,J,KA,KB,KC,KOVFL,KSHIFT,N1,NDSAVE,NMVAL, & NTRSAV,NV2 NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMMPYI',1,MA,MA) KFLAG = 0 NDSAVE = NDIG NTRSAV = NTRACE NTRACE = 0 NTRACE = NTRSAV IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMMPYI' CALL IMNTR(2,MA,MA,1) CALL IMNTRI(2,IVAL,0) ENDIF MAS = MA(-1) IF (MA(1) <= 1) THEN MDAB = MA(-1) * MA(2) * IVAL IF (ABS(MDAB) < MBASE) THEN MB(0) = MA(0) MB(1) = 1 IF (MDAB == 0) MB(1) = 0 MB(-1) = 1 IF (MDAB < 0) MB(-1) = -1 MB(2) = ABS(MDAB) MB(3) = 0 GO TO 120 ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN MB(0) = MA(0) MB(1) = 2 MB(-1) = 1 IF (MDAB < 0) MB(-1) = -1 MDAB = ABS(MDAB) MB(2) = AINT (MDAB/MBASE) MB(3) = MDAB - MBASE*MB(2) GO TO 120 ENDIF ENDIF ! Check for special cases. KOVFL = 0 IF (MA(1) == MEXPOV) KOVFL = 1 IF (MA(1) < 0) THEN KFLAG = -4 NAMEST(NCALL) = 'IMMPYI' CALL FMWARN CALL IMST2M('UNKNOWN',MB) GO TO 130 ENDIF IF (MA(1) == MUNKNO) THEN KFLAG = -4 CALL IMST2M('UNKNOWN',MB) GO TO 130 ELSE IF (IVAL == 0) THEN CALL IMI2M(0,MB) GO TO 120 ELSE IF (IVAL == 1) THEN CALL IMEQ(MA,MB) GO TO 120 ELSE IF (IVAL == -1) THEN CALL IMEQ(MA,MB) IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1) GO TO 120 ELSE IF (MA(1) == 1 .AND. MA(2)*MA(-1) == 1) THEN CALL IMI2M(IVAL,MB) GO TO 120 ELSE IF (MA(1) == 1 .AND. MA(2)*MA(-1) == -1) THEN CALL IMI2M(IVAL,MB) IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1) GO TO 120 ELSE IF (MA(1) == MEXPOV) THEN KFLAG = -5 CALL IMST2M('OVERFLOW',MB) GO TO 110 ENDIF ! Work with positive numbers. MVAL = ABS(IVAL) NMVAL = INT(MVAL) NV2 = NMVAL - 1 NDIG = INT(MA(1)) N1 = NDIG + 1 ! To leave room for normalization, shift the product ! to the right KSHIFT places in MWA. KSHIFT = INT((LOG(DBLE(MA(2)+1)*DBLE(MVAL)))/DLOGMB) ! If IVAL is too big, use IMMPY. IF (KSHIFT > NDIG .OR. MVAL > MAXINT/MBASE .OR. & NMVAL /= ABS(IVAL) .OR. NV2 /= ABS(IVAL)-1) THEN CALL IMI2M(IVAL,M01) CALL IMMPY(MA,M01,MB) GO TO 120 ENDIF MWA(1) = MA(1) + KSHIFT KA = 2 + KSHIFT KB = N1 + KSHIFT KC = NDIG + 5 DO J = KB, KC MWA(J) = 0 ENDDO MCARRY = 0 ! This is the main multiplication loop. DO J = KB, KA, -1 MKT = MA(J-KSHIFT)*MVAL + MCARRY MCARRY = INT (MKT/MBASE) MWA(J) = MKT - MCARRY*MBASE ENDDO ! Resolve the final carry. DO J = KA-1, 2, -1 MKT = INT (MCARRY/MBASE) MWA(J) = MCARRY - MKT*MBASE MCARRY = MKT ENDDO ! Now the first significant digit in the product is in ! MWA(2) or MWA(3). MB(0) = MA(0) IF (MWA(2) == 0) THEN MB(1) = MWA(1) - 1 DO J = 3, KB MB(J-1) = MWA(J) ENDDO ELSE MB(1) = MWA(1) DO J = 2, KB MB(J) = MWA(J) ENDDO ENDIF ! Put the sign on the result. 110 MB(-1) = 1 IF ((IVAL > 0 .AND. MAS < 0) .OR. (IVAL < 0 .AND.MAS > 0)) & MB(-1) = -1 120 IF (MB(1) > NDIGMX) THEN IF (NCALL == 1 .OR. MB(1) > NDG2MX) THEN IF (MB(-1) > 0) THEN CALL IMST2M('OVERFLOW',MB) ELSE CALL IMST2M('-OVERFLOW',MB) ENDIF KFLAG = -5 NAMEST(NCALL) = 'IMMPYI' IF (KOVFL /= 1) CALL FMWARN ENDIF ENDIF 130 IF (MB(1) <= 1) MB(3) = 0 IF (NTRACE /= 0) CALL IMNTR(1,MB,MB,1) NCALL = NCALL - 1 NDIG = NDSAVE RETURN END SUBROUTINE IMMPYI SUBROUTINE IMMPYM(MA,MB,MC,MD) ! MD = MA * MB mod MC ! This routine is slightly faster than calling IMMPY and IMMOD ! separately, and it works for cases where IMMPY would return ! OVERFLOW. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK), & MD(-1:LUNPCK) REAL (KIND(1.0D0)) :: MAS,MAXMWA,MBM1,MBS,MC1,MCARRY, & MDC,MDAB,MKT,MLMAX,MQD DOUBLE PRECISION XB,XBASE,XBR,XMWA INTEGER J,JB,JL,K,KA,KB,KL,KLTFLG,KPTMWA,N1,NA1,NC1,NDSAVE, & NGUARD,NL,NMCWDS,NTRSAV LOGICAL IMCOMP NCALL = NCALL + 1 IF (KDEBUG == 1) CALL IMARGS('IMMPYM',2,MA,MB) NDSAVE = NDIG KFLAG = 0 IF (NTRACE /= 0) THEN NAMEST(NCALL) = 'IMMPYM' CALL IMNTR(2,MA,MB,2) IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN IF (NTRACE < 0) THEN NDIG = MAX(2,INT(MC(1))) IF (NDIG > NDG2MX) NDIG = 2 NTRSAV = NTRACE IF (NTRACE < -2) NTRACE = -2 CALL IMNTRJ(MC,NDIG) NTRACE = NTRSAV NDIG = NDSAVE ELSE CALL IMPRNT(MC) ENDIF ENDIF ENDIF IF (MA(1) <= 1) THEN IF (MB(1) > 1) GO TO 110 IF (MA(1) < 0 .OR. MB(1) < 0) GO TO 110 MDAB = MA(-1) * MA(2) * MB(-1) * MB(2) IF (MC(1) <= 2) THEN IF (MC(2) == 0) GO TO 110 IF (MC(1) <= 1) THEN MDC = MC(-1) * MC(2) ELSE MDC = MC(-1) * (MC(2)*MBASE + MC(3)) ENDIF MDAB = MOD(MDAB,MDC) ENDIF IF (ABS(MDAB) < MBASE) THEN MD(0) = MIN(MA(0),MB(0),MC(0)) MD(1) = 1 IF (MDAB == 0) MD(1) = 0 MD(-1) = 1 IF (MDAB < 0) MD(-1) = -1 MD(2) = ABS(MDAB) MD(3) = 0 GO TO 160 ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN MD(0) = MIN(MA(0),MB(0),MC(0)) MD(1) = 2 MD(-1) = 1 IF (MDAB < 0) MD(-1) = -1 MDAB = ABS(MDAB) MD(2) = AINT (MDAB/MBASE) MD(3) = MDAB - MBASE*MD(2) GO TO 160 ENDIF ENDIF ! Check for special cases. 110 IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR. MC(1) == MUNKNO) THEN KFLAG = -4 CALL IMST2M('UNKNOWN',MD) GO TO 170 ELSE IF (MC(2) == 0 .OR. MA(1) < 0 .OR. MB(1) < 0 .OR. MC(1) < 0) THEN KFLAG = -4 NAMEST(NCALL) = 'IMMPYM' CALL FMWARN CALL IMST2M('UNKNOWN',MD) GO TO 170 ELSE IF (MA(2) == 0 .OR. MB(2) == 0) THEN CALL IMI2M(0,MD) GO TO 170 ELSE IF (MC(1) == 1 .AND. MC(2) == 1) THEN CALL IMI2M(0,MD) GO TO 170 ELSE IF (MB(1) == 1 .AND. MB(2) == 1 .AND. MB(-1) == 1) THEN CALL IMMOD(MA,MC,MD) GO TO 160 ELSE IF (MB(1) == 1 .AND. MB(2) == 1 .AND. MB(-1) == -1) THEN CALL IMMOD(MA,MC,MD) IF (MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -MD(-1) GO TO 160 ELSE IF (MA(1) == 1 .AND. MA(2) == 1 .AND. MA(-1) == 1) THEN CALL IMMOD(MB,MC,MD) GO TO 160 ELSE IF (MA(1) == 1 .AND. MA(2) == 1 .AND. MA(-1) == -1) THEN CALL IMMOD(MB,MC,MD) IF (MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -MD(-1) GO TO 160 ELSE IF (MA(1) > NDG2MX .OR. MB(1) > NDG2MX .OR. & MC(1) > NDG2MX) THEN KFLAG = -4 NAMEST(NCALL) = 'IMMPYM' CALL FMWARN CALL IMST2M('UNKNOWN',MD) GO TO 170 ENDIF NDIG = INT(MA(1) + MB(1)) IF (NDIG < 2) NDIG = 2 IF (NDIG > LMWA) NDIG = LMWA ! Save the sign of MA and MB and then work only with ! positive numbers. MAS = MA(-1) MBS = MB(-1) N1 = NDIG + 1 ! It is faster if the second argument is the one ! with fewer digits. IF (MA(1) < MB(1)) THEN CALL IMMPY2(MB,MA) ELSE CALL IMMPY2(MA,MB) ENDIF ! Now do the division to find MWA mod MC. KLTFLG = 0 IF (MWA(2) == 0) THEN MWA(1) = MWA(1) - 1 ELSE DO J = N1, 2, -1 MWA(J+1) = MWA(J) ENDDO MWA(2) = 0 ENDIF KL = INT(MC(1)) IF (KL > LMWA) KL = 2 DO J = -1, KL+1 M01(J) = MC(J) ENDDO M01(-1) = 1 IF (MWA(1) == M01(1) .AND. ABS(MWA(3)) <= M01(2)) THEN DO J = 4, N1 M02(J-1) = MWA(J) ENDDO M02(2) = ABS(MWA(3)) M02(1) = MWA(1) IF (IMCOMP(M02,'EQ',M01)) THEN KLTFLG = 2 ELSE IF (IMCOMP(M02,'LT',M01)) THEN KLTFLG = 1 ENDIF ENDIF IF (MWA(1) < MC(1) .OR. KLTFLG >= 1) THEN IF (KLTFLG /= 2) THEN DO J = 3, N1+1 MD(J-1) = MWA(J) ENDDO MD(1) = MWA(1) MD(0) = MIN(MA(0),MB(0),MC(0)) ELSE CALL IMI2M(0,MD) ENDIF GO TO 150 ENDIF NDIG = INT(MWA(1)) IF (NDIG < 2) NDIG = 2 ! NGUARD is the number of guard digits used. NGUARD = 1 NA1 = INT(MWA(1)) + 1 NC1 = INT(MC(1)) + 1 MWA(1) = MWA(1) - MC(1) + 1 NL = NA1 + NGUARD + 3 DO J = NA1+2, NL MWA(J) = 0 ENDDO ! Work only with positive numbers. MC1 = MC(1) ! NMCWDS is the number of words of MC used to ! compute the estimated quotient digit MQD. NMCWDS = 4 IF (MBASE < 100) NMCWDS = 7 ! XB is an approximation of MC used in ! estimating the quotient digits. XBASE = DBLE(MBASE) XB = 0 JL = NMCWDS IF (JL <= NC1) THEN DO J = 2, JL XB = XB*XBASE + DBLE(MC(J)) ENDDO ELSE DO J = 2, JL IF (J <= NC1) THEN XB = XB*XBASE + DBLE(MC(J)) ELSE XB = XB*XBASE ENDIF ENDDO ENDIF IF (JL+1 <= NC1) XB = XB + DBLE(MC(JL+1))/XBASE XBR = 1.0D0/XB ! MLMAX determines when to normalize all of MWA. MBM1 = MBASE - 1 MLMAX = MAXINT/MBM1 MKT = INTMAX - MBASE MLMAX = MIN(MLMAX,MKT) ! MAXMWA is an upper bound on the size of values in MWA ! divided by MBASE-1. It is used to determine whether ! normalization can be postponed. MAXMWA = 0 ! KPTMWA points to the next digit in the quotient. KPTMWA = 2 ! This is the start of the division loop. ! XMWA is an approximation of the active part of MWA ! used in estimating quotient digits. 120 KL = KPTMWA + NMCWDS - 1 IF (KL <= NL) THEN XMWA = ((DBLE(MWA(KPTMWA))*XBASE & + DBLE(MWA(KPTMWA+1)))*XBASE & + DBLE(MWA(KPTMWA+2)))*XBASE & + DBLE(MWA(KPTMWA+3)) DO J = KPTMWA+4, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) ENDDO ELSE XMWA = DBLE(MWA(KPTMWA)) DO J = KPTMWA+1, KL IF (J <= NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) ELSE XMWA = XMWA*XBASE ENDIF ENDDO ENDIF ! MQD is the estimated quotient digit. MQD = AINT(XMWA*XBR) IF (MQD < 0) MQD = MQD - 1 IF (MQD > 0) THEN MAXMWA = MAXMWA + MQD ELSE MAXMWA = MAXMWA - MQD ENDIF ! See if MWA must be normalized. KA = KPTMWA + 1 KB = KA + INT(MC1) - 1 IF (MAXMWA >= MLMAX) THEN DO J = KB, KA, -1 IF (MWA(J) < 0) THEN MCARRY = INT((-MWA(J)-1)/MBASE) + 1 MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ELSE IF (MWA(J) >= MBASE) THEN MCARRY = -INT(MWA(J)/MBASE) MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ENDIF ENDDO XMWA = 0 IF (KL <= NL) THEN DO J = KPTMWA, KL XMWA = XMWA*XBASE + DBLE(MWA(J)) ENDDO ELSE DO J = KPTMWA, KL IF (J <= NL) THEN XMWA = XMWA*XBASE + DBLE(MWA(J)) ELSE XMWA = XMWA*XBASE ENDIF ENDDO ENDIF MQD = AINT(XMWA*XBR) IF (MQD < 0) MQD = MQD - 1 IF (MQD > 0) THEN MAXMWA = MQD ELSE MAXMWA = -MQD ENDIF ENDIF ! Subtract MQD*MC from MWA. JB = KA - 2 IF (MQD /= 0) THEN ! Major (Inner Loop) DO J = KA, KB MWA(J) = MWA(J) - MQD*MC(J-JB) ENDDO ENDIF MWA(KA) = MWA(KA) + MWA(KA-1)*MBASE MWA(KPTMWA) = MQD KPTMWA = KPTMWA + 1 IF (KPTMWA-2 < MWA(1)) GO TO 120 ! Final normalization. KPTMWA = KPTMWA - 1 DO J = KPTMWA, 3, -1 IF (MWA(J) < 0) THEN MCARRY = INT((-MWA(J)-1)/MBASE) + 1 MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ELSE IF (MWA(J) >= MBASE) THEN MCARRY = -INT(MWA(J)/MBASE) MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ENDIF ENDDO 130 DO J = KPTMWA+INT(MC1), KPTMWA+2, -1 IF (MWA(J) < 0) THEN MCARRY = INT((-MWA(J)-1)/MBASE) + 1 MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ELSE IF (MWA(J) >= MBASE) THEN MCARRY = -INT(MWA(J)/MBASE) MWA(J) = MWA(J) + MCARRY*MBASE MWA(J-1) = MWA(J-1) - MCARRY ENDIF ENDDO ! Due to rounding, the remainder may not be between ! 0 and ABS(MC) here. Correct if necessary. IF (MWA(KA) < 0) THEN DO J = KA, KB MWA(J) = MWA(J) + MC(J-JB) ENDDO GO TO 130 ELSE IF (MWA(KA) >= MBASE) THEN DO J = KA, KB MWA(J) = MWA(J) - MC(J-JB) ENDDO GO TO 130 ENDIF IF (MWA(KPTMWA+1) /= 0) THEN DO J = 1, INT(MC1) MD(J+1) = MWA(KPTMWA+J) ENDDO MD(1) = MC1 ELSE DO J = 1, INT(MC1) IF (MWA(KPTMWA+J) /= 0) THEN DO K = J, INT(MC1) MD(K-J+2) = MWA(KPTMWA+K) ENDDO MD(1) = MC1 + 1 - J GO TO 140 ENDIF ENDDO MD(1) = 0 MD(2) = 0 ENDIF 140 IF (MD(1) <= 1) MD(3) = 0 MD(0) = MIN(MA(0),MB(0),MC(0)) IF (MD(1) > M01(1) .OR. & (MD(1) == M01(1) .AND. ABS(MD(2)) >= M01(2))) THEN MD(-1) = 1 IF (IMCOMP(MD,'GE',M01)) THEN CALL IMSUB(MD,M01,M10) CALL IMEQ(M10,MD) ENDIF ENDIF 150 MD(-1) = 1 IF (MAS*MBS < 0) THEN IF (MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -MD(-1) ENDIF IF (NDIG > NDIGMX) NDIG = 2 160 IF (MD(1) == MUNKNO) THEN KFLAG = -4 NAMEST(NCALL) = 'IMMPYM' CALL FMWARN ENDIF 170 IF (MD(1) <= 1) MD(3) = 0 IF (NTRACE /= 0) CALL IMNTR(1,MD,MD,1) NCALL = NCALL - 1 NDIG = NDSAVE RETURN END SUBROUTINE IMMPYM SUBROUTINE IMNTR(NTR,MA,MB,NARG) ! Print IM numbers in base 10 format. ! This is used for trace output from the IM routines. ! NTR = 1 if a result of an IM call is to be printed. ! = 2 to print input argument(s) to an IM call. ! MA - the IM number to be printed. ! MB - an optional second IM number to be printed. ! NARG - the number of arguments. NARG = 1 if only MA is to be ! printed, and NARG = 2 if both MA and MB are to be printed. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK) INTEGER NARG,NDSAVE,NTR,NTRSAV CHARACTER(6) :: NAME IF (NTRACE == 0) RETURN IF (NCALL > LVLTRC) RETURN IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN IF (NTR == 2) THEN NAME = NAMEST(NCALL) WRITE (KW,"(' Input to ',A6)") NAME ELSE NAME = NAMEST(NCALL) IF (KFLAG == 0) THEN WRITE (KW, & "(' ',A6,15X,'Call level =',I2,5X,'MBASE ='," // & "I10)" & ) NAME,NCALL,INT(MBASE) ELSE WRITE (KW, & "(' ',A6,6X,'Call level =',I2,4X,'MBASE ='," // & "I10,4X,'KFLAG =',I3)" & ) NAME,NCALL,INT(MBASE),KFLAG ENDIF ENDIF NDSAVE = NDIG IF (NTRACE < 0) THEN NDIG = MAX(2,INT(MA(1))) IF (NDIG > NDG2MX) NDIG = 2 NTRSAV = NTRACE IF (NTRACE < -2) NTRACE = -2 CALL IMNTRJ(MA,NDIG) IF (NARG == 2) THEN NDIG = MAX(2,INT(MB(1))) IF (NDIG > NDG2MX) NDIG = 2 CALL IMNTRJ(MB,NDIG) ENDIF NTRACE = NTRSAV ENDIF IF (NTRACE > 0) THEN CALL IMPRNT(MA) IF (NARG == 2) CALL IMPRNT(MB) ENDIF NDIG = NDSAVE RETURN END SUBROUTINE IMNTR SUBROUTINE IMNTRI(NTR,N,KNAM) ! Internal routine for trace output of integer variables. ! NTR = 1 for output values ! 2 for input values ! N Integer to be printed. ! KNAM is positive if the routine name is to be printed. USE FMVALS IMPLICIT NONE INTEGER NTR,N,KNAM CHARACTER(6) :: NAME IF (NTRACE == 0) RETURN IF (NCALL > LVLTRC) RETURN IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN IF (NTR == 2 .AND. KNAM > 0) THEN NAME = NAMEST(NCALL) WRITE (KW,"(' Input to ',A6)") NAME ENDIF IF (NTR == 1 .AND. KNAM > 0) THEN NAME = NAMEST(NCALL) IF (KFLAG == 0) THEN WRITE (KW,"(' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10)") & NAME,NCALL,INT(MBASE) ELSE WRITE (KW, & "(' ',A6,6X,'Call level =',I2,4X,'MBASE ='," // & "I10,4X,'KFLAG =',I3)" & ) NAME,NCALL,INT(MBASE),KFLAG ENDIF ENDIF WRITE (KW,"(1X,I18)") N RETURN END SUBROUTINE IMNTRI SUBROUTINE IMNTRJ(MA,ND) ! Print trace output in internal base MBASE format. The number to ! be printed is in MA. ! ND is the number of base MBASE digits to be printed. USE FMVALS IMPLICIT NONE REAL (KIND(1.0D0)) :: MA(-1:LUNPCK) INTEGER ND CHARACTER(50) :: FORM INTEGER J,L,N,N1 N1 = ND + 1 L = INT(LOG10(DBLE(MBASE-1))) + 2 N = (KSWIDE-23)/L IF (N > 10) N = 5*(N/5) IF (ND <= N) THEN WRITE (FORM,"(' (1X,I19,I',I2,',',I3,'I',I2,') ')") L+2, N-1, L ELSE WRITE (FORM, & "(' (1X,I19,I',I2,',',I3,'I',I2,'/(22X,',I3,'I',I2,')) ')" & ) L+2, N-1, L, N, L ENDIF IF (INT(MA(1)) >= 2) THEN WRITE (KW,FORM) INT(MA(1)),INT(MA(-1)*MA(2)),(INT(MA(J)),J=3,N1) ELSE WRITE (KW,FORM) INT(MA(1)),INT(MA(-1)*MA(2)),(0,J=3,N1) ENDIF RETURN END SUBROUTINE IMNTRJ SUBROUTINE IMNTRR(NTR,X,KNAM) ! Internal routine for trace output of real variables. ! NTR - 1 for output values ! 2 for input values ! X - Double precision value to be printed if NX == 1 ! KNAM - Positive if the routine name is to be printed. USE FMVALS IMPLICIT NONE INTEGER NTR,KNAM