C ALGORITHM 786, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 24,NO. 4, December, 1998, P. 359--367. #! /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: # Fortran90/ # Fortran90/Doc/ # Fortran90/Doc/Makefile # Fortran90/Doc/readme # Fortran90/Drivers/ # Fortran90/Drivers/Dp/ # Fortran90/Drivers/Dp/RES1 # Fortran90/Drivers/Dp/RES2 # Fortran90/Drivers/Dp/RES3 # Fortran90/Drivers/Dp/RES4 # Fortran90/Drivers/Dp/RES5 # Fortran90/Drivers/Dp/RES6 # Fortran90/Drivers/Dp/driver1.f90 # Fortran90/Drivers/Dp/driver2.f90 # Fortran90/Drivers/Dp/driver3.f90 # Fortran90/Drivers/Dp/driver4.f90 # Fortran90/Drivers/Dp/driver5.f90 # Fortran90/Drivers/Dp/driver6.f90 # Fortran90/Src/ # Fortran90/Src/Dp/ # Fortran90/Src/Dp/fmlib.f90 # Fortran90/Src/Dp/fmzm90.f90 # Fortran90/Src/Dp/fmzmcomm.f90 # Fortran90/Src/Dp/zmlib.f90 # This archive created: Thu Mar 25 10:55:09 1999 export PATH; PATH=/bin:$PATH if test ! -d 'Fortran90' then mkdir 'Fortran90' fi cd 'Fortran90' if test ! -d 'Doc' then mkdir 'Doc' fi cd 'Doc' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' # Define EPC F90 compiler and flags #FC = epcf90 #FFLAGS = -C -d1 -g -temp=/tmp -u #FFLAGS = -temp=/tmp -O # Define Nag f90 compiler and flags FC = f90 FFLAGS = -g # Define rule for .f to .o and .f90 to .o .SUFFIXES : .f .f90 .o .f.o: $(FC) $(FFLAGS) -c $< .f90.o: $(FC) $(FFLAGS) -c $< all: res1 res2 res3 res4 res5 res6 res1: zmlib.o fmlib.o driver1.o $(FC) $(FFLAGS) zmlib.o fmlib.o driver1.o -o driver1 driver1 > res1 res2: zmlib.o fmlib.o driver2.o $(FC) $(FFLAGS) zmlib.o fmlib.o driver2.o -o driver2 driver2 > res2 res3: fmlib.o driver3.o $(FC) $(FFLAGS) fmlib.o driver3.o -o driver3 driver3 > res3 res4: driver4.o fmlib.o $(FC) $(FFLAGS) driver4.o fmlib.o -o driver4 driver4 > res4 res5: fmzmcomm.o fmzm90.o fmlib.o zmlib.o driver5.o $(FC) $(FFLAGS) fmzmcomm.o fmzm90.o fmlib.o zmlib.o driver5.o -o driver5 driver5 > res5 res6: fmzmcomm.o fmzm90.o fmlib.o zmlib.o driver6.o $(FC) $(FFLAGS) fmzmcomm.o fmzm90.o fmlib.o zmlib.o driver6.o -o driver6 driver6 > res6 clean: rm -rf driver4 driver6 driver3 driver5 driver1 driver2 rm -rf *.o *.LOG res* SHAR_EOF fi # end of overwriting check 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.1 of FMLIB and ZMLIB. 1. zmlib.f90 Subroutine library for complex operations 2. fmlib.f90 Subroutine library for real operations 3. testzm.f90 Test program for most of the ZM routines 4. zmsample.f90 Small sample program using ZM 5. zmsample.chk Expected output file from zmsample.f90 6. testfm.f90 Test program for most of the FM routines 7. fmsample.f90 Small sample program using FM 8. fmsample.chk Expected output file from fmsample.f90 9. fmzm90.f90 Fortran-90 interface module 10. fmzmcomm.f90 Fortran-90 module for common blocks 11. Test90.f90 Test program for fmzm90 12. Sample90.f90 Small sample program using fmzm90 13. SAMPLE90.CHK Expected output file from sample90.f A makefile detailing the building of the ZM and FM libraries and the running of all the test examples is provided. My web site contains copies of other related papers and files. In 1998 it was located at "http://cse.eng.lmu.edu/~dsmith/FMLIB.html". If that location changes in the future, try searching for the keyword "dsmithfmlibrary" to find the site. =========================================================================== =========================================================================== 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 programs fmsample.f90, zmsample.f90, and sample90.f90 for some examples of initializing and using the package. This version of the package uses code with the names of routines, variables, and files in lower case, but in this file as well as in comment lines in the code such names are emphasized by writing them in upper case. INITIALIZATION: Before ANY part of the FM package can be used, the base and precision to be used must be defined, along with several other saved parameters. If any complex arithmetic is to be used, put CALL ZMSET(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. This will initialize both FMLIB and ZMLIB packages. If only real arithmetic is to be used, 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. This will initialize the FMLIB package. One of these calls must be present whether the FM/ZM routines are to be called directly by the user, or the Fortran-90 interface routines are to be used. For compatibility when the interface module is used, the derived type routine names FM_SET or ZM_SET may be used in place of FMSET or ZMSET. MODULE/COMMON: Some common blocks used for saved parameters must be declared in the main program. If the Fortran-90 interface is used, put USE FMZM at the beginning of the main program and also in each routine that uses type FM, IM, or ZM variables. If the Fortran-90 interface is not used, put the common blocks given in zmsample.f90 at the top of the main program if complex arithmetic is used, or put the common blocks given in fmsample.f90 at the top of the main program if only real arithmetic is 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 with 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) If fmlib.f90 is used without the interface module, then the multiple precision numbers are declared as arrays DOUBLE PRECISION A(0:LUNPCK),B(0:LUNPCK),C(0:LUNPCK) where LUNPCK is defined in the PARAMETER statement included with the FM common blocks. The numbers are then added by calling the FMLIB 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(0:LPACK),B(0:LPACK),C(0: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 or complex 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(0:LUNPCK),B(0:LUNPCK),C(0:LUNPCK) DOUBLE PRECISION X(0:LUNPKZ),Y(0:LUNPKZ),Z(0:LUNPKZ) ... CALL IMADD(A,B,C) ... CALL ZMADD(X,Y,Z) Packed format without the interface module: DOUBLE PRECISION A(0:LPACK),B(0:LPACK),C(0:LPACK) DOUBLE PRECISION X(0:LPACKZ),Y(0:LPACKZ),Z(0: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 the the interface routines assume that the precision chosen in the calling program (using FM_SET or ZM_SET) represents more significant digits than does the machine's double precision. All the functions defined in this module are standard Fortran-90 functions, except for several direct conversion 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, this module contains 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 =, +, -, *, /, **, .EQ., .NE., .GT., .GE., .LT., and .LE., 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).LT.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: = + - * / ** .EQ. .NE. .GT. .GE. .LT. .LE. 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 ------------------------------------------------------------------------ ----------- 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 each case it is permissible to use the same array more than once in the calling sequence. The statement MA = MA*MA can be written CALL FMMPY(MA,MA,MA). For each of these routines there is also a version available for which the argument list is the same but all FM numbers are in packed format. The routines using packed numbers have the same names except 'FM' is replaced by 'FP' at the start of each name. FMABS(MA,MB) MB = ABS(MA) FMACOS(MA,MB) MB = ACOS(MA) FMADD(MA,MB,MC) MC = MA + MB FMADDI(MA,IVAL) MA = MA + IVAL Increment an FM number by a one word integer. Note this call does not have an "MB" result like FMDIVI and FMMPYI. FMASIN(MA,MB) MB = ASIN(MA) FMATAN(MA,MB) MB = ATAN(MA) FMATN2(MA,MB,MC) MC = ATAN2(MA,MB) FMBIG(MA) MA = Biggest FM number less than overflow. FMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA). Faster than making two separate calls. FMCOMP(MA,LREL,MB) Logical comparison of MA and MB. LREL is a CHARACTER*2 value identifying which comparison is made. Example: IF (FMCOMP(MA,'GE',MB)) ... FMCONS Set several saved constants that depend on MBASE, the base being used. FMCONS should be called immediately after changing MBASE. FMCOS(MA,MB) MB = COS(MA) FMCOSH(MA,MB) MB = COSH(MA) FMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA). Faster than making two separate calls. FMDIG(NSTACK,KST) Find a set of precisions to use during Newton iteration for finding a simple root starting with about double precision accuracy. FMDIM(MA,MB,MC) MC = DIM(MA,MB) FMDIV(MA,MB,MC) MC = MA/MB FMDIVI(MA,IVAL,MB) MB = MA/IVAL IVAL is a one word integer. FMDP2M(X,MA) MA = X Convert from double precision to FM. FMDPM(X,MA) MA = X Convert from double precision to FM. Much 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 zero-padded if NB.GT.NA MB is rounded if NB.LT.NA FMEXP(MA,MB) MB = EXP(MA) FMFORM(FORM,MA,STRING) MA is converted to a character string using format FORM and returned in STRING. FORM can represent I, F, E, or 1PE formats. Example: CALL FMFORM('F60.40',MA,STRING) FMFPRT(FORM,MA) Print MA on unit KW using FORM format. FMI2M(IVAL,MA) MA = IVAL Convert from one word integer to FM. FMINP(LINE,MA,LA,LB) MA = LINE Input conversion. Convert LINE(LA) through LINE(LB) from characters to FM. FMINT(MA,MB) MB = INT(MA) Integer part of MA. FMIPWR(MA,IVAL,MB) MB = MA**IVAL Raise an FM number to a one word integer power. FMLG10(MA,MB) MB = LOG10(MA) FMLN(MA,MB) MB = LOG(MA) FMLNI(IVAL,MA) MA = LOG(IVAL) Natural log of a one word integer. FMM2DP(MA,X) X = MA Convert from FM to double precision. FMM2I(MA,IVAL) IVAL = MA Convert from FM to integer. FMM2SP(MA,X) X = MA Convert from FM to single precision. FMMAX(MA,MB,MC) MC = MAX(MA,MB) FMMIN(MA,MB,MC) MC = MIN(MA,MB) FMMOD(MA,MB,MC) MC = MA mod MB FMMPY(MA,MB,MC) MC = MA*MB FMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer. FMNINT(MA,MB) MB = NINT(MA) Nearest FM integer. FMOUT(MA,LINE,LB) LINE = MA Convert from FM to character. LINE is a character array of length LB. FMPI(MA) MA = pi FMPRNT(MA) Print MA on unit KW using current format. FMPWR(MA,MB,MC) MC = MA**MB 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 default values and machine-dependent variables to give at least NPREC base 10 digits plus three base 10 guard digits. Must be called to initialize FM package. FMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer. FMSIN(MA,MB) MB = SIN(MA) FMSINH(MA,MB) MB = SINH(MA) FMSP2M(X,MA) MA = X Convert from single precision to FM. FMSQR(MA,MB) MB = MA*MA Faster than FMMPY. FMSQRT(MA,MB) MB = SQRT(MA) FMST2M(STRING,MA) MA = STRING Convert from character string to FM. Often more convenient than FMINP, which converts an array of CHARACTER*1 values. Example: CALL FMST2M('123.4',MA). FMSUB(MA,MB,MC) MC = MA - MB FMTAN(MA,MB) MB = TAN(MA) FMTANH(MA,MB) MB = TANH(MA) FMULP(MA,MB) MB = One Unit in the Last Place of MA. 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. ------------------------------------------------------------------------ ----------------- 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 comparison is made. Example: IF (IMCOMP(MA,'GE',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. Many of the IM routines call FM routines, but none of the FM routines call IM routines, so the IM routines can be omitted if none are called explicitly from a program. ------------------------------------------------------------------------ ---------- Routines for Complex Floating-Point Operations ---------- These are the routines in ZMLIB that are designed to be called by the user. All are subroutines, and in each case the version of the routine to handle packed ZM numbers has the same name, with 'ZM' replaced by 'ZP'. MA, MB, MC refer to ZM format complex numbers. MAFM, MBFM, MCFM refer to FM format real numbers. INTEG is a Fortran INTEGER variable. ZVAL is a Fortran COMPLEX variable. In each case it is permissible to use the same array more than once in the calling sequence. The statement MA = MA*MA may be written CALL ZMMPY(MA,MA,MA). ZMABS(MA,MBFM) MBFM = ABS(MA) Result is real. ZMACOS(MA,MB) MB = ACOS(MA) ZMADD(MA,MB,MC) MC = MA + MB ZMADDI(MA,INTEG) MA = MA + INTEG Increment an ZM number by a one word integer. Note this call does not have an "MB" result like ZMDIVI and ZMMPYI. ZMARG(MA,MBFM) MBFM = Argument(MA) Result is real. ZMASIN(MA,MB) MB = ASIN(MA) ZMATAN(MA,MB) MB = ATAN(MA) ZMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA). Faster than 2 calls. ZMCMPX(MAFM,MBFM,MC) MC = CMPLX(MAFM,MBFM) ZMCONJ(MA,MB) MB = CONJG(MA) ZMCOS(MA,MB) MB = COS(MA) ZMCOSH(MA,MB) MB = COSH(MA) ZMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA). Faster than 2 calls. ZMDIV(MA,MB,MC) MC = MA / MB ZMDIVI(MA,INTEG,MB) MB = MA / INTEG ZMEQ(MA,MB) MB = MA ZMEQU(MA,MB,NDA,NDB) MB = MA Version for changing precision. (NDA and NDB are as in FMEQU) ZMEXP(MA,MB) MB = EXP(MA) ZMFORM(FORM1,FORM2,MA,STRING) STRING = MA MA is converted to a character string using format FORM1 for the real part and FORM2 for the imaginary part. The result is returned in STRING. FORM1 and FORM2 can represent I, F, E, or 1PE formats. Example: CALL ZMFORM('F20.10','F15.10',MA,STRING) 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 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) Initialize ZM package. Set precision to the equivalent of at least NPREC base 10 digits. 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 ------------------------------------------------------------------------ -------------------------- fmlib.f90 Notes --------------------------- The FM routines in this package perform floating-point multiple-precision arithmetic, and the IM routines perform integer multiple-precision arithmetic. 1. INITIALIZING THE PACKAGE Before calling any routine in the package, several variables in the common blocks /FMUSER/, /FM/, /FMBUFF/, and /FMSAVE/ must be initialized. These four common blocks contain information that is saved between calls, so they should be declared in the main program. Subroutine FMSET initializes these variables to default values and defines all machine-dependent values in the package. After calling FMSET once at the start of a program, the user may sometimes want to reset some of the variables in these common blocks. These variables are described below. 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 the PARAMETER statement at the top of each routine and is restricted only by the amount of memory available. Sometimes it is useful to dynamically vary NDIG during the program. Use FMEQU to round numbers to lower precision or zero-pad them to higher precision when changing NDIG. It is rare to need to change MBASE during a program. Use FMCONS to reset some saved constants that depend on MBASE. FMCONS should be called immediately after changing MBASE. There are two representations for a floating 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 easily 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) containing one digit of the mantissa, expressed in base MBASE. The array is dimensioned to start at MA(0), with the approximate number of bits of precision stored in MA(0). This precision value is intended to be used by FM functions that need to monitor cancellation error in addition and subtraction. The cancellation monitor code is usually disabled for user calls, and FM functions only check for cancellation when they must. Tracking cancellation causes most routines to run slower, with addition and subtraction being affected the most. The exponent is a power of MBASE and the implied radix point is immediately before the first digit of the mantissa. Every nonzero number is normalized so that the second array element (the first digit of the mantissa) is nonzero. In both representations the sign of the number is carried on the second array element only. Elements 3,4,... are always nonnegative. The exponent is a signed integer and may be as large in magnitude as MXEXP (defined in FMSET). For MBASE = 10,000 and NDIG = 4, the number -pi would have these representations: Word 1 2 3 4 5 Unpacked: 1 -3 1415 9265 3590 Packed: 1 -31415 92653590 Word 0 would be 42 in both formats, indicating that the mantissa has about 42 bits of precision. Because of normalization in a large base, the equivalent number of base 10 significant digits for an FM number may be as small as LOG10(MBASE)*(NDIG-1) + 1. The integer routines use the FMLIB 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. 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 common, so that a separate format definition does not have to be provided for each output call. The user sets JFORM1 and JFORM2 to determine the 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.EQ.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 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 printout except warnings and errors. = 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. 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 parameter 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. 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 NDIGMX in all the PARAMETER statements 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 FMSET are correct for the current machine. Zero was returned. 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 routine IMMPYM 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 PARAMETERS KRAD = 0 All angles in the trigonometric functions and inverse functions are measured in degrees. = 1 All angles are measured in radians. (Default) KROUND = 0 All final results are chopped (rounded toward zero). Intermediate results are rounded. = 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) 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. Default is for 'E7' to translate like '1.0E+7'. CMCHAR defines the exponent letter to be used for FM variable output. Default is 'M', as in 1.2345M+678. KDEBUG = 0 Error checking is not done for valid input arguments and parameters like NDIG and MBASE upon entry to each routine. (Default) = 1 Some error checking is done. (Slower speed) See FMSET 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 a PARAMETER statement at the top of each routine. The size of these arrays depends on the values of 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 FMLIB sets NDIGMX = 256, so on a 32-bit machine using MBASE = 10**7 the maximum precision is about 7*255+1 = 1786 significant digits. To change dimensions so that 10,000 significant digit calculation can be done, NDIGMX needs to be at least 10**4/7 + 5 = 1434. This allows for a few user guard digits to be defined when the package is initialized using CALL FMSET(10000). Changing 'NDIGMX = 256' to 'NDIGMX = 1434' everywhere in the package and the user's calling program 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 the formula 0.051*Log(MBASE)*NDIG**(1/3) + 1.85 For example, with MBASE=10**7 and NDIG=1434 this gives 11. Changing 'LJSUMS = 8*(LUNPCK+2)' to 'LJSUMS =11*(LUNPCK+2)' everywhere in the package and the user's calling program will give slightly better speed. FM numbers in packed format have dimension 0:LPACK, and those in unpacked format have dimension 0:LUNPCK. 8. PORTABILITY In FMSET there is some machine-dependent code that attempts to approximate the largest representable integer value. The current code works on all machines tested, but if an FM run fails, check the MAXINT and INTMAX loops in FMSET. Values for SPMAX and DPMAX are also defined in FMSET that should be set to values near overflow for single precision and double precision. Setting KDEBUG = 1 may also identify some errors if a run fails. Some compilers object to a function like FMCOMP with side effects such as changing KFLAG or other common variables. Blocks of code in FMCOMP and IMCOMP that modify common 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. All variables are explicitly declared in each routine. There is a commented IMPLICIT NONE statement in each routine that can be enabled to get more compiler diagnostic information in some testing or debugging situations. 9. NEW FOR VERSION 1.1 Version 1.0 used integer arrays and integer arithmetic internally to perform the multiple precision operations. Version 1.1 uses 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.1 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. Several routines have undergone minor modification, but only a few changes should affect programs that used FM 1.0. Many of the routines are faster in version 1.1, because code has been added to take advantage of special cases for individual functions instead of using general formulas that are more compact. For example, there are separate routines using series for SINH and COSH instead of just calling EXP. FMEQU was the only routine that required the user to give the value of the current precision. This was to allow automatic rounding or zero-padding when changing precision. Since few user calls change precision, a new routine has been added for this case. FMEQ now handles this case and has a simple argument list that does not include the value of NDIG. FMEQU is used for changing precision. See the list of FM routines above for details. All variable names beginning with M in the package are now declared as double precision, so FM common blocks in the user's program need D.P. declarations, and FM variables (arrays) used in the calling program need to be D.P. /FMUSER/ is a common block holding parameters that define the arithmetic to be used and other user options. Several new variables have been added, including screen width to be used for output. See above for further description. /FMSAVE/ is a common block for saving constants to avoid re-computing them. Several new variables have been added. /FMBUFF/ is a common block containing a character array used to format FM numbers for output. Two new items have been added. New routines: All the IM routines are new for version 1.1. FMADDI increments an FM number by a small integer. It runs in O(1) time, on the average. FMCHSH returns both SINH(MA) and COSH(MA). When both are needed, this is almost twice as fast as making separate calls to FMCOSH and FMSINH. FMCSSN returns both SIN(MA) and COS(MA). When both are needed, this is almost twice as fast as making separate calls to FMCOS and FMSIN. FMFORM uses a format string to convert an FM number to a character string. FMFPRT prints an FM number using a format string. FMREAD reads an FM number written using FMWRIT. FMRPWR computes an FM number raised to a rational power. For cube roots and similar rational powers it is usually much faster than FMPWR. FMSQR squares an FM number. It is faster than using FMMPY. FMST2M converts character strings to FM format. Since FMINP converts character arrays, this routine can be more convenient for easily defining an FM number. For example, CALL FMST2M('123.4',MA). FMWRIT writes an FM number using a format for multi-line numbers with '&' at the end of all but the last line of a multi-line number. This allows automatic reading of FM numbers without needing to know the base, precision or format under which they were written. One extra word has been added to the dimensions of all FM numbers. Word zero in each array contains a value used to monitor cancellation error arising from addition or subtraction. This value approximates the number of bits of precision for an FM value. It allows higher level FM functions to detect cases where too much cancellation has occurred. KACCSW is a switch variable in COMMON /FM/ used internally to enable cancellation error monitoring. 10. EFFICIENCY To take advantage of hardware architecture on different machines, the package has been designed so that the arithmetic used to perform the multiple precision operations can easily be changed. All variables that must be changed to get a different arithmetic have names beginning with 'M' and are declared using REAL (KIND(0.0D0)) :: m.... For example, to change the package to use integer arithmetic internally, make these two changes everywhere in the package: change 'REAL (KIND(0.0D0)) :: m' to 'INTEGER m', change 'DINT(' to 'INT('. On some systems, changing 'DINT(' to '(' may give better speed. When changing to a different type of arithmetic, all FM common blocks and arrays in the user's program must be changed to agree. In a few places in FM, where a DINT function is not supposed to be changed, it is spelled 'DINT (' so the global change will not find it. This version 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 usually run faster. This would usually not be much faster than using 10**7 with double precision. The value of NBITS defined as a parameter in most FM routines 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 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)'. ------------------------------------------------------------------------ -------------------------- zmlib.f90 Notes --------------------------- The ZM routines perform complex floating-point multiple-precision arithmetic. These routines use a Fortran 90 version of the FMLIB package (version 1.1) for real floating-point multiple-precision arithmetic. FMLIB is Algorithm 693, ACM Transactions on Mathematical Software, Vol. 17, No. 2, June 1991, pages 273-283. This package and FMLIB 1.1 use double precision arithmetic and arrays internally. This is usually faster at higher precision, and on many machines it is also faster at lower precision. Both packages are written so that the arithmetic used can easily be changed from double precision to integer, or another available arithmetic type. See the EFFICIENCY discussion in the fmlib.f90 Notes for details. 1. INITIALIZING THE PACKAGE Before calling any routine in the package, several variables in the common blocks /FMUSER/, /FM/, /FMSAVE/, /FMBUFF/, and /ZMUSER/ must be initialized. These common blocks contain information that is saved between calls, so they should be declared in the main program. Subroutine ZMSET initializes these variables to default values and defines all machine-dependent values in the package. After calling ZMSET once at the start of a program, the user may sometimes want to reset some of the variables in common blocks /FMUSER/ or /ZMUSER/. 2. REPRESENTATION OF ZM NUMBERS The format for complex FM numbers (called ZM numbers below) is very similar to that for real FM numbers in FMLIB. 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 ZM numbers. a. Conversion to or from a character array ZMINP converts from a character*1 array to an ZM number. ZMOUT converts an ZM 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 variables in common, so that a separate format definition does not have to be provided for each output call. For the output format of ZM numbers, JFORM1 and JFORM2 determine the format for the individual parts of a complex number as described in the FMLIB documentation. JFORMZ (in /ZMUSER/) 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 (in /ZMUSER/) 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 b. Conversion to or from a character string ZMST2M converts from a character string to an ZM number. ZMFORM converts an ZM number to a character string according to a format provided in each call. The format descriptions are more like that of a Fortran FORMAT statement, and integer or fixed-point output is right justified. c. Direct read or write ZMPRNT uses ZMOUT to print one ZM number. ZMFPRT uses ZMFORM to print one ZM number. ZMWRIT writes ZM numbers for later input using ZMREAD. ZMREAD reads ZM numbers written by ZMWRIT. For further description of these routines, see the list of ZM routines above. 4. ARRAY DIMENSIONS 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. =========================================================================== =========================================================================== SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'Drivers' then mkdir 'Drivers' fi cd 'Drivers' if test ! -d 'Dp' then mkdir 'Dp' fi cd 'Dp' if test -f 'RES1' then echo shar: will not over-write existing file "'RES1'" else cat << SHAR_EOF > 'RES1' 53 cases tested. No errors were found. SHAR_EOF fi # end of overwriting check if test -f 'RES2' then echo shar: will not over-write existing file "'RES2'" else cat << SHAR_EOF > 'RES2' Sample 1. Find a 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 2. 44 terms were added to get Exp(1.23-2.34i) Result= -2.379681796854777515745457977697 - 2.458032970832342652397461908326 i All results were ok. SHAR_EOF fi # end of overwriting check if test -f 'RES3' then echo shar: will not over-write existing file "'RES3'" else cat << SHAR_EOF > 'RES3' 108 cases tested. No errors were found. SHAR_EOF fi # end of overwriting check if test -f 'RES4' then echo shar: will not over-write existing file "'RES4'" else cat << SHAR_EOF > 'RES4' Sample 1. Find a 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. 109 terms were added Zeta(3) = 1.202056903159594285399738161511449990764986292340498881792272 Sample 3. 22 values were tested p = 1000000000000000000000000000000000000000000000000000000000000000659661 All results were ok. SHAR_EOF fi # end of overwriting check if test -f 'RES5' then echo shar: will not over-write existing file "'RES5'" else cat << SHAR_EOF > 'RES5' 603 cases tested. No errors were found. SHAR_EOF fi # end of overwriting check if test -f 'RES6' then echo shar: will not over-write existing file "'RES6'" else cat << SHAR_EOF > 'RES6' 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. 109 terms were added Zeta(3) = 1.202056903159594285399738161511449990764986292340498881792272 Sample 3. 22 values were tested p = 1000000000000000000000000000000000000000000000000000000000000000659661 Sample 4. 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 5. 44 terms were added to get Exp(1.23-2.34i) Result= -2.379681796854777515745457977697 - 2.458032970832342652397461908326 i All results were ok. SHAR_EOF fi # end of overwriting check if test -f 'driver1.f90' then echo shar: will not over-write existing file "'driver1.f90'" else cat << SHAR_EOF > 'driver1.f90' PROGRAM test ! David M. Smith 6-14-96 ! This is a test program for ZMLIB 1.1, a multiple-precision complex ! arithmetic package. Most of the ZM routines are tested, and the ! results are checked to 50 significant digits. ! This program uses both ZMLIB.f90 and FMLIB.f90. ! These five common blocks contain information that must be saved ! between calls, so they should be declared in the main program. ! The parameter statement defines array sizes and pointers, and ! contains the FMLIB parameters, followed by ZMLIB parameters. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Local Scalars .. INTEGER :: klog, ncase, nerror ! Character strings used for input and output. CHARACTER (160) :: st1, st2 ! Declare arrays for ZM complex variables (MA, MB, MC, MD) ! and for FM real variables (MAFM, MBFM). All are in ! unpacked format. ! .. ! .. Local Arrays .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Subroutines .. EXTERNAL test1, test2, test3, test4, test5, test6, test7, test8, zmset ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, jformz, jprntz, kaccsw, & kdebug, keswch, kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, & ncall, ndg2mx, ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, & ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /zmuser/jformz, jprntz ! .. ! Set precision to give at least 50 significant digits ! and initialize the FMLIB package. CALL zmset(50) ! Write output to the standard FM output (unit KW, defined ! in subroutine FMSET), and also to the file TESTZM.LOG. klog = 18 OPEN (klog,file='TESTZM.LOG') ! NERROR is the number of errors found. ! NCASE is the number of cases tested. nerror = 0 ! Test input and output conversion. CALL test1(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test add and subtract. CALL test2(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test multiply, divide and square root. CALL test3(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test exponentials. CALL test4(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test logarithms. CALL test5(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test trigonometric functions. CALL test6(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test inverse trigonometric functions. CALL test7(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test hyperbolic functions. CALL test8(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! End of tests. IF (nerror==0) THEN WRITE (kw,90000) ncase WRITE (klog,90000) ncase ELSE ! Write some of the initialized values in common. WRITE (klog,*) ' NDIG,MBASE,JFORM1,JFORM2,KRAD = ' WRITE (klog,*) ndig, mbase, jform1, jform2, krad WRITE (klog,*) ' KW,NTRACE,LVLTRC,KFLAG,KWARN,KROUND = ' WRITE (klog,*) kw, ntrace, lvltrc, kflag, kwarn, kround WRITE (klog,*) ' NCALL,MXEXP,MXEXP2,KACCSW,MEXPUN,MEXPOV' WRITE (klog,*) ncall, mxexp, mxexp2, kaccsw, mexpun, mexpov WRITE (klog,*) ' MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX = ' WRITE (klog,*) munkno, iunkno, runkno, mxbase, ndg2mx WRITE (klog,*) ' MAXINT,INTMAX,SPMAX,DPMAX = ' WRITE (klog,*) maxint, intmax, spmax, dpmax WRITE (klog,*) ' ALOGMB,ALOGM2,ALOGMX,ALOGMT,DLOGMB,DLOGTN =' WRITE (klog,*) alogmb, alogm2, alogmx, alogmt, dlogmb, dlogtn WRITE (klog,*) ' DLOGTW,DLOGTP,DLOGPI,DPPI =' WRITE (klog,*) dlogtw, dlogtp, dlogpi, dppi WRITE (klog,*) ' DPEPS,DLOGEB =' WRITE (klog,*) dpeps, dlogeb WRITE (kw,90010) ncase, nerror WRITE (klog,90010) ncase, nerror END IF WRITE (kw,*) ' End of run.' STOP 90000 FORMAT (///1X,I5,' cases tested. No errors were found.'/) 90010 FORMAT (///1X,I5,' cases tested.',I4,' error(s) found.'/) END PROGRAM test SUBROUTINE test1(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Input and output testing. ! Logical function for comparing FM numbers. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zm2i2m, zmabs, zmdivi, zmform, zmmpyi, & zmst2m, zmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 1 CALL zmst2m('123 + 456 i',ma) CALL zm2i2m(123,456,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-48,mbfm) ! 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(mafm,'LE',mbfm)) THEN CALL errprt('ZMST2M',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 2 st1 = '0.3505154639175257731958762886597938144329896907216495 + ' // & '0.7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,ma) CALL zm2i2m(34,71,mc) CALL zmdivi(mc,97,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMST2M',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 3 st1 = '0.3505154639175257731958762886597938144329896907216495E-5 ' // & '+ 0.7319587628865979381443298969072164948453608247422680D-5 i' CALL zmst2m(st1,ma) CALL zm2i2m(34,71,mc) CALL zmdivi(mc,9700000,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-55,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMST2M',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 4 st1 = '7.699115044247787610619469026548672566371681415929204e 03 ' // & '- 5.221238938053097345132743362831858407079646017699115M 03 I' CALL zmst2m(st1,ma) CALL zm2i2m(87,-59,mc) CALL zmdivi(mc,113,mc) CALL zmmpyi(mc,10000,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-47,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMST2M',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 5 st1 = '7.699115044247787610619469026548672566371681415929204e+3 ' // & '- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL zmst2m(st1,ma) CALL zmform('F53.33','F50.30',ma,st2) CALL zmst2m(st2,ma) st1 = '7699.115044247787610619469026548673 ' // & '-5221.238938053097345132743362831858 i' CALL zmst2m(st1,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-30,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 6 st1 = '7.699115044247787610619469026548672566371681415929204e+3 ' // & '- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL zmst2m(st1,ma) CALL zmform('I9','I7',ma,st2) CALL zmst2m(st2,ma) st1 = '7699 -5221 i' CALL zmst2m(st1,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(0,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 7 st1 = '7.699115044247787610619469026548672566371681415929204e+3 ' // & '- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL zmst2m(st1,ma) CALL zmform('E59.50','E58.49',ma,st2) CALL zmst2m(st2,ma) st1 = '7.6991150442477876106194690265486725663716814159292E3' // & '- 5.221238938053097345132743362831858407079646017699E3 i' CALL zmst2m(st1,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-48,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 8 st1 = '7.699115044247787610619469026548672566371681415929204e+3 ' // & '- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL zmst2m(st1,ma) CALL zmform('1PE59.50','1PE58.49',ma,st2) CALL zmst2m(st2,ma) CALL zmst2m(st1,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-44,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing input and output routines.') END SUBROUTINE test1 SUBROUTINE test2(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test add and subtract. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zm2i2m, zmabs, zmadd, zmst2m, zmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 9 CALL zmst2m('123 + 456 i',ma) CALL zmst2m('789 - 543 i',mb) CALL zmadd(ma,mb,ma) CALL zm2i2m(912,-87,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(0,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMADD ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 10 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) st1 = '.3505154639175257731958762886597938144329896907216495 ' // & '+ .7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,mb) CALL zmadd(ma,mb,ma) st2 = '1.1204269683423045342578231913146610710701578323145698 ' // & '+ 0.2098348690812882036310555606240306541373962229723565 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMADD ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 11 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) st1 = '.3505154639175257731958762886597938144329896907216495 ' // & '+ .7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,mb) CALL zmsub(ma,mb,ma) st2 = '0.4193960405072529878660706139950734422041784508712709 ' // & '- 1.2540826566919076726576042331904023355533254265121795 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSUB ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 12 st1 = '.7699115044247787610619469026548672566371681415929204E3 ' // & '- .5221238938053097345132743362831858407079646017699115E3 i' CALL zmst2m(st1,ma) st1 = '.3505154639175257731958762886597938144329896907216495 ' // & '+ .7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,mb) CALL zmsub(ma,mb,ma) st2 = '769.5609889608612352887510263662074628227351519021987045 ' // & '- 522.8558525681963324514186661800930572028099625946537725 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-47,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSUB ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing add and subtract routines.') END SUBROUTINE test2 SUBROUTINE test3(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test multiply, divide and square root. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zm2i2m, zmabs, zmdiv, zmdivi, zmmpy, & zmmpyi, zmsqr, zmsqrt, zmst2m, zmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 13 CALL zmst2m('123 + 456 i',ma) CALL zmst2m('789 - 543 i',mb) CALL zmmpy(ma,mb,ma) CALL zm2i2m(344655,292995,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(0,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMMPY ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 14 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) st1 = '.3505154639175257731958762886597938144329896907216495 ' // & '+ .7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,mb) CALL zmmpy(ma,mb,ma) st2 = '0.6520390475321594745005017790347596022260742632971444 ' // & '+ 0.3805309734513274336283185840707964601769911504424779 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMMPY ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 15 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) st1 = '.3505154639175257731958762886597938144329896907216495 ' // & '+ .7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,mb) CALL zmdiv(ma,mb,ma) st2 = '-.1705178497731560089737969128653459210208765017614861 ' // & '- 1.1335073636829696356072949942949842987114804337239972 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMDIV ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 16 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmmpyi(ma,36,ma) st2 = '27.7168141592920353982300884955752212389380530973451327 ' // & '- 18.7964601769911504424778761061946902654867256637168142 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-48,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMMPYI',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 17 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmdivi(ma,37,ma) st2 = '2.080841903850753408275532169337479071992346328629514E-2 ' // & '- 1.411145658933269552738579287251853623535039464243004E-2 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-52,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMDIVI',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 18 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmsqr(ma,ma) st2 = '0.3201503641632077688150990680554467851828647505677813 ' // & '- 0.8039783851515388832328295089670295246299631921058814 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSQR ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 19 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmsqrt(ma,ma) st2 = '0.9219999909012323458336720551458583330580388434229845 ' // & '- 0.2831474506279259570386845864488094697732718981999941 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSQRT',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing multiply, divide and square root routines.') END SUBROUTINE test3 SUBROUTINE test4(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test exponentials. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zmabs, zmexp, zmipwr, zmpwr, zmrpwr, & zmst2m, zmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 20 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmexp(ma,ma) st2 = '1.8718374504057787925867989348073888855260008469310002 ' // & '- 1.0770279996847678711699041910427261417963102075889234 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMEXP ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 21 st1 = '5.7699115044247787610619469026548672566371681415929204 ' // & '- 4.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmexp(ma,ma) st2 = '-60.6144766542152809520229386164396710991242264070603612 ' // & '+ 314.7254994809539691403004121118801578835669635535466592 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-47,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMEXP ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 22 st1 = '1.7699115044247787610619469026548672566371681415929204 ' // & '- 1.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmipwr(ma,45,ma) st2 = '31595668743300099.70429472191424818167262151605608585179 ' // & '- 19209634448276799.67717448173630165852744930837930753788 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-33,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMIPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 23 st1 = '1.7699115044247787610619469026548672566371681415929204 ' // & '- 1.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmipwr(ma,-122,ma) st2 = '3.1000215641022021714480000129414241564868699479432E-46 ' // & '- 1.1687846789859477815450163510927243367234863123667E-45 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-93,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMIPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 24 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) st1 = '.3505154639175257731958762886597938144329896907216495 ' // & '+ .7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,mb) CALL zmpwr(ma,mb,ma) st2 = '1.4567089343012352449621841355636496276866203747888724 ' // & '- 0.3903177712261966292764255714390622205129978923650749 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMPWR ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 25 st1 = '.3505154639175257731958762886597938144329896907216495 ' // & '+ .7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,ma) st1 = '2.7699115044247787610619469026548672566371681415929204 ' // & '- 0.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,mb) CALL zmpwr(ma,mb,ma) st2 = '-1.0053105716678380336247948739245187868180079734997482 ' // & '- 0.0819537653234704467729051473979237153087038930127116 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMPWR ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 26 st1 = '0.7699115044247787610619469026548672566371681415929204 ' // & '- 0.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmrpwr(ma,2,7,ma) st2 = '0.9653921326136512316639621651337975772631340364271270 ' // & '- 0.1659768285667051396562270035411852432430188906482848 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMRPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 27 st1 = '0.7699115044247787610619469026548672566371681415929204 ' // & '- 0.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmrpwr(ma,-19,7,ma) st2 = '-0.0567985880053556315170006800325686036902111276420647 ' // & '+ 1.2154793972711356706410882510363594270389067962568571 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMRPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing exponential routines.') END SUBROUTINE test4 SUBROUTINE test5(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test logarithms. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zmabs, zmlg10, zmln, zmst2m, zmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 28 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmln(ma,ma) st2 = '-0.0722949652393911311212450699415231782692434885813725 ' // & '- 0.5959180055163009910007765127008371205749515965219804 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMLN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 29 st1 = '.7699115044247787610619469026548672566371681415929204E28 ' // & '- .5221238938053097345132743362831858407079646017699115E28 i' CALL zmst2m(st1,ma) CALL zmln(ma,ma) st2 = '64.4000876385938880213825156612206746345615981930242708 ' // & '- 0.5959180055163009910007765127008371205749515965219804 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-48,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMLN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 30 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmlg10(ma,ma) st2 = '-0.0313973044728549715287589498363619677438302809470943 ' // & '- 0.2588039014625211035392823012785304771809982053965284 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMLG10',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 31 st1 = '.7699115044247787610619469026548672566371681415929204E82 ' // & '- .5221238938053097345132743362831858407079646017699115E82 i' CALL zmst2m(st1,ma) CALL zmlg10(ma,ma) st2 = '81.9686026955271450284712410501636380322561697190529057 ' // & '- 0.2588039014625211035392823012785304771809982053965284 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-48,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMLG10',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing logarithm routines.') END SUBROUTINE test5 SUBROUTINE test6(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test trigonometric functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zmabs, zmcos, zmcssn, zmsin, zmst2m, & zmsub, zmtan ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 32 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmcos(ma,ma) st2 = '0.8180802525254482451348613286211514555816444253416895 ' // & '+ 0.3801751200076938035500853542125525088505055292851393 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCOS ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 33 st1 = '34.7699115044247787610619469026548672566371681415929204 ' // & '- 42.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmcos(ma,ma) st2 = '-1432925478410268113.5816466154230974355002592549420099 ' // & '- 309002816679456015.00151246245263842483282458519462258 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-31,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCOS ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 34 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmsin(ma,ma) st2 = '0.7931260548991613428648822413402447097755865697557818 ' // & '- 0.3921366045897070762848927655743167937790944353110710 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSIN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 35 st1 = '34.7699115044247787610619469026548672566371681415929204 ' // & '- 42.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmsin(ma,ma) st2 = '-3.090028166794560150015124624526384249047272360765358E17 ' // & '+ 1.432925478410268113581646615423097435166828182950161E18 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-31,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSIN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 36 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmtan(ma,ma) st2 = '0.6141156219447569167198437040270236055089243090199979 ' // & '- 0.7647270337230070156308196055474639461102792169274526 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMTAN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 37 st1 = '35.7699115044247787610619469026548672566371681415929204 ' // & '- 43.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmtan(ma,ma) st2 = '2.068934241218867332441292427642153175237611151321340E-38 ' // & '- 1.000000000000000000000000000000000000023741659169354 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMTAN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 38 st1 = '0.3505154639175257731958762886597938144329896907216495 ' // & '+ 0.7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,ma) CALL zmcssn(ma,ma,mc) st2 = '1.2022247452809115256533054407001508718694617802593324 ' // & '- 0.2743936538120352873902095801531325075994392065668943 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCSSN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 39 st1 = '0.3505154639175257731958762886597938144329896907216495 ' // & '+ 0.7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,ma) CALL zmcssn(ma,mc,ma) st2 = '0.4395486978082638069281369170831952476351663772871008 ' // & '+ 0.7505035100906417134864779281080728222900154610025883 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCSSN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing trigonometric routines.') END SUBROUTINE test6 SUBROUTINE test7(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test inverse trigonometric functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zmabs, zmacos, zmasin, zmatan, zmst2m, & zmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 40 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmacos(ma,ma) st2 = '0.8797127900868121872960714368309657795959216549012347 ' // & '+ 0.6342141347945396859119941874681961111936156338608130 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMACOS',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 41 st1 = '.7699115044247787610619469026548672566371681415929204E12 ' // & '- .5221238938053097345132743362831858407079646017699115E12 i' CALL zmst2m(st1,ma) CALL zmacos(ma,ma) st2 = '0.5959180055163009910007767810953294528367807973983794 ' // & '+28.2518733312491023865118844008522768856672089946951468 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-48,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMACOS',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 42 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmasin(ma,ma) st2 = '0.6910835367080844319352502548087856625026630447863182 ' // & '- 0.6342141347945396859119941874681961111936156338608130 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMASIN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 43 st1 = '.7699115044247787610619469026548672566371681415929204E13 ' // & '- .5221238938053097345132743362831858407079646017699115E13 i' CALL zmst2m(st1,ma) CALL zmasin(ma,ma) st2 = '0.9748783212785956282305451762549693982010148111568094 ' // & '-30.5544584242431480705298759613446206186670533428066404 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-48,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMASIN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 44 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmatan(ma,ma) st2 = '0.7417952692265900376512911713942700568648670953521258 ' // & '- 0.3162747143126729004878357203292329539837025170484857 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMATAN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 45 st1 = '.7699115044247787610619469026548672566371681415929204E13 ' // & '- .5221238938053097345132743362831858407079646017699115E13 i' CALL zmst2m(st1,ma) CALL zmatan(ma,ma) st2 = ' 1.570796326794807650905529836436131532596233124329403 ' // & '-6.033484162895927601809954710695221401671437742867605E-14 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMATAN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing inverse trigonometric routines.') END SUBROUTINE test7 SUBROUTINE test8(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test hyperbolic functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zmabs, zmchsh, zmcosh, zmsinh, zmst2m, & zmsub, zmtanh ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 46 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmcosh(ma,ma) st2 = '1.1365975275870879962259716562608779977957563621412079 ' // & '- 0.4230463404769118342540441830446134405410543954181579 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCOSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 47 st1 = '34.7699115044247787610619469026548672566371681415929204 ' // & '- 42.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmcosh(ma,ma) st2 = '69552104658681.7558589320148420094288419217262200765435 ' // & '+ 626163773308016.884007302915197616300902876551542156676 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-35,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCOSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 48 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmsinh(ma,ma) st2 = '0.7352399228186907963608272785465108877302444847897922 ' // & '- 0.6539816592078560369158600079981127012552558121707655 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSINH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 49 st1 = '34.7699115044247787610619469026548672566371681415929204 ' // & '- 42.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmsinh(ma,ma) st2 = '6.955210465868175585893201484192181376093291191637290E 13 ' // & '+ 6.261637733080168840073029151984050820616907795167046E 14 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-35,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSINH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 50 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmtanh(ma,ma) st2 = '0.7562684782933185240709480231996041186654551038993505 ' // & '- 0.2938991498221693198532255749292372853685311106820169 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMTANH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 51 st1 = '35.7699115044247787610619469026548672566371681415929204 ' // & '- 43.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmtanh(ma,ma) st2 = '9.999999999999999999999999999998967653135180689424497E-01 ' // & '+ 1.356718776492102400812550018433337461876455254467192E-31 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMTANH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 52 st1 = '0.3505154639175257731958762886597938144329896907216495 ' // & '+ 0.7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,ma) CALL zmchsh(ma,ma,mc) st2 = '0.7900326499280864816444807620997665088044412803737969 ' // & '+ 0.2390857359988804105051429301542214823277594407302781 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCHSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 53 st1 = '0.3505154639175257731958762886597938144329896907216495 ' // & '+ 0.7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,ma) CALL zmchsh(ma,mc,ma) st2 = '0.2661087555034471983220879532235334422670297141428191 ' // & '+ 0.7098057980612199357870532628105009808447460332437714 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCHSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing hyperbolic routines.') END SUBROUTINE test8 SUBROUTINE errprt(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 ERRPRT is called if this is too big. ! NAME1,NAME2,NAME3 are strings identifying which variables in main ! correspond to M1,M2,M3. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (2) :: name1, name2, name3 CHARACTER (6) :: nrout ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: m1(0:lunpkz), m2(0:lunpkz), m3(0:lunpkz) ! .. ! .. Local Scalars .. INTEGER :: kwsave ! .. ! .. External Subroutines .. EXTERNAL zmprnt ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. nerror = nerror + 1 WRITE (kw,90000) ncase, nrout WRITE (klog,90000) ncase, nrout ! Temporarily change KW to KLOG so ZMPRNT ! will write to the log file. kwsave = kw kw = klog WRITE (klog,90010) name1 CALL zmprnt(m1) WRITE (klog,90010) name2 CALL zmprnt(m2) WRITE (klog,90010) name3 CALL zmprnt(m3) kw = kwsave RETURN 90000 FORMAT (//' Error in case',I3,'. The routine',' being tested was ',A6) 90010 FORMAT (1X,A2,' =') END SUBROUTINE errprt SHAR_EOF fi # end of overwriting check if test -f 'driver2.f90' then echo shar: will not over-write existing file "'driver2.f90'" else cat << SHAR_EOF > 'driver2.f90' PROGRAM sample ! David M. Smith 9-17-96 ! This is a test program for ZMLIB 1.1, a multiple-precision real ! arithmetic package. A few example ZM calculations are carried ! out using 30 significant digit precision. ! This program uses both ZMLIB.f90 and FMLIB.f90. ! The output is saved in file ZMSAMPLE.LOG. A comparison file, ! ZMSAMPLE.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." !----------------------------------------------------------------------- ! These five common blocks contain information that must be saved ! between calls, so they should be declared in the main program. ! The parameter statement defines array sizes and pointers, and ! contains the FMLIB parameters, followed by ZMLIB parameters. !----------------------------------------------------------------------- ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Local Scalars .. INTEGER :: iter, k, klog, nerror ! Character string used for input and output. CHARACTER (80) :: st1 ! Declare arrays for ZM variables. All are in ! unpacked format. ! .. ! .. Local Arrays .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmst2m, zmabs, zmadd, zmaddi, zmdiv, zmdivi, zmeq, zmform, & zmi2m, zmmpy, zmmpyi, zmset, zmst2m, zmsub ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, dlogtw, dpeps, & dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, jformz, jprntz, kaccsw, & kdebug, keswch, kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, & ncall, ndg2mx, ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, & ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /zmuser/jformz, jprntz ! .. ! Set precision to give at least 30 significant digits ! and initialize both the ZMLIB and FMLIB packages. ! Note that any program using the ZM package MUST call ! ZMSET before using the package. CALL zmset(30) nerror = 0 ! Write output to the standard FM output (unit KW, defined ! in subroutine FMSET), and also to the file ZMSAMPLE.LOG. klog = 18 OPEN (klog,file='ZMSAMPLE.LOG') ! 1. 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: ! f(x) = ((((x-3)*x+1)*x-4)*x+1)*x-6. ! MA is the previous iterate. ! MB is the current iterate. CALL zmst2m('.56 + 1.06 i',ma) ! Print the first iteration. WRITE (kw,90000) WRITE (klog,90000) CALL zmform('F32.30','F32.30',ma,st1) WRITE (kw,90010) 0, st1(1:69) WRITE (klog,90010) 0, st1(1:69) DO 10 iter = 1, 10 ! MC is f(MA). CALL zmeq(ma,mc) CALL zmaddi(mc,-3) CALL zmmpy(mc,ma,mc) CALL zmaddi(mc,1) CALL zmmpy(mc,ma,mc) CALL zmaddi(mc,-4) CALL zmmpy(mc,ma,mc) CALL zmaddi(mc,1) CALL zmmpy(mc,ma,mc) CALL zmaddi(mc,-6) ! MD is f'(MA). CALL zmmpyi(ma,5,md) CALL zmaddi(md,-12) CALL zmmpy(md,ma,md) CALL zmaddi(md,3) CALL zmmpy(md,ma,md) CALL zmaddi(md,-8) CALL zmmpy(md,ma,md) CALL zmaddi(md,1) CALL zmdiv(mc,md,mb) CALL zmsub(ma,mb,mb) ! Print each iteration. CALL zmform('F32.30','F32.30',mb,st1) WRITE (kw,90010) iter, st1(1:69) WRITE (klog,90010) iter, st1(1:69) ! Stop iterating if MA and MB agree to over ! 30 places. CALL zmsub(ma,mb,md) CALL zmabs(md,mafm) ! The ABS result is real -- do a real (FM) compare. CALL fmst2m('1.0E-31',mbfm) IF (fmcomp(mafm,'LT',mbfm)) GO TO 20 ! Set MA = MB for the next iteration. CALL zmeq(mb,ma) 10 CONTINUE ! Check the answer. 20 st1 = '0.561958308335403235498111195347453 +' // & '1.061134679604332556983391239058885 i' CALL zmst2m(st1,mc) CALL zmsub(mc,mb,md) CALL zmabs(md,mafm) CALL fmst2m('1.0E-31',mbfm) IF (fmcomp(mafm,'GT',mbfm)) THEN nerror = nerror + 1 WRITE (kw,90020) WRITE (klog,90020) END IF ! 2. Compute Exp(1.23-2.34i). ! Use the direct Taylor series. See the ZMEXP routine ! for a faster way to get Exp(x). ! MA is x. ! MB is the current term, x**n/n!. ! MC is the current partial sum. CALL zmst2m('1.23-2.34i',ma) CALL zmi2m(1,mb) CALL zmeq(mb,mc) DO 30 k = 1, 100 CALL zmmpy(mb,ma,mb) CALL zmdivi(mb,k,mb) CALL zmadd(mc,mb,mc) ! Test for convergence. KFLAG will be 1 if the result ! of the last add or subtract is the same as one of the ! input arguments. IF (kflag==1) THEN WRITE (kw,90030) k WRITE (klog,90030) k GO TO 40 END IF 30 CONTINUE ! Print the result. 40 CALL zmform('F33.30','F32.30',mc,st1) WRITE (kw,90040) st1(1:70) WRITE (klog,90040) st1(1:70) ! Check the answer. st1 = '-2.379681796854777515745457977696745 -' // & '2.458032970832342652397461908326042 i' CALL zmst2m(st1,md) CALL zmsub(md,mc,md) CALL zmabs(md,mafm) CALL fmst2m('1.0E-31',mbfm) IF (fmcomp(mafm,'GT',mbfm)) THEN nerror = nerror + 1 WRITE (kw,90050) WRITE (klog,90050) END IF IF (nerror==0) THEN WRITE (kw,90060) ' All results were ok.' WRITE (klog,90060) ' All results were ok.' END IF STOP 90000 FORMAT (//' Sample 1. Find a root of f(x) = x**5 - 3x**4 + ', & 'x**3 - 4x**2 + x - 6 = 0.'///' Iteration Newton Approximation') 90010 FORMAT (/I6,4X,A) 90020 FORMAT (/' Error in sample case number 1.'/) 90030 FORMAT (///' Sample 2.',8X,I5,' terms were added to get ', & 'Exp(1.23-2.34i)'/) 90040 FORMAT (' Result= ',A) 90050 FORMAT (/' Error in sample case number 2.'/) 90060 FORMAT (//A/) END PROGRAM sample SHAR_EOF fi # end of overwriting check if test -f 'driver3.f90' then echo shar: will not over-write existing file "'driver3.f90'" else cat << SHAR_EOF > 'driver3.f90' PROGRAM test ! David M. Smith 6-14-96 ! This is a test program for FMLIB 1.1, a multiple-precision real ! arithmetic package. Most of the FM (floating-point) routines ! are tested, and the results are checked to 50 significant digits. ! Most of the IM (integer) routines are tested, with exact results ! required to pass the tests. ! This program uses FMLIB.f90. ! The four common blocks contain information that must be saved ! between calls, so they should be declared in the main program. ! The parameter statement defines various array sizes. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Local Scalars .. INTEGER :: klog, ncase, nerror ! Character strings used for input and output. CHARACTER (80) :: st1, st2 ! Declare arrays for FM variables. All are in ! unpacked format. ! .. ! .. Local Arrays .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmset, test1, test10, test11, test12, test13, test14, test15, & test2, test3, test4, test5, test6, test7, test8, test9 ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! Set precision to give at least 50 significant digits ! and initialize the FMLIB package. CALL fmset(50) ! 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') ! NERROR is the number of errors found. ! NCASE is the number of cases tested. nerror = 0 ! Test input and output conversion. CALL test1(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test add and subtract. CALL test2(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test multiply, divide and square root. CALL test3(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test stored constants. CALL test4(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test exponentials. CALL test5(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test logarithms. CALL test6(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test trigonometric functions. CALL test7(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test inverse trigonometric functions. CALL test8(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test hyperbolic functions. CALL test9(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer input and output conversion. CALL test10(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer add and subtract. CALL test11(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer multiply and divide. CALL test12(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test conversions between FM and IM format. CALL test13(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer power and GCD functions. CALL test14(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer modular functions. CALL test15(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! End of tests. IF (nerror==0) THEN WRITE (kw,90000) ncase WRITE (klog,90000) ncase ELSE ! Write some of the initialized values in common. WRITE (klog,*) ' NDIG,MBASE,JFORM1,JFORM2,KRAD = ' WRITE (klog,*) ndig, mbase, jform1, jform2, krad WRITE (klog,*) ' KW,NTRACE,LVLTRC,KFLAG,KWARN,KROUND = ' WRITE (klog,*) kw, ntrace, lvltrc, kflag, kwarn, kround WRITE (klog,*) ' NCALL,MXEXP,MXEXP2,KACCSW,MEXPUN,MEXPOV' WRITE (klog,*) ncall, mxexp, mxexp2, kaccsw, mexpun, mexpov WRITE (klog,*) ' MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX = ' WRITE (klog,*) munkno, iunkno, runkno, mxbase, ndg2mx WRITE (klog,*) ' MAXINT,INTMAX,SPMAX,DPMAX = ' WRITE (klog,*) maxint, intmax, spmax, dpmax WRITE (klog,*) ' ALOGMB,ALOGM2,ALOGMX,ALOGMT,DLOGMB,DLOGTN =' WRITE (klog,*) alogmb, alogm2, alogmx, alogmt, dlogmb, dlogtn WRITE (klog,*) ' DLOGTW,DLOGTP,DLOGPI,DPPI =' WRITE (klog,*) dlogtw, dlogtp, dlogpi, dppi WRITE (klog,*) ' DPEPS,DLOGEB =' WRITE (klog,*) dpeps, dlogeb WRITE (kw,90010) ncase, nerror WRITE (klog,90010) ncase, nerror END IF WRITE (kw,*) ' End of run.' STOP 90000 FORMAT (///1X,I5,' cases tested. No errors were found.'/) 90010 FORMAT (///1X,I5,' cases tested.',I4,' error(s) found.'/) END PROGRAM test SUBROUTINE test1(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Input and output testing. ! Logical function for comparing FM numbers. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmdiv, fmform, fmi2m, fmipwr, fmst2m, fmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 1 CALL fmst2m('123',ma) CALL fmi2m(123,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmi2m(10,mb) CALL fmipwr(mb,-48,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 errprt('FMST2M',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 2 st1 = '1.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmi2m(131,mb) CALL fmi2m(97,mc) CALL fmdiv(mb,mc,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMST2M',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 3 st1 = '1.3505154639175257731958762886597938144329896907216495E-2' CALL fmst2m(st1,ma) CALL fmi2m(131,mb) CALL fmi2m(9700,mc) CALL fmdiv(mb,mc,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-52',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMST2M',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF 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,md) CALL fmst2m('0',mb) IF (( .NOT. fmcomp(md,'LE',mb)) .OR. st1/=st2) THEN CALL errprt('FMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF 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,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF 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,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF 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,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF 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,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing input and output routines.') END SUBROUTINE test1 SUBROUTINE test2(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test add and subtract. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmadd, fmaddi, fmi2m, fmst2m, fmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 9 CALL fmst2m('123',ma) CALL fmst2m('789',mb) CALL fmadd(ma,mb,ma) CALL fmi2m(912,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMADD ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 10 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,mb) CALL fmadd(ma,mb,ma) st2 = '1.0824742268041237113402061855670103092783505154639175' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMADD ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 11 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,mb) CALL fmsub(ma,mb,ma) st2 = '-.3814432989690721649484536082474226804123711340206185' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSUB ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 12 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) st1 = '0.3505154639175257731443298969072164948453608247422680' CALL fmst2m(st1,mb) CALL fmsub(ma,mb,ma) st2 = '5.15463917525773195876288659793815M-20' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSUB ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF 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,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMADDI',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF 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,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMADDI',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing add and subtract routines.') END SUBROUTINE test2 SUBROUTINE test3(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test multiply, divide and square root. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmdiv, fmdivi, fmi2m, fmmpy, fmmpyi, fmsqr, & fmsqrt, fmst2m, fmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 15 CALL fmst2m('123',ma) CALL fmst2m('789',mb) CALL fmmpy(ma,mb,ma) CALL fmi2m(97047,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMMPY ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 16 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,mb) CALL fmmpy(ma,mb,ma) st2 = '0.2565628653416941226485280051014985652035285365075991' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMMPY ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 17 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,mb) CALL fmdiv(ma,mb,ma) st2 = '0.4788732394366197183098591549295774647887323943661972' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMDIV ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 18 st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,ma) CALL fmmpyi(ma,14,ma) st2 = '10.2474226804123711340206185567010309278350515463917526' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMMPYI',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 19 st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,ma) CALL fmdivi(ma,24,ma) st2 = '0.0304982817869415807560137457044673539518900343642612' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMDIVI',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 20 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmsqr(ma,ma) st2 = '0.1228610904453183122542246784993091720692953555106813' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSQR ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 21 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmsqrt(ma,ma) st2 = '0.5920434645509785316136003710368759268547372945659987' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSQRT',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing multiply, divide and square root routines.') END SUBROUTINE test3 SUBROUTINE test4(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test stored constants. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mbsave INTEGER :: j, jexp, ndgsav ! .. ! .. Local Arrays .. REAL (KIND(0.0D0)) :: mlnsv2(0:lunpck), mlnsv3(0:lunpck), mlnsv5(0:lunpck), & mlnsv7(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmcons, fmeq, fmexp, fmi2m, fmipwr, fmln, fmpi, & fmsub ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, dlogtw, & dpeps, dppi REAL (KIND(0.0D0)) :: mbase, mblogs, mbse, mbslb, mbsli, mbspi, mexpab INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, & ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ! Switch to base 10 and check the stored digits. mbsave = mbase ndgsav = ndig ncase = 22 mbase = 10 ndig = 200 CALL fmcons CALL fmi2m(1,mb) CALL fmexp(mb,mc) DO 10 j = 142, 144 ndig = j ndige = 0 CALL fmi2m(1,mb) CALL fmexp(mb,ma) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmi2m(10,mb) jexp = -j + 1 CALL fmipwr(mb,jexp,mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt(' e ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) GO TO 20 END IF 10 CONTINUE 20 ncase = 23 mbase = 10 ndig = 200 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,90010) DO 30 j = 142, 144 ndig = j ndigli = 0 CALL fmi2m(2,mb) CALL fmln(mb,ma) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmi2m(10,mb) jexp = -j CALL fmipwr(mb,jexp,mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt(' ln(2)',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) GO TO 40 END IF 30 CONTINUE 40 ncase = 24 mbase = 10 ndig = 200 WRITE (kw,90020) CALL fmeq(mlnsv3,mc) DO 50 j = 142, 144 ndig = j ndigli = 0 CALL fmi2m(3,mb) CALL fmln(mb,ma) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmi2m(10,mb) jexp = -j + 1 CALL fmipwr(mb,jexp,mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt(' ln(3)',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) GO TO 60 END IF 50 CONTINUE 60 ncase = 25 mbase = 10 ndig = 200 WRITE (kw,90030) CALL fmeq(mlnsv5,mc) DO 70 j = 142, 144 ndig = j ndigli = 0 CALL fmi2m(5,mb) CALL fmln(mb,ma) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmi2m(10,mb) jexp = -j + 1 CALL fmipwr(mb,jexp,mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt(' ln(5)',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) GO TO 80 END IF 70 CONTINUE 80 ncase = 26 mbase = 10 ndig = 200 WRITE (kw,90040) CALL fmeq(mlnsv7,mc) DO 90 j = 142, 144 ndig = j ndigli = 0 CALL fmi2m(7,mb) CALL fmln(mb,ma) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmi2m(10,mb) jexp = -j + 1 CALL fmipwr(mb,jexp,mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt(' ln(7)',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) GO TO 100 END IF 90 CONTINUE 100 ncase = 27 mbase = 10 ndig = 200 WRITE (kw,90050) CALL fmpi(mc) DO 110 j = 142, 144 ndig = j ndigpi = 0 CALL fmpi(ma) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmi2m(10,mb) jexp = -j + 1 CALL fmipwr(mb,jexp,mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt(' pi ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) GO TO 120 END IF 110 CONTINUE ! Restore base and precision. 120 mbase = mbsave ndig = ndgsav CALL fmcons RETURN 90000 FORMAT (/' Testing stored constants.'//' Check e.'/) 90010 FORMAT (' Check ln(2).'/) 90020 FORMAT (' Check ln(3).'/) 90030 FORMAT (' Check ln(5).'/) 90040 FORMAT (' Check ln(7).'/) 90050 FORMAT (' Check pi.') END SUBROUTINE test4 SUBROUTINE test5(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test exponentials. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmexp, fmipwr, fmpwr, fmrpwr, fmst2m, fmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 28 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmexp(ma,ma) st2 = '0.7043249420381570899426746185150096342459216636010743' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMEXP ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 29 st1 = '5.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmexp(ma,ma) st2 = '210.7168868293979289717186453717687341395104929999527672' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-48',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMEXP ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 30 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmipwr(ma,13,ma) st2 = '1.205572620050170403854527299272882946980306577287581E-6' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-56',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMIPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 31 st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,ma) CALL fmipwr(ma,-1234,ma) st2 = '1.673084074011006302103793189789209370839697748745938E167' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E+120',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMIPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 32 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,mb) CALL fmpwr(ma,mb,ma) st2 = '0.4642420045002127676457665673753493595170650613692580' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMPWR ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 33 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) st1 = '-34.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,mb) CALL fmpwr(ma,mb,ma) st2 = '6.504461581246879800523526109766882955934341922848773E15' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-34',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMPWR ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 34 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmrpwr(ma,1,3,ma) st2 = '0.7050756680967220302067310420367584779561732592049823' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMRPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 35 st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,ma) CALL fmrpwr(ma,-17,5,ma) st2 = '2.8889864895853344043562747681699203201333872009477318' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMRPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing exponential routines.') END SUBROUTINE test5 SUBROUTINE test6(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test logarithms. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmlg10, fmln, fmlni, fmst2m, fmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 36 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmln(ma,ma) st2 = '-1.0483504538872214324499548823726586101452117557127813' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-49',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMLN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 37 st1 = '0.3505154639175257731958762886597938144329896907216495E123' CALL fmst2m(st1,ma) CALL fmln(ma,ma) st2 = '282.1696159843803977017629940438041389247902713456262947' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-47',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMLN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 38 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmlg10(ma,ma) st2 = '-0.4552928172239897280304530226127473926500843247517120' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-49',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMLG10',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 39 CALL fmlni(210,ma) st2 = '5.3471075307174686805185894350500696418856767760333836' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-49',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMIPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 40 CALL fmlni(211,ma) st2 = '5.3518581334760664957419562654542801180411581735816684' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-49',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMPWR ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing logarithm routines.') END SUBROUTINE test6 SUBROUTINE test7(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test trigonometric functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmcos, fmcssn, fmsin, fmst2m, fmsub, fmtan ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 41 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcos(ma,ma) st2 = '0.9391958366109693586000906984500978377093121163061328' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCOS ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 42 st1 = '-43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcos(ma,ma) st2 = '0.8069765551968063243992244125871029909816207609700968' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCOS ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 43 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmsin(ma,ma) st2 = '-0.3433819746180939949443652360333010581867042625893927' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSIN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 44 st1 = '43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmsin(ma,ma) st2 = '-0.5905834736620182429243173169772978155668602154136946' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSIN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 45 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmtan(ma,ma) st2 = '0.3656127521360899712035823015565426347554405301360773' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMTAN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 46 st1 = '43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmtan(ma,ma) st2 = '-0.7318471272291003544610122296764031536071117330470298' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMTAN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 47 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcssn(ma,ma,mc) st2 = '0.9391958366109693586000906984500978377093121163061328' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCSSN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 48 st1 = '-43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcssn(ma,ma,mc) st2 = '0.8069765551968063243992244125871029909816207609700968' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCSSN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 49 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcssn(ma,mc,ma) st2 = '-0.3433819746180939949443652360333010581867042625893927' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCSSN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 50 st1 = '43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcssn(ma,mc,ma) st2 = '-0.5905834736620182429243173169772978155668602154136946' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCSSN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing trigonometric routines.') END SUBROUTINE test7 SUBROUTINE test8(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test inverse trigonometric functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmacos, fmasin, fmatan, fmst2m, fmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 51 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmacos(ma,ma) st2 = '1.2126748979730954046873545995574544481988102502510807' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMACOS',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 52 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmacos(ma,ma) st2 = '1.9289177556166978337752887837220484359983591491240252' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMACOS',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 53 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmasin(ma,ma) st2 = '0.3581214288218012145439670920822969938997744494364723' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMASIN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 54 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmasin(ma,ma) st2 = '-0.3581214288218012145439670920822969938997744494364723' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMASIN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 55 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmatan(ma,ma) st2 = '0.3371339561772373443347761845672381725353758541616570' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMATAN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 56 st1 = '43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmatan(ma,ma) st2 = '1.5477326406586162039457549832092678908202994134569781' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMATAN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing inverse trigonometric routines.') END SUBROUTINE test8 SUBROUTINE test9(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test hyperbolic functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmchsh, fmcosh, fmsinh, fmst2m, fmsub, fmtanh ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 57 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcosh(ma,ma) st2 = '1.0620620786534654254819884264931372964608741056397718' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-49',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCOSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 58 st1 = '-43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcosh(ma,ma) st2 = '3.356291383454381441662669560464886179346554730604556E+18' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-31',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCOSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 59 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmsinh(ma,ma) st2 = '-0.3577371366153083355393138079781276622149524420386975' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSINH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 60 st1 = '43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmsinh(ma,ma) st2 = '3.356291383454381441662669560464886179197580776059111E+18' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-31',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSINH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 61 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmtanh(ma,ma) st2 = '0.3368326049912874057089491946232983472275659538703038' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMTANH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 62 st1 = '43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmtanh(ma,ma) st2 = '0.9999999999999999999999999999999999999556135217341837' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMTANH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 63 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmchsh(ma,ma,mc) st2 = '1.0620620786534654254819884264931372964608741056397718' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-49',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCHSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 64 st1 = '-43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmchsh(ma,ma,mc) st2 = '3.356291383454381441662669560464886179346554730604556E+18' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-31',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCHSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 65 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmchsh(ma,mc,ma) st2 = '-0.3577371366153083355393138079781276622149524420386975' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCHSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 66 st1 = '43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmchsh(ma,mc,ma) st2 = '3.356291383454381441662669560464886179197580776059111E+18' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-31',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCHSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing hyperbolic routines.') END SUBROUTINE test9 SUBROUTINE test10(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Input and output testing for IM routines. ! Logical function for comparing IM numbers. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL errpr2, imform, imi2m, impwr, imst2m ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 67 CALL imst2m('123',ma) CALL imi2m(123,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMST2M',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 68 st1 = '-350515' CALL imst2m(st1,ma) CALL imi2m(-350515,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMST2M',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 69 st1 = '19895113660064588580108197261066338165074766609' CALL imst2m(st1,ma) CALL imi2m(23,mb) CALL imi2m(34,mc) CALL impwr(mb,mc,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMST2M',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 70 st1 = '-20800708073664542533904165663516279809808659679033703' CALL imst2m(st1,ma) CALL imi2m(-567,mb) CALL imi2m(19,mc) CALL impwr(mb,mc,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMST2M',ma,'MA',mc,'MC',ncase,nerror,klog) END IF 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 errpr2('IMFORM',ma,'MA',mc,'MC',ncase,nerror,klog) END IF 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 errpr2('IMFORM',ma,'MA',mc,'MC',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing integer input and output routines.') END SUBROUTINE test10 SUBROUTINE test11(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test add and subtract for IM routines. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL errpr2, imadd, imi2m, imst2m, imsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 73 CALL imst2m('123',ma) CALL imst2m('789',mb) CALL imadd(ma,mb,ma) CALL imi2m(912,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMADD ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 74 st1 = '3505154639175257731958762886597938144329896907216495' CALL imst2m(st1,ma) st1 = '7319587628865979381443298969072164948453608247422680' CALL imst2m(st1,mb) CALL imadd(ma,mb,ma) st2 = '10824742268041237113402061855670103092783505154639175' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMADD ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 75 st1 = '3505154639175257731958762886597938144329896907216495' CALL imst2m(st1,ma) st1 = '7319587628865979381443298969072164948453608247422680' CALL imst2m(st1,mb) CALL imsub(ma,mb,ma) st2 = '-3814432989690721649484536082474226804123711340206185' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMSUB ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 76 st1 = '3505154639175257731958762886597938144329896907216495' CALL imst2m(st1,ma) st1 = '3505154639175257731443298969072164948453608247422680' CALL imst2m(st1,mb) CALL imsub(ma,mb,ma) st2 = '515463917525773195876288659793815' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMSUB ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing integer add and subtract routines.') END SUBROUTINE test11 SUBROUTINE test12(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer multiply and divide. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: irem ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL errpr2, imdiv, imdivi, imdivr, imdvir, imi2m, immod, immpy, & immpyi, imsqr, imst2m ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 77 CALL imst2m('123',ma) CALL imst2m('789',mb) CALL immpy(ma,mb,ma) CALL imi2m(97047,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMMPY ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 78 st1 = '10430738374625018354698' CALL imst2m(st1,ma) st1 = '2879494424799214514791045985' CALL imst2m(st1,mb) CALL immpy(ma,mb,ma) st2 = '30035252996271960952238822892375588336807158787530' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMMPY ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 79 CALL imst2m('12347',ma) CALL imst2m('47',mb) CALL imdiv(ma,mb,ma) CALL imst2m('262',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDIV ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 80 st1 = '2701314697583086005158008013691015597308949443159762' CALL imst2m(st1,ma) st1 = '-978132616472842669976589722394' CALL imst2m(st1,mb) CALL imdiv(ma,mb,ma) CALL imst2m('-2761705981469115610382',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDIV ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 81 CALL imst2m('12368',ma) CALL imst2m('67',mb) CALL immod(ma,mb,mb) CALL imst2m('40',mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMMOD ',mb,'MB',mc,'MC',ncase,nerror,klog) END IF ncase = 82 st1 = '2701314697583086005158008013691015597308949443159762' CALL imst2m(st1,ma) st1 = '-978132616472842669976589722394' CALL imst2m(st1,mb) CALL immod(ma,mb,mb) CALL imst2m('450750319653685523300198865254',mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMMOD ',mb,'MB',mc,'MC',ncase,nerror,klog) END IF ncase = 83 CALL imst2m('1234',ma) CALL imst2m('17',mb) CALL imdivr(ma,mb,ma,mb) CALL imst2m('72',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDIVR',ma,'MA',mc,'MC',ncase,nerror,klog) END IF CALL imst2m('10',mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMDIVR',mb,'MB',mc,'MC',ncase,nerror,klog) END IF ncase = 84 st1 = '34274652243817531418235301715935108945364446765801943' CALL imst2m(st1,ma) st1 = '-54708769795848731641842224621693' CALL imst2m(st1,mb) CALL imdivr(ma,mb,ma,mb) CALL imst2m('-626492834178447772323',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDIVR',ma,'MA',mc,'MC',ncase,nerror,klog) END IF CALL imst2m('31059777254296217822749494999104',mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMDIVR',mb,'MB',mc,'MC',ncase,nerror,klog) END IF ncase = 85 CALL imst2m('4866',ma) CALL immpyi(ma,14,ma) CALL imst2m('68124',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMMPYI',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 86 CALL imst2m('270131469758308600515800801369101559730894',ma) CALL immpyi(ma,-2895,ma) CALL imst2m('-782030604950303398493243319963549015420938130',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMMPYI ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 87 CALL imst2m('-37179',ma) CALL imdivi(ma,129,ma) CALL imst2m('-288',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDIVI',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 88 st1 = '8267538919383255454483790743961990401918726073065738' CALL imst2m(st1,ma) CALL imdivi(ma,1729,ma) st2 = '4781688212483085861471249707323302719444028960708' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDIVI',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 89 CALL imst2m('-71792',ma) CALL imdvir(ma,65,ma,irem) CALL imst2m('-1104',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDVIR',ma,'MA',mc,'MC',ncase,nerror,klog) END IF CALL imi2m(irem,mb) CALL imi2m(-32,mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMDVIR',mb,'MB',mc,'MC',ncase,nerror,klog) END IF ncase = 90 st1 = '97813261647284266997658972239417958580120170263408655' CALL imst2m(st1,ma) CALL imdvir(ma,826,ma,irem) st2 = '118417992309060855929369215786220288837917881674828' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDVIR',ma,'MA',mc,'MC',ncase,nerror,klog) END IF CALL imi2m(irem,mb) CALL imi2m(727,mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMDVIR',mb,'MB',mc,'MC',ncase,nerror,klog) END IF ncase = 91 CALL imst2m('538',ma) CALL imsqr(ma,ma) CALL imst2m('289444',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMSQR ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 92 CALL imst2m('-47818191879814587168242632',ma) CALL imsqr(ma,ma) st2 = '2286579474654765721668058416662636606051551222287424' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMSQR ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing integer multiply, divide and square routines.') END SUBROUTINE test12 SUBROUTINE test13(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test conversions between FM and IM format. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp, imcomp ! .. ! .. External Subroutines .. EXTERNAL errpr2, errprt, fmabs, fmi2m, fmst2m, fmsub, imfm2i, imi2fm, & imi2m, imst2m ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 93 CALL imst2m('123',ma) CALL imi2fm(ma,mb) CALL fmi2m(123,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('IMI2FM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 94 CALL imst2m('979282999076598337488362000995916',ma) CALL imi2fm(ma,mb) CALL fmst2m('979282999076598337488362000995916',mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('IMI2FM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 95 CALL fmst2m('123.4',ma) CALL imfm2i(ma,mb) CALL imi2m(123,mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMFM2I',mb,'MB',mc,'MC',ncase,nerror,klog) END IF ncase = 96 CALL fmst2m('979282999076598337488362000995916',ma) CALL imfm2i(ma,mb) CALL imst2m('979282999076598337488362000995916',mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMFM2I',mb,'MB',mc,'MC',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing conversions between FM and IM format.') END SUBROUTINE test13 SUBROUTINE test14(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer power and GCD functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL errpr2, imgcd, imi2m, impwr, imst2m ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 97 CALL imst2m('123',ma) CALL imst2m('789',mb) CALL imgcd(ma,mb,ma) CALL imi2m(3,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMGCD ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 98 st1 = '431134020618556701030927835051546391752577319587628885' CALL imst2m(st1,ma) st1 = '900309278350515463917525773195876288659793814432989640' CALL imst2m(st1,mb) CALL imgcd(ma,mb,ma) CALL imst2m('615',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMGCD ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 99 st1 = '5877631675869176172956662762822298812326084745145447940' CALL imst2m(st1,ma) st1 = '10379997509886032090765062511740075746391432253007667' CALL imst2m(st1,mb) CALL imgcd(ma,mb,ma) CALL imst2m('1',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMGCD ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 100 CALL imst2m('47',ma) CALL imst2m('34',mb) CALL impwr(ma,mb,ma) st2 = '710112520079088427392020925014421733344154169313556279969' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMPWR ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 101 CALL imst2m('2',ma) CALL imst2m('187',mb) CALL impwr(ma,mb,ma) st2 = '196159429230833773869868419475239575503198607639501078528' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMPWR ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 102 CALL imst2m('-3',ma) CALL imst2m('101',mb) CALL impwr(ma,mb,ma) st2 = '-1546132562196033993109383389296863818106322566003' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMPWR ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing integer GCD and power routines.') END SUBROUTINE test14 SUBROUTINE test15(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer modular functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL errpr2, imi2m, immpym, impmod, imst2m ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 103 CALL imst2m('123',ma) CALL imst2m('789',mb) CALL imst2m('997',mc) CALL immpym(ma,mb,mc,ma) CALL imi2m(338,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMMPYM',ma,'MA',mc,'MC',ncase,nerror,klog) END IF 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,ma) st2 = '458279704440780378752997531208983184411293504187816380' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMMPYM',ma,'MA',mc,'MC',ncase,nerror,klog) END IF 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,ma) st2 = '-7769745969769966093344960' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMMPYM',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 106 CALL imst2m('123',ma) CALL imst2m('789',mb) CALL imst2m('997',mc) CALL impmod(ma,mb,mc,ma) CALL imi2m(240,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMPMOD',ma,'MA',mc,'MC',ncase,nerror,klog) END IF 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,ma) st2 = '755107893576299697276281907390144058060594744720442385' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMPMOD',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 108 CALL imst2m('314159',ma) CALL imst2m('1411695892374393248272691827763664225585897550',mb) CALL imst2m('1411695892374393248272691827763664225585897551',mc) CALL impmod(ma,mb,mc,ma) CALL imst2m('1',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMPMOD',ma,'MA',mc,'MC',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing integer modular routines.') END SUBROUTINE test15 SUBROUTINE errprt(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 FMST2M. ! M3 is ABS(M1-M2), and ERRPRT is called if this is too big. ! NAME1,NAME2,NAME3 are strings identifying which variables in main ! correspond to M1,M2,M3. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (2) :: name1, name2, name3 CHARACTER (6) :: nrout ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: m1(0:lunpck), m2(0:lunpck), m3(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwsave ! .. ! .. External Subroutines .. EXTERNAL fmprnt ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. nerror = nerror + 1 WRITE (kw,90000) ncase, nrout WRITE (klog,90000) ncase, nrout ! Temporarily change KW to KLOG so FMPRNT ! will write to the log file. kwsave = kw kw = klog WRITE (klog,90010) name1 CALL fmprnt(m1) WRITE (klog,90010) name2 CALL fmprnt(m2) WRITE (klog,90010) name3 CALL fmprnt(m3) kw = kwsave RETURN 90000 FORMAT (//' Error in case',I3,'. The routine',' being tested was ',A6) 90010 FORMAT (1X,A2,' =') END SUBROUTINE errprt SUBROUTINE errpr2(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 main ! correspond to M1,M2. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (2) :: name1, name2 CHARACTER (6) :: nrout ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: m1(0:lunpck), m2(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwsave ! .. ! .. External Subroutines .. EXTERNAL imprnt ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. nerror = nerror + 1 WRITE (kw,90000) ncase, nrout WRITE (klog,90000) ncase, nrout ! Temporarily change KW to KLOG so IMPRNT ! will write to the log file. kwsave = kw kw = klog WRITE (klog,90010) name1 CALL imprnt(m1) WRITE (klog,90010) name2 CALL imprnt(m2) kw = kwsave RETURN 90000 FORMAT (//' Error in case',I3,'. The routine',' being tested was ',A6) 90010 FORMAT (1X,A2,' =') END SUBROUTINE errpr2 SHAR_EOF fi # end of overwriting check if test -f 'driver4.f90' then echo shar: will not over-write existing file "'driver4.f90'" else cat << SHAR_EOF > 'driver4.f90' PROGRAM sample ! David M. Smith 6-17-96 ! This is a test program for FMLIB 1.1, a multiple-precision real ! arithmetic package. A few example FM calculations are carried ! out using 60 significant digit precision. ! The output is saved in file FMSAMPLE.LOG. A comparison file, ! FMSAMPLE.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." !----------------------------------------------------------------------- ! These four common blocks contain information that must be saved ! between calls, so they should be declared in the main program. ! The parameter statement defines various array sizes. !----------------------------------------------------------------------- ! .. Intrinsic Functions .. INTRINSIC mod ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Local Scalars .. INTEGER :: iter, j, k, klog, nerror ! Character string used for input and output. CHARACTER (80) :: st1 ! Declare arrays for FM variables. All are in ! unpacked format. ! .. ! .. Local Arrays .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp, imcomp ! .. ! .. External Subroutines .. EXTERNAL fmabs, fmadd, fmaddi, fmdiv, fmdivi, fmeq, fmform, fmi2m, & fmmpy, fmmpyi, fmset, fmsqr, fmst2m, fmsub, imadd, imdivi, imform, & imi2m, immpyi, impmod, impwr, imst2m, imsub ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! Set precision to give at least 60 significant digits ! and initialize the FMLIB package. ! Note that any program using the FM package MUST call ! FMSET before using the package. CALL fmset(60) nerror = 0 ! Write output to the standard FM output (unit KW, defined ! in subroutine FMSET), and also to the file FMSAMPLE.LOG. klog = 18 OPEN (klog,file='FMSAMPLE.LOG') ! 1. Find a root of the equation ! f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0. ! 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: ! f(x) = ((((x-3)*x+1)*x-4)*x+1)*x-6. ! MA is the previous iterate. ! MB is the current iterate. CALL fmst2m('3.12',ma) ! Print the first iteration. WRITE (kw,90000) WRITE (klog,90000) CALL fmform('F65.60',ma,st1) WRITE (kw,90010) 0, st1(1:65) WRITE (klog,90010) 0, st1(1:65) DO 10 iter = 1, 10 ! MC is f(MA). CALL fmeq(ma,mc) CALL fmaddi(mc,-3) CALL fmmpy(mc,ma,mc) CALL fmaddi(mc,1) CALL fmmpy(mc,ma,mc) CALL fmaddi(mc,-4) CALL fmmpy(mc,ma,mc) CALL fmaddi(mc,1) CALL fmmpy(mc,ma,mc) CALL fmaddi(mc,-6) ! MD is f'(MA). CALL fmmpyi(ma,5,md) CALL fmaddi(md,-12) CALL fmmpy(md,ma,md) CALL fmaddi(md,3) CALL fmmpy(md,ma,md) CALL fmaddi(md,-8) CALL fmmpy(md,ma,md) CALL fmaddi(md,1) CALL fmdiv(mc,md,mb) CALL fmsub(ma,mb,mb) ! Print each iteration. CALL fmform('F65.60',mb,st1) WRITE (kw,90010) iter, st1(1:65) WRITE (klog,90010) iter, st1(1:65) ! Stop iterating if MA and MB agree to over ! 60 places. CALL fmsub(ma,mb,md) CALL fmabs(md,md) CALL fmst2m('1.0E-61',mc) IF (fmcomp(md,'LT',mc)) GO TO 20 ! Set MA = MB for the next iteration. CALL fmeq(mb,ma) 10 CONTINUE ! Check the answer. 20 st1 = '3.120656215326726500470956013523797484654623935599066014' // & '9888284358' CALL fmst2m(st1,mc) CALL fmsub(mc,mb,md) CALL fmabs(md,md) CALL fmst2m('1.0E-61',mc) IF (fmcomp(md,'GT',mc)) THEN nerror = nerror + 1 WRITE (kw,90020) WRITE (klog,90020) END IF ! 2. 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, .... ! MA is the current partial sum. ! MB is the current term. ! MC is k! ! MD is (2k+1)! CALL fmi2m(1,ma) CALL fmeq(ma,mc) CALL fmeq(ma,md) DO 30 k = 1, 200 CALL fmmpyi(mc,k,mc) j = 2*k*(2*k+1) CALL fmmpyi(md,j,md) CALL fmsqr(mc,mb) j = (k+1)*(k+1) CALL fmdivi(mb,j,mb) CALL fmdiv(mb,md,mb) IF (mod(k,2)==0) THEN CALL fmadd(ma,mb,ma) ELSE CALL fmsub(ma,mb,ma) END IF ! Test for convergence. KFLAG will be 1 if the result ! of the last add or subtract is the same as one of the ! input arguments. IF (kflag==1) THEN WRITE (kw,90030) k WRITE (klog,90030) k GO TO 40 END IF 30 CONTINUE ! Print the result. 40 CALL fmmpyi(ma,5,ma) CALL fmdivi(ma,4,ma) CALL fmform('F65.60',ma,st1) WRITE (kw,90040) st1(1:65) WRITE (klog,90040) st1(1:65) ! Check the answer. st1 = '1.20205690315959428539973816151144999076498629234049888' // & '1792271555' CALL fmst2m(st1,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-61',mc) IF (fmcomp(md,'GT',mc)) THEN nerror = nerror + 1 WRITE (kw,90050) WRITE (klog,90050) END IF ! 3. 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. ! MA is the value p being tested. CALL imi2m(10,ma) CALL imi2m(69,mb) CALL impwr(ma,mb,ma) ! 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 CALL imdivi(ma,k,ma) CALL immpyi(ma,k,ma) CALL imi2m(k,mb) CALL imadd(ma,mb,ma) CALL imi2m(1,md) CALL imadd(ma,md,ma) CALL imi2m(3,mc) DO 50 j = 1, 100 ! Compute 3**(p-1) mod p CALL imsub(ma,md,mb) CALL impmod(mc,mb,ma,mc) IF (imcomp(mc,'EQ',md)) THEN ! Check that 7**(p-1) mod p is also 1. CALL imi2m(7,mc) CALL impmod(mc,mb,ma,mc) IF (imcomp(mc,'EQ',md)) THEN WRITE (kw,90060) j WRITE (klog,90060) j GO TO 60 END IF END IF CALL imi2m(3,mc) CALL imi2m(k,mb) CALL imadd(ma,mb,ma) 50 CONTINUE ! Print the result. 60 CALL imform('I72',ma,st1) WRITE (kw,90070) st1(1:72) WRITE (klog,90070) st1(1:72) ! Check the answer. st1 = '1000000000000000000000000000000000000000000000000000' // & '000000000000659661' CALL imst2m(st1,mc) IF (imcomp(ma,'NE',mc)) THEN nerror = nerror + 1 WRITE (kw,90080) WRITE (klog,90080) END IF IF (nerror==0) THEN WRITE (kw,90090) ' All results were ok.' WRITE (klog,90090) ' All results were ok.' END IF STOP 90000 FORMAT (//' Sample 1. Find a root of f(x) = x**5 - 3x**4 + ', & 'x**3 - 4x**2 + x - 6 = 0.'///' Iteration Newton Approximation') 90010 FORMAT (/I10,4X,A) 90020 FORMAT (/' Error in sample case number 1.'/) 90030 FORMAT (///' Sample 2.',8X,I5,' terms were added'/) 90040 FORMAT (' Zeta(3) = ',A) 90050 FORMAT (/' Error in sample case number 2.'/) 90060 FORMAT (///' Sample 3.',8X,I5,' values were tested'/) 90070 FORMAT (' p = ',A) 90080 FORMAT (/' Error in sample case number 3.'/) 90090 FORMAT (//A/) END PROGRAM sample SHAR_EOF fi # end of overwriting check if test -f 'driver5.f90' then echo shar: will not over-write existing file "'driver5.f90'" else cat << SHAR_EOF > 'driver5.f90' PROGRAM testm ! David M. Smith 3-23-97 ! Test program using the FM Fortran-90 module for doing ! arithmetic using the FM, IM, and ZM derived types. ! Any errors will be noted in file Test90.LOG. ! After a successful run of this program, there should be ! one line in Test90.LOG: ! 603 cases tested. No errors were found. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Local Structures .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm2, mzm3, mzm4 ! .. ! .. Local Scalars .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. External Subroutines .. EXTERNAL test1, test10, test11, test12, test13, test14, test15, test16, & test17, test18, test19, test2, test3, test4, test5, test6, test7, & test8, test9, zmset ! .. CALL zmset(50) kdebug = 1 kwarn = 2 ! Write output to the standard FM output (unit KW, defined ! in subroutine FMSET), and also to the file Test90.LOG. klog = 11 OPEN (klog,file='Test90.LOG') ! NERROR is the number of errors found. ! NCASE is the number of cases tested. nerror = 0 ncase = 0 i1 = 131 r1 = 241.21 d1 = 391.61D0 z1 = (411.11D0,421.21D0) c1 = (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) ! Test the '=' assignment operator. CALL test1(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3,mzm4, & nerror,ncase,klog) ! Test the '.EQ.' logical operator. CALL test2(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,mzm1,mzm2,nerror,ncase, & klog) ! Test the '.NE.' logical operator. CALL test3(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,mzm1,mzm2,nerror,ncase, & klog) ! Test the '.GT.' logical operator. CALL test4(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,nerror,ncase,klog) ! Test the '.GE.' logical operator. CALL test5(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,nerror,ncase,klog) ! Test the '.LT.' logical operator. CALL test6(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,nerror,ncase,klog) ! Test the '.LE.' logical operator. CALL test7(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,nerror,ncase,klog) ! Test the '+' arithmetic operator. CALL test8(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '-' arithmetic operator. CALL test9(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '*' arithmetic operator. CALL test10(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '/' arithmetic operator. CALL test11(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '**' arithmetic operator. CALL test12(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test functions ABS, ..., CEILING. CALL test13(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3, & mzm4,nerror,ncase,klog) ! Test functions CMPLX, ..., EXPONENT. CALL test14(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm3,mzm4,nerror,ncase,klog) ! Test functions FLOOR, ..., MIN. CALL test15(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm3,mzm4,nerror,ncase,klog) ! Test functions MINEXPONENT, ..., RRSPACING. CALL test16(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3,mzm4, & nerror,ncase,klog) ! Test functions SCALE, ..., TINY. CALL test17(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm3,mzm4,nerror,ncase,klog) ! Test functions TO_FM, ..., TO_ZM. CALL test18(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3,mzm4, & nerror,ncase,klog) ! Test derived-type interface routines. CALL test19(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3,mzm4, & nerror,ncase,klog) IF (nerror==0) THEN WRITE (kw,*) ncase, ' cases tested. No errors were found. ' WRITE (klog,*) ncase, ' cases tested. No errors were found. ' ELSE WRITE (kw,*) ncase, ' cases tested. ', nerror, ' error(s) found. ' WRITE (klog,*) ncase, ' cases tested. ', nerror, ' error(s) found. ' END IF END PROGRAM testm SUBROUTINE test1(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3, & mzm4,nerror,ncase,klog) ! Test the '=' assignment operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm3, mfm4 TYPE (im) :: mim1, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Structures .. TYPE (fm) :: msmall ! .. ! .. Local Scalars .. COMPLEX (kind(0.0D0)) :: c3 COMPLEX :: z3 REAL (KIND(0.0D0)) :: d3, dsmall REAL :: r3, rsmall INTEGER :: i3 ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. rsmall = epsilon(1.0)*100.0 dsmall = epsilon(1.0D0)*100.0 msmall = epsilon(to_fm(1))*10000.0 ncase = 1 i3 = mfm1 IF (i3/=581) CALL prterr(kw,klog,ncase,nerror) ncase = 2 i3 = mim1 IF (i3/=661) CALL prterr(kw,klog,ncase,nerror) ncase = 3 i3 = mzm1 IF (i3/=731) CALL prterr(kw,klog,ncase,nerror) ncase = 4 r3 = mfm1 IF (abs((r3-581.21)/581.21)>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 5 r3 = mim1 IF (abs((r3-661.0)/661.0)>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 6 r3 = mzm1 IF (abs((r3-731.51)/731.51)>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 7 d3 = mfm1 IF (abs((d3-581.21D0)/581.21D0)>dsmall) CALL prterr(kw,klog,ncase,nerror & ) ncase = 8 d3 = mim1 IF (abs((d3-661.0D0)/661.0D0)>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 9 d3 = mzm1 IF (abs((d3-731.51D0)/731.51D0)>dsmall) CALL prterr(kw,klog,ncase,nerror & ) ncase = 10 z3 = mfm1 IF (abs((z3-581.21)/581.21)>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 11 z3 = mim1 IF (abs((z3-661.0)/661.0)>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 12 z3 = mzm1 IF (abs((z3-(731.51,711.41))/(731.51,711.41))>rsmall) CALL prterr(kw, & klog,ncase,nerror) ncase = 13 c3 = mfm1 IF (abs((c3-581.21D0)/581.21D0)>dsmall) CALL prterr(kw,klog,ncase,nerror & ) ncase = 14 c3 = mim1 IF (abs((c3-661.0D0)/661.0D0)>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 15 c3 = mzm1 IF (abs((c3-(731.51D0,711.41D0))/(731.51D0,711.41D0))>dsmall) CALL & prterr(kw,klog,ncase,nerror) ncase = 16 mfm3 = i1 CALL fm_i2m(131,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_abs(mfm4,mfm4) CALL fm_st2m('0',mfm3) IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 17 mfm3 = r1 CALL fm_st2m('241.21',mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 18 mfm3 = d1 CALL fm_st2m('391.61',mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = dsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 19 mfm3 = z1 CALL fm_st2m('411.11',mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 20 mfm3 = c1 CALL fm_st2m('431.11',mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = dsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 21 mfm3 = mfm1 CALL fm_st2m('581.21',mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) CALL fm_eq(msmall,mfm3) IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 22 mfm3 = mim1 CALL fm_st2m('661',mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_abs(mfm4,mfm4) CALL fm_st2m('0',mfm3) IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 23 mfm3 = mzm1 CALL fm_st2m('731.51',mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = msmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 24 mim3 = i1 CALL im_i2m(131,mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 25 mim3 = r1 CALL im_st2m('241',mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 26 mim3 = d1 CALL im_st2m('391',mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 27 mim3 = z1 CALL im_st2m('411',mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 28 mim3 = c1 CALL im_st2m('431',mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 29 mim3 = mfm1 CALL im_st2m('581',mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 30 mim3 = mim1 CALL im_st2m('661',mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 31 mim3 = mzm1 CALL im_st2m('731',mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 32 mzm3 = i1 CALL zm_i2m(131,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_abs(mzm4,mfm4) CALL fm_st2m('0',mfm3) IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 33 mzm3 = r1 CALL zm_st2m('241.21',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 34 mzm3 = d1 CALL zm_st2m('391.61',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = dsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 35 mzm3 = z1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 36 mzm3 = c1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = dsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 37 mzm3 = mfm1 CALL zm_st2m('581.21',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = msmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 38 mzm3 = mim1 CALL zm_st2m('661',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_abs(mzm4,mfm4) CALL fm_st2m('0',mfm3) IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 39 mzm3 = mzm1 CALL zm_st2m('731.51 + 711.41 i',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = msmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test1 SUBROUTINE test2(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,mzm1,mzm2,nerror, & ncase,klog) ! Test the '.EQ.' logical operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2 TYPE (im) :: mim1, mim2 TYPE (zm) :: mzm1, mzm2 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 40 IF (i1==mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 41 IF (i1==mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 42 IF (i1==mzm1) CALL prterr(kw,klog,ncase,nerror) ncase = 43 IF (r1==mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 44 IF (r1==mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 45 IF (r1==mzm1) CALL prterr(kw,klog,ncase,nerror) ncase = 46 IF (d1==mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 47 IF (d1==mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 48 IF (d1==mzm1) CALL prterr(kw,klog,ncase,nerror) ncase = 49 IF (z1==mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 50 IF (z1==mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 51 IF (z1==mzm1) CALL prterr(kw,klog,ncase,nerror) ncase = 52 IF (c1==mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 53 IF (c1==mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 54 IF (c1==mzm1) CALL prterr(kw,klog,ncase,nerror) ncase = 55 IF (mfm1==i1) CALL prterr(kw,klog,ncase,nerror) ncase = 56 IF (mfm1==r1) CALL prterr(kw,klog,ncase,nerror) ncase = 57 IF (mfm1==d1) CALL prterr(kw,klog,ncase,nerror) ncase = 58 IF (mfm1==z1) CALL prterr(kw,klog,ncase,nerror) ncase = 59 IF (mfm1==c1) CALL prterr(kw,klog,ncase,nerror) ncase = 60 IF (mfm1==mfm2) CALL prterr(kw,klog,ncase,nerror) ncase = 61 IF (mfm1==mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 62 IF (mfm1==mzm1) CALL prterr(kw,klog,ncase,nerror) ncase = 63 IF (mim1==i1) CALL prterr(kw,klog,ncase,nerror) ncase = 64 IF (mim1==r1) CALL prterr(kw,klog,ncase,nerror) ncase = 65 IF (mim1==d1) CALL prterr(kw,klog,ncase,nerror) ncase = 66 IF (mim1==z1) CALL prterr(kw,klog,ncase,nerror) ncase = 67 IF (mim1==c1) CALL prterr(kw,klog,ncase,nerror) ncase = 68 IF (mim1==mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 69 IF (mim1==mim2) CALL prterr(kw,klog,ncase,nerror) ncase = 70 IF (mim1==mzm1) CALL prterr(kw,klog,ncase,nerror) ncase = 71 IF (mzm1==i1) CALL prterr(kw,klog,ncase,nerror) ncase = 72 IF (mzm1==r1) CALL prterr(kw,klog,ncase,nerror) ncase = 73 IF (mzm1==d1) CALL prterr(kw,klog,ncase,nerror) ncase = 74 IF (mzm1==z1) CALL prterr(kw,klog,ncase,nerror) ncase = 75 IF (mzm1==c1) CALL prterr(kw,klog,ncase,nerror) ncase = 76 IF (mzm1==mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 77 IF (mzm1==mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 78 IF (mzm1==mzm2) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test2 SUBROUTINE test3(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,mzm1,mzm2,nerror, & ncase,klog) ! Test the '.NE.' logical operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2 TYPE (im) :: mim1, mim2 TYPE (zm) :: mzm1, mzm2 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 79 IF ( .NOT. (i1/=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 80 IF ( .NOT. (i1/=mim1)) CALL prterr(kw,klog,ncase,nerror) ncase = 81 IF ( .NOT. (i1/=mzm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 82 IF ( .NOT. (r1/=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 83 IF ( .NOT. (r1/=mim1)) CALL prterr(kw,klog,ncase,nerror) ncase = 84 IF ( .NOT. (r1/=mzm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 85 IF ( .NOT. (d1/=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 86 IF ( .NOT. (d1/=mim1)) CALL prterr(kw,klog,ncase,nerror) ncase = 87 IF ( .NOT. (d1/=mzm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 88 IF ( .NOT. (z1/=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 89 IF ( .NOT. (z1/=mim1)) CALL prterr(kw,klog,ncase,nerror) ncase = 90 IF ( .NOT. (z1/=mzm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 91 IF ( .NOT. (c1/=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 92 IF ( .NOT. (c1/=mim1)) CALL prterr(kw,klog,ncase,nerror) ncase = 93 IF ( .NOT. (c1/=mzm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 94 IF ( .NOT. (mfm1/=i1)) CALL prterr(kw,klog,ncase,nerror) ncase = 95 IF ( .NOT. (mfm1/=r1)) CALL prterr(kw,klog,ncase,nerror) ncase = 96 IF ( .NOT. (mfm1/=d1)) CALL prterr(kw,klog,ncase,nerror) ncase = 97 IF ( .NOT. (mfm1/=z1)) CALL prterr(kw,klog,ncase,nerror) ncase = 98 IF ( .NOT. (mfm1/=c1)) CALL prterr(kw,klog,ncase,nerror) ncase = 99 IF ( .NOT. (mfm1/=mfm2)) CALL prterr(kw,klog,ncase,nerror) ncase = 100 IF ( .NOT. (mfm1/=mim1)) CALL prterr(kw,klog,ncase,nerror) ncase = 101 IF ( .NOT. (mfm1/=mzm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 102 IF ( .NOT. (mim1/=i1)) CALL prterr(kw,klog,ncase,nerror) ncase = 103 IF ( .NOT. (mim1/=r1)) CALL prterr(kw,klog,ncase,nerror) ncase = 104 IF ( .NOT. (mim1/=d1)) CALL prterr(kw,klog,ncase,nerror) ncase = 105 IF ( .NOT. (mim1/=z1)) CALL prterr(kw,klog,ncase,nerror) ncase = 106 IF ( .NOT. (mim1/=c1)) CALL prterr(kw,klog,ncase,nerror) ncase = 107 IF ( .NOT. (mim1/=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 108 IF ( .NOT. (mim1/=mim2)) CALL prterr(kw,klog,ncase,nerror) ncase = 109 IF ( .NOT. (mim1/=mzm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 110 IF ( .NOT. (mzm1/=i1)) CALL prterr(kw,klog,ncase,nerror) ncase = 111 IF ( .NOT. (mzm1/=r1)) CALL prterr(kw,klog,ncase,nerror) ncase = 112 IF ( .NOT. (mzm1/=d1)) CALL prterr(kw,klog,ncase,nerror) ncase = 113 IF ( .NOT. (mzm1/=z1)) CALL prterr(kw,klog,ncase,nerror) ncase = 114 IF ( .NOT. (mzm1/=c1)) CALL prterr(kw,klog,ncase,nerror) ncase = 115 IF ( .NOT. (mzm1/=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 116 IF ( .NOT. (mzm1/=mim1)) CALL prterr(kw,klog,ncase,nerror) ncase = 117 IF ( .NOT. (mzm1/=mzm2)) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test3 SUBROUTINE test4(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,nerror,ncase,klog) ! Test the '.GT.' logical operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2 TYPE (im) :: mim1, mim2 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 118 IF (i1>mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 119 IF (i1>mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 120 IF (r1>mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 121 IF (r1>mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 122 IF (d1>mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 123 IF (d1>mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 124 IF ( .NOT. (mfm1>i1)) CALL prterr(kw,klog,ncase,nerror) ncase = 125 IF ( .NOT. (mfm1>r1)) CALL prterr(kw,klog,ncase,nerror) ncase = 126 IF ( .NOT. (mfm1>d1)) CALL prterr(kw,klog,ncase,nerror) ncase = 127 IF ( .NOT. (mfm1>mfm2)) CALL prterr(kw,klog,ncase,nerror) ncase = 128 IF (mfm1>mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 129 IF ( .NOT. (mim1>i1)) CALL prterr(kw,klog,ncase,nerror) ncase = 130 IF ( .NOT. (mim1>r1)) CALL prterr(kw,klog,ncase,nerror) ncase = 131 IF ( .NOT. (mim1>d1)) CALL prterr(kw,klog,ncase,nerror) ncase = 132 IF ( .NOT. (mim1>mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 133 IF ( .NOT. (mim1>mim2)) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test4 SUBROUTINE test5(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,nerror,ncase,klog) ! Test the '.GE.' logical operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2 TYPE (im) :: mim1, mim2 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 134 IF (i1>=mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 135 IF (i1>=mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 136 IF (r1>=mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 137 IF (r1>=mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 138 IF (d1>=mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 139 IF (d1>=mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 140 IF ( .NOT. (mfm1>=i1)) CALL prterr(kw,klog,ncase,nerror) ncase = 141 IF ( .NOT. (mfm1>=r1)) CALL prterr(kw,klog,ncase,nerror) ncase = 142 IF ( .NOT. (mfm1>=d1)) CALL prterr(kw,klog,ncase,nerror) ncase = 143 IF ( .NOT. (mfm1>=mfm2)) CALL prterr(kw,klog,ncase,nerror) ncase = 144 IF (mfm1>=mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 145 IF ( .NOT. (mim1>=i1)) CALL prterr(kw,klog,ncase,nerror) ncase = 146 IF ( .NOT. (mim1>=r1)) CALL prterr(kw,klog,ncase,nerror) ncase = 147 IF ( .NOT. (mim1>=d1)) CALL prterr(kw,klog,ncase,nerror) ncase = 148 IF ( .NOT. (mim1>=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 149 IF ( .NOT. (mim1>=mim2)) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test5 SUBROUTINE test6(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,nerror,ncase,klog) ! Test the '.LT.' logical operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2 TYPE (im) :: mim1, mim2 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 150 IF ( .NOT. (i1rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 186 CALL fm_st2m('241.21',mfm4) CALL fm_st2m('661',mfm3) CALL fm_add(mfm4,mfm3,mfm4) mfm3 = r1 + mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 187 mzm3 = r1 + mzm1 CALL zm_st2m('241.21',mzm4) CALL zm_add(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 188 mfm3 = d1 + mfm1 CALL fm_st2m('391.61',mfm4) CALL fm_add(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 189 CALL fm_st2m('391.61',mfm4) CALL fm_st2m('661',mfm3) CALL fm_add(mfm4,mfm3,mfm4) mfm3 = d1 + mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 190 mzm3 = d1 + mzm1 CALL zm_st2m('391.61',mzm4) CALL zm_add(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 191 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_add(mzm4,mzm3,mzm4) mzm3 = z1 + mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 192 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_add(mzm4,mzm3,mzm4) mzm3 = z1 + mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 193 mzm3 = z1 + mzm1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_add(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 194 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_add(mzm4,mzm3,mzm4) mzm3 = c1 + mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 195 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_add(mzm4,mzm3,mzm4) mzm3 = c1 + mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 196 mzm3 = c1 + mzm1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_add(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 197 mfm3 = mfm1 + i1 CALL fm_st2m('131',mfm4) CALL fm_add(mfm1,mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 198 mfm3 = mfm1 + r1 CALL fm_st2m('241.21',mfm4) CALL fm_add(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 199 mfm3 = mfm1 + d1 CALL fm_st2m('391.61',mfm4) CALL fm_add(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 200 CALL zm_st2m('581.21',mzm3) CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_add(mzm3,mzm4,mzm4) mzm3 = mfm1 + z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 201 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('581.21',mzm4) CALL zm_add(mzm4,mzm3,mzm4) mzm3 = mfm1 + c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 202 mfm3 = mfm1 + mfm2 CALL fm_add(mfm1,mfm2,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 203 mfm3 = mfm1 + mim1 CALL fm_st2m('661',mfm4) CALL fm_add(mfm1,mfm4,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 204 mzm3 = mfm1 + mzm1 CALL zm_st2m('581.21',mzm4) CALL zm_add(mzm4,mzm1,mzm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 205 mim3 = mim1 + i1 CALL im_st2m('131',mim4) CALL im_add(mim1,mim4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 206 CALL fm_st2m('241.21',mfm3) CALL fm_st2m('661',mfm4) CALL fm_add(mfm4,mfm3,mfm4) mfm3 = mim1 + r1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 207 CALL fm_st2m('391.61',mfm3) CALL fm_st2m('661',mfm4) CALL fm_add(mfm4,mfm3,mfm4) mfm3 = mim1 + d1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 208 CALL zm_st2m('411.11 + 421.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_add(mzm4,mzm3,mzm4) mzm3 = mim1 + z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 209 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_add(mzm4,mzm3,mzm4) mzm3 = mim1 + c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 210 mfm3 = mim1 + mfm1 CALL fm_st2m('661',mfm4) CALL fm_add(mfm4,mfm1,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 211 mim3 = mim1 + mim2 CALL im_add(mim1,mim2,mim4) IF (mim4/=mim3) CALL prterr(kw,klog,ncase,nerror) ncase = 212 mzm3 = mim1 + mzm1 CALL zm_st2m('661',mzm4) CALL zm_add(mzm4,mzm1,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 213 mzm3 = mzm1 + i1 CALL zm_st2m('131',mzm4) CALL zm_add(mzm1,mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 214 mzm3 = mzm1 + r1 CALL zm_st2m('241.21',mzm4) CALL zm_add(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 215 mzm3 = mzm1 + d1 CALL zm_st2m('391.61',mzm4) CALL zm_add(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 216 mzm3 = mzm1 + z1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_add(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 217 mzm3 = mzm1 + c1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_add(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 218 mzm3 = mzm1 + mfm1 CALL zm_st2m('581.21',mzm4) CALL zm_add(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 219 mzm3 = mzm1 + mim1 CALL zm_st2m('661',mzm4) CALL zm_add(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 220 mzm3 = mzm1 + mzm2 CALL zm_add(mzm1,mzm2,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 221 mfm3 = + mfm1 CALL fm_eq(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 222 mim3 = + mim1 CALL im_eq(mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 223 mzm3 = + mzm1 CALL zm_eq(mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test8 SUBROUTINE test9(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4, & mzm1,mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '-' arithmetic operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm2, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: dsmall REAL :: rsmall ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. rsmall = epsilon(1.0)*100.0 dsmall = epsilon(1.0D0)*100.0 ncase = 224 mfm3 = i1 - mfm1 CALL fm_st2m('131',mfm4) CALL fm_sub(mfm4,mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 225 mim3 = i1 - mim1 CALL im_st2m('131',mim4) CALL im_sub(mim4,mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 226 mzm3 = i1 - mzm1 CALL zm_st2m('131',mzm4) CALL zm_sub(mzm4,mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 227 mfm3 = r1 - mfm1 CALL fm_st2m('241.21',mfm4) CALL fm_sub(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 228 CALL fm_st2m('241.21',mfm4) CALL fm_st2m('661',mfm3) CALL fm_sub(mfm4,mfm3,mfm4) mfm3 = r1 - mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 229 mzm3 = r1 - mzm1 CALL zm_st2m('241.21',mzm4) CALL zm_sub(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 230 mfm3 = d1 - mfm1 CALL fm_st2m('391.61',mfm4) CALL fm_sub(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 231 CALL fm_st2m('391.61',mfm4) CALL fm_st2m('661',mfm3) CALL fm_sub(mfm4,mfm3,mfm4) mfm3 = d1 - mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 232 mzm3 = d1 - mzm1 CALL zm_st2m('391.61',mzm4) CALL zm_sub(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 233 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_sub(mzm4,mzm3,mzm4) mzm3 = z1 - mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 234 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_sub(mzm4,mzm3,mzm4) mzm3 = z1 - mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 235 mzm3 = z1 - mzm1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_sub(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 236 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_sub(mzm4,mzm3,mzm4) mzm3 = c1 - mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 237 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_sub(mzm4,mzm3,mzm4) mzm3 = c1 - mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 238 mzm3 = c1 - mzm1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_sub(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 239 mfm3 = mfm1 - i1 CALL fm_st2m('131',mfm4) CALL fm_sub(mfm1,mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 240 mfm3 = mfm1 - r1 CALL fm_st2m('241.21',mfm4) CALL fm_sub(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 241 mfm3 = mfm1 - d1 CALL fm_st2m('391.61',mfm4) CALL fm_sub(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 242 CALL zm_st2m('581.21',mzm3) CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) mzm3 = mfm1 - z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 243 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('581.21',mzm4) CALL zm_sub(mzm4,mzm3,mzm4) mzm3 = mfm1 - c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 244 mfm3 = mfm1 - mfm2 CALL fm_sub(mfm1,mfm2,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 245 mfm3 = mfm1 - mim1 CALL fm_st2m('661',mfm4) CALL fm_sub(mfm1,mfm4,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 246 mzm3 = mfm1 - mzm1 CALL zm_st2m('581.21',mzm4) CALL zm_sub(mzm4,mzm1,mzm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 247 mim3 = mim1 - i1 CALL im_st2m('131',mim4) CALL im_sub(mim1,mim4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 248 CALL fm_st2m('241.21',mfm3) CALL fm_st2m('661',mfm4) CALL fm_sub(mfm4,mfm3,mfm4) mfm3 = mim1 - r1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 249 CALL fm_st2m('391.61',mfm3) CALL fm_st2m('661',mfm4) CALL fm_sub(mfm4,mfm3,mfm4) mfm3 = mim1 - d1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 250 CALL zm_st2m('411.11 + 421.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_sub(mzm4,mzm3,mzm4) mzm3 = mim1 - z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 251 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_sub(mzm4,mzm3,mzm4) mzm3 = mim1 - c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 252 mfm3 = mim1 - mfm1 CALL fm_st2m('661',mfm4) CALL fm_sub(mfm4,mfm1,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 253 mim3 = mim1 - mim2 CALL im_sub(mim1,mim2,mim4) IF (mim4/=mim3) CALL prterr(kw,klog,ncase,nerror) ncase = 254 mzm3 = mim1 - mzm1 CALL zm_st2m('661',mzm4) CALL zm_sub(mzm4,mzm1,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 255 mzm3 = mzm1 - i1 CALL zm_st2m('131',mzm4) CALL zm_sub(mzm1,mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 256 mzm3 = mzm1 - r1 CALL zm_st2m('241.21',mzm4) CALL zm_sub(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 257 mzm3 = mzm1 - d1 CALL zm_st2m('391.61',mzm4) CALL zm_sub(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 258 mzm3 = mzm1 - z1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_sub(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 259 mzm3 = mzm1 - c1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_sub(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 260 mzm3 = mzm1 - mfm1 CALL zm_st2m('581.21',mzm4) CALL zm_sub(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 261 mzm3 = mzm1 - mim1 CALL zm_st2m('661',mzm4) CALL zm_sub(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 262 mzm3 = mzm1 - mzm2 CALL zm_sub(mzm1,mzm2,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 263 mfm3 = -mfm1 CALL fm_i2m(0,mfm4) CALL fm_sub(mfm4,mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 264 mim3 = -mim1 CALL im_i2m(0,mim4) CALL im_sub(mim4,mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 265 mzm3 = -mzm1 CALL zm_i2m(0,mzm4) CALL zm_sub(mzm4,mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test9 SUBROUTINE test10(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4, & mzm1,mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '*' arithmetic operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm2, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: dsmall REAL :: rsmall ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. rsmall = epsilon(1.0)*100.0 dsmall = epsilon(1.0D0)*100.0 ncase = 266 mfm3 = i1*mfm1 CALL fm_st2m('131',mfm4) CALL fm_mpy(mfm4,mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 267 mim3 = i1*mim1 CALL im_st2m('131',mim4) CALL im_mpy(mim4,mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 268 mzm3 = i1*mzm1 CALL zm_st2m('131',mzm4) CALL zm_mpy(mzm4,mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 269 mfm3 = r1*mfm1 CALL fm_st2m('241.21',mfm4) CALL fm_mpy(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 270 CALL fm_st2m('241.21',mfm4) CALL fm_st2m('661',mfm3) CALL fm_mpy(mfm4,mfm3,mfm4) mfm3 = r1*mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 271 mzm3 = r1*mzm1 CALL zm_st2m('241.21',mzm4) CALL zm_mpy(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 272 mfm3 = d1*mfm1 CALL fm_st2m('391.61',mfm4) CALL fm_mpy(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 273 CALL fm_st2m('391.61',mfm4) CALL fm_st2m('661',mfm3) CALL fm_mpy(mfm4,mfm3,mfm4) mfm3 = d1*mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 274 mzm3 = d1*mzm1 CALL zm_st2m('391.61',mzm4) CALL zm_mpy(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 275 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_mpy(mzm4,mzm3,mzm4) mzm3 = z1*mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 276 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_mpy(mzm4,mzm3,mzm4) mzm3 = z1*mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 277 mzm3 = z1*mzm1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_mpy(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 278 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_mpy(mzm4,mzm3,mzm4) mzm3 = c1*mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 279 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_mpy(mzm4,mzm3,mzm4) mzm3 = c1*mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 280 mzm3 = c1*mzm1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_mpy(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 281 mfm3 = mfm1*i1 CALL fm_st2m('131',mfm4) CALL fm_mpy(mfm1,mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 282 mfm3 = mfm1*r1 CALL fm_st2m('241.21',mfm4) CALL fm_mpy(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 283 mfm3 = mfm1*d1 CALL fm_st2m('391.61',mfm4) CALL fm_mpy(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 284 CALL zm_st2m('581.21',mzm3) CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_mpy(mzm3,mzm4,mzm4) mzm3 = mfm1*z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 285 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('581.21',mzm4) CALL zm_mpy(mzm4,mzm3,mzm4) mzm3 = mfm1*c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 286 mfm3 = mfm1*mfm2 CALL fm_mpy(mfm1,mfm2,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 287 mfm3 = mfm1*mim1 CALL fm_st2m('661',mfm4) CALL fm_mpy(mfm1,mfm4,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 288 mzm3 = mfm1*mzm1 CALL zm_st2m('581.21',mzm4) CALL zm_mpy(mzm4,mzm1,mzm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 289 mim3 = mim1*i1 CALL im_st2m('131',mim4) CALL im_mpy(mim1,mim4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 290 CALL fm_st2m('241.21',mfm3) CALL fm_st2m('661',mfm4) CALL fm_mpy(mfm4,mfm3,mfm4) mfm3 = mim1*r1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 291 CALL fm_st2m('391.61',mfm3) CALL fm_st2m('661',mfm4) CALL fm_mpy(mfm4,mfm3,mfm4) mfm3 = mim1*d1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 292 CALL zm_st2m('411.11 + 421.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_mpy(mzm4,mzm3,mzm4) mzm3 = mim1*z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 293 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_mpy(mzm4,mzm3,mzm4) mzm3 = mim1*c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 294 mfm3 = mim1*mfm1 CALL fm_st2m('661',mfm4) CALL fm_mpy(mfm4,mfm1,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 295 mim3 = mim1*mim2 CALL im_mpy(mim1,mim2,mim4) IF (mim4/=mim3) CALL prterr(kw,klog,ncase,nerror) ncase = 296 mzm3 = mim1*mzm1 CALL zm_st2m('661',mzm4) CALL zm_mpy(mzm4,mzm1,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 297 mzm3 = mzm1*i1 CALL zm_st2m('131',mzm4) CALL zm_mpy(mzm1,mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 298 mzm3 = mzm1*r1 CALL zm_st2m('241.21',mzm4) CALL zm_mpy(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 299 mzm3 = mzm1*d1 CALL zm_st2m('391.61',mzm4) CALL zm_mpy(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 300 mzm3 = mzm1*z1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_mpy(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 301 mzm3 = mzm1*c1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_mpy(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 302 mzm3 = mzm1*mfm1 CALL zm_st2m('581.21',mzm4) CALL zm_mpy(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 303 mzm3 = mzm1*mim1 CALL zm_st2m('661',mzm4) CALL zm_mpy(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 304 mzm3 = mzm1*mzm2 CALL zm_mpy(mzm1,mzm2,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test10 SUBROUTINE test11(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4, & mzm1,mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '/' arithmetic operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm2, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: dsmall REAL :: rsmall ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. rsmall = epsilon(1.0)*100.0 dsmall = epsilon(1.0D0)*100.0 ncase = 305 mfm3 = i1/mfm1 CALL fm_st2m('131',mfm4) CALL fm_div(mfm4,mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 306 mim3 = i1/mim1 CALL im_st2m('131',mim4) CALL im_div(mim4,mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 307 mzm3 = i1/mzm1 CALL zm_st2m('131',mzm4) CALL zm_div(mzm4,mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 308 mfm3 = r1/mfm1 CALL fm_st2m('241.21',mfm4) CALL fm_div(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 309 CALL fm_st2m('241.21',mfm4) CALL fm_st2m('661',mfm3) CALL fm_div(mfm4,mfm3,mfm4) mfm3 = r1/mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 310 mzm3 = r1/mzm1 CALL zm_st2m('241.21',mzm4) CALL zm_div(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 311 mfm3 = d1/mfm1 CALL fm_st2m('391.61',mfm4) CALL fm_div(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 312 CALL fm_st2m('391.61',mfm4) CALL fm_st2m('661',mfm3) CALL fm_div(mfm4,mfm3,mfm4) mfm3 = d1/mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 313 mzm3 = d1/mzm1 CALL zm_st2m('391.61',mzm4) CALL zm_div(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 314 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_div(mzm4,mzm3,mzm4) mzm3 = z1/mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 315 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_div(mzm4,mzm3,mzm4) mzm3 = z1/mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 316 mzm3 = z1/mzm1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_div(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 317 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_div(mzm4,mzm3,mzm4) mzm3 = c1/mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 318 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_div(mzm4,mzm3,mzm4) mzm3 = c1/mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 319 mzm3 = c1/mzm1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_div(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 320 mfm3 = mfm1/i1 CALL fm_st2m('131',mfm4) CALL fm_div(mfm1,mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 321 mfm3 = mfm1/r1 CALL fm_st2m('241.21',mfm4) CALL fm_div(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 322 mfm3 = mfm1/d1 CALL fm_st2m('391.61',mfm4) CALL fm_div(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 323 CALL zm_st2m('581.21',mzm3) CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_div(mzm3,mzm4,mzm4) mzm3 = mfm1/z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 324 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('581.21',mzm4) CALL zm_div(mzm4,mzm3,mzm4) mzm3 = mfm1/c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 325 mfm3 = mfm1/mfm2 CALL fm_div(mfm1,mfm2,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 326 mfm3 = mfm1/mim1 CALL fm_st2m('661',mfm4) CALL fm_div(mfm1,mfm4,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 327 mzm3 = mfm1/mzm1 CALL zm_st2m('581.21',mzm4) CALL zm_div(mzm4,mzm1,mzm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 328 mim3 = mim1/i1 CALL im_st2m('131',mim4) CALL im_div(mim1,mim4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 329 CALL fm_st2m('241.21',mfm3) CALL fm_st2m('661',mfm4) CALL fm_div(mfm4,mfm3,mfm4) mfm3 = mim1/r1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 330 CALL fm_st2m('391.61',mfm3) CALL fm_st2m('661',mfm4) CALL fm_div(mfm4,mfm3,mfm4) mfm3 = mim1/d1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 331 CALL zm_st2m('411.11 + 421.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_div(mzm4,mzm3,mzm4) mzm3 = mim1/z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 332 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_div(mzm4,mzm3,mzm4) mzm3 = mim1/c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 333 mfm3 = mim1/mfm1 CALL fm_st2m('661',mfm4) CALL fm_div(mfm4,mfm1,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 334 mim3 = mim1/mim2 CALL im_div(mim1,mim2,mim4) IF (mim4/=mim3) CALL prterr(kw,klog,ncase,nerror) ncase = 335 mzm3 = mim1/mzm1 CALL zm_st2m('661',mzm4) CALL zm_div(mzm4,mzm1,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 336 mzm3 = mzm1/i1 CALL zm_st2m('131',mzm4) CALL zm_div(mzm1,mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 337 mzm3 = mzm1/r1 CALL zm_st2m('241.21',mzm4) CALL zm_div(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 338 mzm3 = mzm1/d1 CALL zm_st2m('391.61',mzm4) CALL zm_div(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 339 mzm3 = mzm1/z1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_div(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 340 mzm3 = mzm1/c1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_div(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 341 mzm3 = mzm1/mfm1 CALL zm_st2m('581.21',mzm4) CALL zm_div(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 342 mzm3 = mzm1/mim1 CALL zm_st2m('661',mzm4) CALL zm_div(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 343 mzm3 = mzm1/mzm2 CALL zm_div(mzm1,mzm2,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test11 SUBROUTINE test12(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4, & mzm1,mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '**' arithmetic operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm2, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: dsmall REAL :: rsmall INTEGER :: i3 ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ! Use a larger error tolerance for large exponents. rsmall = epsilon(1.0)*10000.0 dsmall = epsilon(1.0D0)*10000.0 ncase = 344 mfm3 = i1**mfm1 CALL fm_st2m('131',mfm4) CALL fm_pwr(mfm4,mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 345 i3 = 13 mim3 = i3**mim1 CALL im_st2m('13',mim4) CALL im_pwr(mim4,mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 346 mzm3 = i1**mzm1 CALL zm_st2m('131',mzm4) CALL zm_pwr(mzm4,mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 347 mfm3 = r1**mfm1 CALL fm_st2m('241.21',mfm4) CALL fm_pwr(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 348 CALL fm_st2m('241.21',mfm4) CALL fm_st2m('661',mfm3) CALL fm_pwr(mfm4,mfm3,mfm4) mfm3 = r1**mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 349 mzm3 = r1**mzm1 CALL zm_st2m('241.21',mzm4) CALL zm_pwr(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 350 mfm3 = d1**mfm1 CALL fm_st2m('391.61',mfm4) CALL fm_pwr(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 351 CALL fm_st2m('391.61',mfm4) CALL fm_st2m('661',mfm3) CALL fm_pwr(mfm4,mfm3,mfm4) mfm3 = d1**mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 352 mzm3 = d1**mzm1 CALL zm_st2m('391.61',mzm4) CALL zm_pwr(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 353 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_pwr(mzm4,mzm3,mzm4) mzm3 = z1**mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 354 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_pwr(mzm4,mzm3,mzm4) mzm3 = z1**mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 355 mzm3 = z1**mzm1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_pwr(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 356 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_pwr(mzm4,mzm3,mzm4) mzm3 = c1**mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 357 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_pwr(mzm4,mzm3,mzm4) mzm3 = c1**mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 358 mzm3 = c1**mzm1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_pwr(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 359 mfm3 = mfm1**i1 CALL fm_st2m('131',mfm4) CALL fm_pwr(mfm1,mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 360 mfm3 = mfm1**r1 CALL fm_st2m('241.21',mfm4) CALL fm_pwr(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 361 mfm3 = mfm1**d1 CALL fm_st2m('391.61',mfm4) CALL fm_pwr(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 362 CALL zm_st2m('581.21',mzm3) CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_pwr(mzm3,mzm4,mzm4) mzm3 = mfm1**z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 363 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('581.21',mzm4) CALL zm_pwr(mzm4,mzm3,mzm4) mzm3 = mfm1**c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 364 mfm3 = mfm1**mfm2 CALL fm_pwr(mfm1,mfm2,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 365 mfm3 = mfm1**mim1 CALL fm_st2m('661',mfm4) CALL fm_pwr(mfm1,mfm4,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 366 mzm3 = mfm1**mzm1 CALL zm_st2m('581.21',mzm4) CALL zm_pwr(mzm4,mzm1,mzm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 367 i3 = 17 mim3 = mim1**i3 CALL im_st2m('17',mim4) CALL im_pwr(mim1,mim4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 368 CALL fm_st2m('241.21',mfm3) CALL fm_st2m('661',mfm4) CALL fm_pwr(mfm4,mfm3,mfm4) mfm3 = mim1**r1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 369 CALL fm_st2m('391.61',mfm3) CALL fm_st2m('661',mfm4) CALL fm_pwr(mfm4,mfm3,mfm4) mfm3 = mim1**d1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 370 CALL zm_st2m('411.11 + 421.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_pwr(mzm4,mzm3,mzm4) mzm3 = mim1**z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 371 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_pwr(mzm4,mzm3,mzm4) mzm3 = mim1**c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 372 mfm3 = mim1**mfm1 CALL fm_st2m('661',mfm4) CALL fm_pwr(mfm4,mfm1,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 373 mim4 = 19 mim3 = mim1**mim4 CALL im_pwr(mim1,mim4,mim4) IF (mim4/=mim3) CALL prterr(kw,klog,ncase,nerror) ncase = 374 mzm3 = mim1**mzm1 CALL zm_st2m('661',mzm4) CALL zm_pwr(mzm4,mzm1,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 375 mzm3 = mzm1**i1 CALL zm_st2m('131',mzm4) CALL zm_pwr(mzm1,mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 376 mzm3 = mzm1**r1 CALL zm_st2m('241.21',mzm4) CALL zm_pwr(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 377 mzm3 = mzm1**d1 CALL zm_st2m('391.61',mzm4) CALL zm_pwr(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 378 mzm3 = mzm1**z1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_pwr(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 379 mzm3 = mzm1**c1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_pwr(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 380 mzm3 = mzm1**mfm1 CALL zm_st2m('581.21',mzm4) CALL zm_pwr(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 381 mzm3 = mzm1**mim1 CALL zm_st2m('661',mzm4) CALL zm_pwr(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 382 mzm3 = mzm1**mzm2 CALL zm_pwr(mzm1,mzm2,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test12 SUBROUTINE test13(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim3,mim4,mzm1, & mzm3,mzm4,nerror,ncase,klog) ! Test functions ABS, ..., CEILING. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Scalars .. INTEGER :: j, jerr ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 383 mfm3 = abs(mfm1) CALL fm_abs(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 384 mim3 = abs(mim1) CALL im_abs(mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 385 mfm3 = abs(mzm1) CALL zm_abs(mzm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 386 CALL fm_st2m('0.7654',mfm4) mfm3 = acos(mfm4) CALL fm_acos(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 387 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = acos(mzm4) CALL zm_acos(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 388 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 = 389 mfm3 = aint(mfm1) CALL fm_int(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 390 mzm3 = aint(mzm1) CALL zm_int(mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 391 mfm3 = anint(mfm1) CALL fm_nint(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 392 mzm3 = anint(mzm1) CALL zm_nint(mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 393 CALL fm_st2m('0.7654',mfm4) mfm3 = asin(mfm4) CALL fm_asin(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 394 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = asin(mzm4) CALL zm_asin(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 395 CALL fm_st2m('0.7654',mfm4) mfm3 = atan(mfm4) CALL fm_atan(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 396 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = atan(mzm4) CALL zm_atan(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 397 mfm3 = atan2(mfm1,mfm2) CALL fm_atn2(mfm1,mfm2,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 398 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 END IF END DO IF (jerr>=0) CALL prterr(kw,klog,ncase,nerror) ncase = 399 CALL fm_st2m('12.37654',mfm4) mfm3 = ceiling(mfm4) CALL fm_st2m('13',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 400 CALL fm_st2m('-12.7654',mfm4) mfm3 = ceiling(mfm4) CALL fm_st2m('-12',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 401 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 = 402 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 test13 SUBROUTINE test14(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4, & mzm1,mzm3,mzm4,nerror,ncase,klog) ! Test functions CMPLX, ..., EXPONENT. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Structures .. TYPE (fm) :: mfmv1(3), mfmv2(3) TYPE (im) :: mimv1(3), mimv2(3) TYPE (zm) :: mzmv1(3), mzmv2(3) ! .. ! .. Local Scalars .. INTEGER :: j ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 403 mzm3 = cmplx(mfm1,mfm2) CALL zm_cmpx(mfm1,mfm2,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 404 mzm3 = cmplx(mim1,mim2) CALL im_i2fm(mim1,mfm3) CALL im_i2fm(mim2,mfm4) CALL zm_cmpx(mfm3,mfm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 405 mzm3 = cmplx(mfm1) CALL fm_i2m(0,mfm4) CALL zm_cmpx(mfm1,mfm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 406 mzm3 = cmplx(mim1) CALL im_i2fm(mim1,mfm3) CALL fm_i2m(0,mfm4) CALL zm_cmpx(mfm3,mfm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 407 mzm3 = conjg(mzm1) CALL zm_conj(mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 408 CALL fm_st2m('0.7654',mfm4) mfm3 = cos(mfm4) CALL fm_cos(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 409 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = cos(mzm4) CALL zm_cos(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 410 CALL fm_st2m('0.7654',mfm4) mfm3 = cosh(mfm4) CALL fm_cosh(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 411 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = cosh(mzm4) CALL zm_cosh(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 412 mfm3 = dble(mfm1) CALL fm_eq(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 413 mfm3 = dble(mim1) CALL im_i2fm(mim1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 414 mfm3 = dble(mzm1) CALL zm_real(mzm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 415 j = digits(mfm1) IF (j/=ndig) CALL prterr(kw,klog,ncase,nerror) ncase = 416 j = digits(mim1) IF (j/=ndigmx) CALL prterr(kw,klog,ncase,nerror) ncase = 417 j = digits(mzm1) IF (j/=ndig) CALL prterr(kw,klog,ncase,nerror) ncase = 418 mfm3 = dim(mfm1,mfm2) CALL fm_dim(mfm1,mfm2,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 419 mim3 = dim(mim1,mim2) CALL im_dim(mim1,mim2,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 420 mfm3 = dint (mfm1) CALL fm_int(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 421 mzm3 = dint (mzm1) CALL zm_int(mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 422 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) END DO IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 423 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) END DO IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 424 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) END DO IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 425 mfm3 = epsilon(mfm1) CALL fm_i2m(1,mfm4) CALL fm_ulp(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 426 CALL fm_st2m('0.7654',mfm4) mfm3 = exp(mfm4) CALL fm_exp(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 427 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = exp(mzm4) CALL zm_exp(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 428 j = exponent(mfm1) IF (j/=int(mfm1%mfm(1))) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test14 SUBROUTINE test15(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4, & mzm1,mzm3,mzm4,nerror,ncase,klog) ! Test functions FLOOR, ..., MIN. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Structures .. TYPE (fm) :: mfma(3,3), mfmb(3,3), mfmc(3,3) TYPE (im) :: mima(2,2), mimb(2,2), mimc(2,2) TYPE (zm) :: mzma(2,3), mzmb(3,4), mzmc(2,4) ! .. ! .. Local Scalars .. INTEGER :: i, j ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 429 CALL fm_st2m('12.37654',mfm4) mfm3 = floor(mfm4) CALL fm_st2m('12',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 430 CALL fm_st2m('-12.7654',mfm4) mfm3 = floor(mfm4) CALL fm_st2m('-13',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 431 CALL im_st2m('12',mim4) mim3 = floor(mim4) CALL im_st2m('12',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 432 CALL im_st2m('-123',mim4) mim3 = floor(mim4) CALL im_st2m('-123',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 433 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 = 434 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 = 435 CALL fm_st2m('12.37654',mfm4) mfm3 = fraction(mfm4) mfm4%mfm(1) = 0 IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 436 CALL zm_st2m('12.37654 - 22.54',mzm4) mzm3 = fraction(mzm4) mzm4%mzm(1) = 0 mzm4%mzm(kptimu+1) = 0 IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 437 mfm3 = huge(mfm1) CALL fm_big(mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 438 mim3 = huge(mim1) CALL im_big(mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 439 mzm3 = huge(mzm1) CALL fm_big(mfm4) CALL zm_cmpx(mfm4,mfm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 440 mim3 = int(mfm1) CALL fm_int(mfm1,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 441 mim3 = int(mim1) CALL im_eq(mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 442 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 = 443 CALL fm_st2m('0.7654',mfm4) mfm3 = log(mfm4) CALL fm_ln(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 444 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = log(mzm4) CALL zm_ln(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 445 CALL fm_st2m('0.7654',mfm4) mfm3 = log10(mfm4) CALL fm_lg10(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 446 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = log10(mzm4) CALL zm_lg10(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 447 DO i = 1, 3 DO j = 1, 3 mfma(i,j) = 3*(j-1) + i mfmb(i,j) = 3*(i-1) + j + 10 END DO END DO 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 = 448 DO i = 1, 2 DO j = 1, 2 mima(i,j) = 2*(j-1) + i + 20 mimb(i,j) = 2*(i-1) + j + 30 END DO END DO 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 = 449 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)) END DO END DO 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)) END DO END DO 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 = 450 mfm3 = max(mfm1,mfm2) CALL fm_max(mfm1,mfm2,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 451 CALL fm_st2m('0.7654',mfm4) mfm3 = max(mfm2,mfm1,mfm4) CALL fm_max(mfm1,mfm4,mfm4) CALL fm_max(mfm2,mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 452 mim3 = max(mim1,mim2) CALL im_max(mim1,mim2,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 453 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 = 454 j = maxexponent(mfm1) IF (j/=int(mxexp)+1) CALL prterr(kw,klog,ncase,nerror) ncase = 455 mfm3 = min(mfm1,mfm2) CALL fm_min(mfm1,mfm2,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 456 CALL fm_st2m('0.7654',mfm4) mfm3 = min(mfm2,mfm1,mfm4) CALL fm_min(mfm1,mfm4,mfm4) CALL fm_min(mfm2,mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 457 mim3 = min(mim1,mim2) CALL im_min(mim1,mim2,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 458 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 test15 SUBROUTINE test16(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3, & mzm4,nerror,ncase,klog) ! Test functions MINEXPONENT, ..., RRSPACING. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm3, mfm4 TYPE (im) :: mim1, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Structures .. TYPE (fm) :: mfm5 ! .. ! .. Local Scalars .. INTEGER :: j ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 459 j = minexponent(mfm1) IF (j/=-int(mxexp)) CALL prterr(kw,klog,ncase,nerror) ncase = 460 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 = 461 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 = 462 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 = 463 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 = 464 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 = 465 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 = 466 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 = 467 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 = 468 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 = 469 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 = 470 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 = 471 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 = 472 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 = 473 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 = 474 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 = 475 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 = 476 CALL fm_st2m('0',mfm4) CALL fm_st2m('1',mfm3) CALL fm_big(mfm5) CALL fm_div(mfm3,mfm5,mfm5) mfm3 = nearest(mfm4,mfm3) IF (mfm3/=mfm5) CALL prterr(kw,klog,ncase,nerror) ncase = 477 CALL fm_st2m('0',mfm4) CALL fm_st2m('-1',mfm3) CALL fm_big(mfm5) CALL fm_div(mfm3,mfm5,mfm5) mfm3 = nearest(mfm4,mfm3) IF (mfm3/=mfm5) CALL prterr(kw,klog,ncase,nerror) ncase = 478 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,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 479 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,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 480 CALL fm_st2m('1',mfm4) CALL fm_st2m('-1',mfm3) mfm3 = nearest(mfm4,mfm3) CALL fm_st2m('0.99',mfm5) CALL fm_ulp(mfm5,mfm5) CALL fm_sub(mfm4,mfm5,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 481 CALL fm_st2m('-1',mfm4) CALL fm_st2m('12',mfm3) mfm3 = nearest(mfm4,mfm3) CALL fm_st2m('-0.99',mfm5) CALL fm_ulp(mfm5,mfm5) CALL fm_sub(mfm4,mfm5,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 482 mim3 = nint(mfm1) CALL fm_nint(mfm1,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 483 mim3 = nint(mim1) CALL im_eq(mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 484 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 = 485 j = precision(mfm1) IF (j/=int(log10(real(mbase))*(ndig-1)+1)) CALL prterr(kw,klog,ncase, & nerror) ncase = 486 j = precision(mzm1) IF (j/=int(log10(real(mbase))*(ndig-1)+1)) CALL prterr(kw,klog,ncase, & nerror) ncase = 487 j = radix(mfm1) IF (j/=int(mbase)) CALL prterr(kw,klog,ncase,nerror) ncase = 488 j = radix(mim1) IF (j/=int(mbase)) CALL prterr(kw,klog,ncase,nerror) ncase = 489 j = radix(mzm1) IF (j/=int(mbase)) CALL prterr(kw,klog,ncase,nerror) ncase = 490 j = range(mfm1) IF (j/=int(mxexp*log10(real(mbase)))) CALL prterr(kw,klog,ncase,nerror) ncase = 491 j = range(mim1) IF (j/=int(ndigmx*log10(real(mbase)))) CALL prterr(kw,klog,ncase,nerror) ncase = 492 j = range(mzm1) IF (j/=int(mxexp*log10(real(mbase)))) CALL prterr(kw,klog,ncase,nerror) ncase = 493 mfm3 = real(mfm1) CALL fm_eq(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 494 mfm3 = real(mim1) CALL im_i2fm(mim1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 495 mfm3 = real(mzm1) CALL zm_real(mzm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 496 mfm3 = rrspacing(mfm1) CALL fm_abs(mfm1,mfm4) mfm4%mfm(1) = ndig IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test16 SUBROUTINE test17(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4, & mzm1,mzm3,mzm4,nerror,ncase,klog) ! Test functions SCALE, ..., TINY. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 497 CALL fm_st2m('0.7654',mfm4) mfm3 = scale(mfm4,1) CALL fm_mpyi(mfm4,int(mbase),mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 498 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = scale(mzm4,-2) CALL zm_divi(mzm4,int(mbase),mzm4) CALL zm_divi(mzm4,int(mbase),mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 499 CALL fm_st2m('0.7654',mfm4) mfm3 = setexponent(mfm4,1) CALL fm_mpyi(mfm4,int(mbase),mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 500 CALL fm_st2m('0.7654',mfm4) mfm3 = sign(mfm4,mfm2) CALL fm_sign(mfm4,mfm2,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 501 CALL im_st2m('231',mim4) mim3 = sign(mim4,mim2) CALL im_sign(mim4,mim2,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 502 CALL fm_st2m('0.7654',mfm4) mfm3 = sin(mfm4) CALL fm_sin(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 503 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = sin(mzm4) CALL zm_sin(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 504 CALL fm_st2m('0.7654',mfm4) mfm3 = sinh(mfm4) CALL fm_sinh(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 505 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = sinh(mzm4) CALL zm_sinh(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 506 CALL fm_st2m('-0.7654',mfm4) mfm3 = spacing(mfm4) CALL fm_ulp(mfm4,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 507 CALL fm_st2m('0.7654',mfm4) mfm3 = sqrt(mfm4) CALL fm_sqrt(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 508 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = sqrt(mzm4) CALL zm_sqrt(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 509 CALL fm_st2m('0.7654',mfm4) mfm3 = tan(mfm4) CALL fm_tan(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 510 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = tan(mzm4) CALL zm_tan(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 511 CALL fm_st2m('0.7654',mfm4) mfm3 = tanh(mfm4) CALL fm_tanh(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 512 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = tanh(mzm4) CALL zm_tanh(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 513 CALL fm_big(mfm4) CALL fm_i2m(1,mfm3) CALL fm_div(mfm3,mfm4,mfm4) mfm3 = tiny(mfm1) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 514 mim3 = tiny(mim1) CALL im_i2m(1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 515 CALL fm_big(mfm4) CALL fm_i2m(1,mfm3) CALL fm_div(mfm3,mfm4,mfm4) CALL zm_cmpx(mfm4,mfm4,mzm4) mzm3 = tiny(mzm1) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test17 SUBROUTINE test18(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3, & mzm4,nerror,ncase,klog) ! Test functions TO_FM, TO_IM, TO_ZM, ..., TO_DPZ. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm3, mfm4 TYPE (im) :: mim1, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Structures .. TYPE (fm) :: mfm5 ! .. ! .. Local Scalars .. COMPLEX (kind(0.0D0)) :: c2 COMPLEX :: z2 REAL (KIND(0.0D0)) :: d2, d3, dsmall REAL :: r2, rsmall INTEGER :: i2 ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. rsmall = epsilon(1.0)*100.0 dsmall = epsilon(1.0D0)*100.0 ncase = 516 mfm3 = to_fm(123) CALL fm_i2m(123,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 517 mfm3 = to_fm(123.4) CALL fm_sp2m(123.4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 518 mfm3 = to_fm(123.45D0) CALL fm_dp2m(123.45D0,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = dsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 519 mfm3 = to_fm(cmplx(123.4,567.8)) CALL fm_sp2m(123.4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 520 mfm3 = to_fm(cmplx(123.4D0,567.8D0,kind(1.0D0))) CALL fm_dp2m(123.4D0,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 521 mfm3 = to_fm(mfm1) CALL fm_eq(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 522 mfm3 = to_fm(mim1) CALL im_i2fm(mim1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 523 mfm3 = to_fm(mzm1) CALL zm_real(mzm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 524 mfm3 = to_fm('-123.654') CALL fm_st2m('-123.654',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 525 mim3 = to_im(123) CALL im_i2m(123,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 526 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 = 527 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 = 528 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 = 529 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 = 530 mim3 = to_im(mfm1) CALL fm_eq(mfm1,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 531 mim3 = to_im(mim1) CALL im_i2fm(mim1,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 532 mim3 = to_im(mzm1) CALL zm_real(mzm1,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 533 mim3 = to_im('-123654') CALL im_st2m('-123654',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 534 mzm3 = to_zm(123) CALL zm_i2m(123,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 535 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,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 536 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,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = dsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 537 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,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 538 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,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = dsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 539 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 = 540 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 = 541 mzm3 = to_zm(mzm1) CALL zm_eq(mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 542 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 = 543 CALL fm_m2i(mfm1,i2) IF (to_int(mfm1)/=i2) CALL prterr(kw,klog,ncase,nerror) ncase = 544 CALL im_m2i(mim1,i2) IF (to_int(mim1)/=i2) CALL prterr(kw,klog,ncase,nerror) ncase = 545 CALL zm_m2i(mzm1,i2) IF (to_int(mzm1)/=i2) CALL prterr(kw,klog,ncase,nerror) ncase = 546 CALL fm_m2sp(mfm1,r2) IF (abs((to_sp(mfm1)-r2)/r2)>rsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 547 CALL im_m2dp(mim1,d2) r2 = d2 IF (abs((to_sp(mim1)-r2)/r2)>rsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 548 CALL zm_real(mzm1,mfm4) CALL fm_m2sp(mfm4,r2) IF (abs((to_sp(mzm1)-r2)/r2)>rsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 549 CALL fm_m2dp(mfm1,d2) IF (abs((to_dp(mfm1)-d2)/d2)>dsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 550 CALL im_m2dp(mim1,d2) IF (abs((to_dp(mim1)-d2)/d2)>dsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 551 CALL zm_real(mzm1,mfm4) CALL fm_m2dp(mfm4,d2) IF (abs((to_dp(mzm1)-d2)/d2)>dsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 552 CALL fm_m2sp(mfm1,r2) z2 = r2 IF (abs((to_spz(mfm1)-z2)/z2)>rsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 553 CALL im_m2dp(mim1,d2) z2 = d2 IF (abs((to_spz(mim1)-z2)/z2)>rsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 554 CALL zm_m2z(mzm1,z2) IF (abs((to_spz(mzm1)-z2)/z2)>rsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 555 CALL fm_m2dp(mfm1,d2) c2 = d2 IF (abs((to_dpz(mfm1)-c2)/c2)>dsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 556 CALL im_m2dp(mim1,d2) c2 = d2 IF (abs((to_dpz(mim1)-c2)/c2)>dsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 557 CALL zm_real(mzm1,mfm4) CALL fm_m2dp(mfm4,d2) CALL zm_imag(mzm1,mfm4) CALL fm_m2dp(mfm4,d3) c2 = cmplx(d2,d3,kind(0.0D0)) IF (abs((to_dpz(mzm1)-c2)/c2)>dsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF END SUBROUTINE test18 SUBROUTINE test19(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3, & mzm4,nerror,ncase,klog) ! Test the derived-type interface routines that are not ! used elsewhere in this program. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm3, mfm4 TYPE (im) :: mim1, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Structures .. TYPE (im) :: mim2 TYPE (fm) :: msmall ! .. ! .. Local Scalars .. COMPLEX :: z3, z4 REAL (KIND(0.0D0)) :: d3, d4, dsmall REAL :: r3, r4, rsmall INTEGER :: i3, i4 CHARACTER (80) :: string ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. rsmall = epsilon(1.0)*100.0 dsmall = epsilon(1.0D0)*100.0 msmall = epsilon(to_fm(1))*10000.0 ncase = 558 mfm3 = mfm1 + 123 mfm4 = mfm1 CALL fm_addi(mfm4,123) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 559 CALL fm_chsh(mfm1,mfm4,mfm3) mfm3 = cosh(mfm1) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 560 CALL fm_chsh(mfm1,mfm3,mfm4) mfm3 = sinh(mfm1) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 561 CALL fm_cssn(mfm1,mfm4,mfm3) mfm3 = cos(mfm1) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 562 CALL fm_cssn(mfm1,mfm3,mfm4) mfm3 = sin(mfm1) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 563 mfm3 = mfm1/123 CALL fm_divi(mfm1,123,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 564 mfm3 = 123.45D0 CALL fm_dpm(123.45D0,mfm4) IF (abs((mfm3-mfm4)/mfm4)>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 565 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 = 566 mfm3 = mfm1**123 CALL fm_ipwr(mfm1,123,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 567 mfm3 = log(to_fm(123)) CALL fm_lni(123,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 568 d3 = mfm1 CALL fm_m2dp(mfm1,d4) IF (abs((d3-d4)/d3)>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 569 i3 = mfm1 CALL fm_m2i(mfm1,i4) IF (i3/=i4) CALL prterr(kw,klog,ncase,nerror) ncase = 570 r3 = mfm1 CALL fm_m2sp(mfm1,r4) IF (abs((r3-r4)/r3)>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 571 mfm3 = 2.67 CALL fm_mod(mfm1,mfm3,mfm4) mfm3 = mod(mfm1,mfm3) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 572 CALL fm_pi(mfm4) mfm3 = 4*atan(to_fm(1)) IF (abs((mfm3-mfm4)/mfm4)>msmall) CALL prterr(kw,klog,ncase,nerror) ncase = 573 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 = 574 CALL fm_sqr(mfm1,mfm4) mfm3 = mfm1*mfm1 IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 575 mim3 = mim1/13 CALL im_divi(mim1,13,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 576 mim3 = 13 CALL im_divr(mim1,mim3,mim3,mim4) mim3 = mod(mim1,mim3) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 577 mim3 = 13 CALL im_divr(mim1,mim3,mim3,mim4) mim4 = mim1/13 IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 578 mim3 = mim1/13 CALL im_dvir(mim1,13,mim4,i4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 579 i3 = mod(mim1,to_im(13)) CALL im_dvir(mim1,13,mim4,i4) IF (i3/=i4) CALL prterr(kw,klog,ncase,nerror) ncase = 580 CALL im_form('I70',mim1,string) CALL im_st2m(string(1:70),mim4) IF (mim1/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 581 mim3 = 40833 mim4 = 16042 CALL im_gcd(mim3,mim4,mim4) IF (mim4/=13) CALL prterr(kw,klog,ncase,nerror) ncase = 582 d3 = mim1 CALL im_m2dp(mim1,d4) IF (abs((d3-d4)/d3)>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 583 i3 = mim1 CALL im_m2i(mim1,i4) IF (i3/=i4) CALL prterr(kw,klog,ncase,nerror) ncase = 584 mim3 = 6 CALL im_mod(mim1,mim3,mim4) mim3 = mod(mim1,mim3) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 585 mim3 = mim1*123 CALL im_mpyi(mim1,123,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 586 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 = 587 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 = 588 CALL im_sqr(mim1,mim4) mim3 = mim1*mim1 IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 589 mzm3 = mzm1 + 123 mzm4 = mzm1 CALL zm_addi(mzm4,123) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 590 mfm3 = atan2(aimag(mzm1),real(mzm1)) CALL zm_arg(mzm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 591 CALL zm_chsh(mzm1,mzm4,mzm3) mzm3 = cosh(mzm1) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 592 CALL zm_chsh(mzm1,mzm3,mzm4) mzm3 = sinh(mzm1) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 593 CALL zm_cssn(mzm1,mzm4,mzm3) mzm3 = cos(mzm1) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 594 CALL zm_cssn(mzm1,mzm3,mzm4) mzm3 = sin(mzm1) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 595 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 = 596 mzm3 = to_zm('123-456i') CALL zm_2i2m(123,-456,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 597 mzm3 = mzm1**123 CALL zm_ipwr(mzm1,123,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 598 i3 = mzm1 CALL zm_m2i(mzm1,i4) IF (i3/=i4) CALL prterr(kw,klog,ncase,nerror) ncase = 599 z3 = mzm1 CALL zm_m2z(mzm1,z4) IF (abs((z3-z4)/z3)>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 600 mzm3 = mzm1*123 CALL zm_mpyi(mzm1,123,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 601 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 = 602 CALL zm_sqr(mzm1,mzm4) mzm3 = mzm1*mzm1 IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 603 mzm3 = z1 CALL zm_z2m(z1,mzm4) IF (abs((mzm3-mzm4)/mzm3)>rsmall) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test19 SUBROUTINE prterr(kw,klog,ncase,nerror) ! .. Scalar Arguments .. INTEGER :: klog, kw, ncase, nerror ! .. WRITE (kw,*) ' Error in case ', ncase WRITE (klog,*) ' Error in case ', ncase nerror = nerror + 1 END SUBROUTINE prterr SHAR_EOF fi # end of overwriting check if test -f 'driver6.f90' then echo shar: will not over-write existing file "'driver6.f90'" else cat << SHAR_EOF > 'driver6.f90' PROGRAM test90 ! David M. Smith 9-17-96 ! Program using the FM Fortran-90 modules for doing ! arithmetic using the FM, IM, and ZM derived types. ! This program does the same calculations as FMSAMPLE and ZMSAMPLE. ! The output is saved in file SAMPLE90.LOG. A comparison file, ! SAMPLE90.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.f90. ! .. Use Statements .. USE fmzm ! .. ! .. Local Structures .. TYPE (fm) :: mafm, mbfm, mcfm, mdfm TYPE (im) :: maim, mbim, mcim TYPE (zm) :: mazm, mbzm, mczm, mdzm ! .. ! .. Local Scalars .. INTEGER :: iter, j, k, klog, nerror ! Character string used to format multiple-precision output. CHARACTER (80) :: st1 ! .. ! Note that any program using the FM package MUST call ! FM_SET before using the package. ! Since the argument to FM_SET is not an FM number, ! calling FMSET would have the same effect. The "FM_" ! version is available so that all calls in a program ! using the derived types can have the "FM_" form. ! Later in this program complex arithmetic is be used, ! and ZM_SET is called there to initialize the ZM package. ! Set precision to give at least 60 significant digits ! and initialize the FMLIB package. CALL fm_set(60) nerror = 0 ! Write output to the standard FM output (unit KW, defined ! in subroutine FMSET), and also to the file SAMPLE90.LOG. klog = 18 OPEN (klog,file='SAMPLE90.LOG') ! 1. Find a root of the equation ! f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0. ! 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. mafm = to_fm('3.12') ! Print the first iteration. WRITE (kw,90000) WRITE (klog,90000) CALL fm_form('F65.60',mafm,st1) WRITE (kw,90010) 0, st1(1:65) WRITE (klog,90010) 0, st1(1:65) 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. CALL fm_form('F65.60',mbfm,st1) WRITE (kw,90010) iter, st1(1:65) WRITE (klog,90010) iter, st1(1:65) ! 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 END DO ! Check the answer. mcfm = to_fm('3.120656215326726500470956013523797484654623'// & '9355990660149888284358') IF (abs(mcfm-mbfm)>1.0D-61) THEN nerror = nerror + 1 WRITE (kw,90020) WRITE (klog,90020) END IF ! 2. 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)! 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 END IF ! Test for convergence. IF (mafm-mbfm==mafm) THEN WRITE (kw,90030) k WRITE (klog,90030) k EXIT END IF END DO ! Print the result. mafm = (5*mafm)/4 CALL fm_form('F65.60',mafm,st1) WRITE (kw,90040) st1(1:65) WRITE (klog,90040) st1(1:65) ! Check the answer. mcfm = to_fm('1.20205690315959428539973816151144999076498'// & '6292340498881792271555') IF (abs(mafm-mcfm)>1.0D-61) THEN nerror = nerror + 1 WRITE (kw,90050) WRITE (klog,90050) END IF ! 3. 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. ! MAIM is the value p being tested. maim = to_im(10)**69 ! 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 ! Compute 3**(p-1) mod p mbim = maim - 1 CALL im_pmod(mcim,mbim,maim,mcim) IF (mcim==1) THEN ! Check that 7**(p-1) mod p is also 1. mcim = 7 CALL im_pmod(mcim,mbim,maim,mcim) IF (mcim==1) THEN WRITE (kw,90060) j WRITE (klog,90060) j EXIT END IF END IF mcim = 3 maim = maim + k END DO ! Print the result. CALL im_form('I72',maim,st1) WRITE (kw,90070) st1(1:72) WRITE (klog,90070) st1(1:72) ! Check the answer. mcim = to_im('1000000000000000000000000000000000000000000'// & '000000000000000000000659661') IF (maim/=mcim) THEN nerror = nerror + 1 WRITE (kw,90080) WRITE (klog,90080) END IF ! Complex arithmetic. ! Set precision to give at least 30 significant digits ! and initialize the ZMLIB package. Both FM and ZM ! operations will now have this precision. ! Note that any program using the ZM package MUST call ! ZM_SET before using the package. CALL zm_set(30) ! 4. 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. WRITE (kw,90090) WRITE (klog,90090) CALL zm_form('F32.30','F32.30',mazm,st1) WRITE (kw,90100) 0, st1(1:69) WRITE (klog,90100) 0, st1(1:69) 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 (kw,90100) iter, st1(1:69) WRITE (klog,90100) iter, st1(1:69) ! 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 END DO ! Check the answer. mczm = to_zm('0.561958308335403235498111195347453 +'// & '1.061134679604332556983391239058885 i') IF (abs(mczm-mbzm)>1.0D-31) THEN nerror = nerror + 1 WRITE (kw,90110) WRITE (klog,90110) END IF ! 5. 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 WRITE (kw,90120) k WRITE (klog,90120) k EXIT END IF mczm = mdzm END DO ! Print the result. CALL zm_form('F33.30','F32.30',mczm,st1) WRITE (kw,90130) st1(1:70) WRITE (klog,90130) st1(1:70) ! Check the answer. mdzm = to_zm('-2.379681796854777515745457977696745 -'// & ' 2.458032970832342652397461908326042 i') IF (abs(mdzm-mczm)>1.0D-31) THEN nerror = nerror + 1 WRITE (kw,90140) WRITE (klog,90140) END IF IF (nerror==0) THEN WRITE (kw,90150) ' All results were ok.' WRITE (klog,90150) ' All results were ok.' END IF 90000 FORMAT (//' Sample 1. Real root of f(x) = x**5 - 3x**4 + ', & 'x**3 - 4x**2 + x - 6 = 0.'///' Iteration Newton Approximation') 90010 FORMAT (/I10,4X,A) 90020 FORMAT (/' Error in sample case number 1.'/) 90030 FORMAT (///' Sample 2.',8X,I5,' terms were added'/) 90040 FORMAT (' Zeta(3) = ',A) 90050 FORMAT (/' Error in sample case number 2.'/) 90060 FORMAT (///' Sample 3.',8X,I5,' values were tested'/) 90070 FORMAT (' p = ',A) 90080 FORMAT (/' Error in sample case number 3.'/) 90090 FORMAT (//' Sample 4. Complex root of f(x) = x**5 - 3x**4 + ', & 'x**3 - 4x**2 + x - 6 = 0.'///' Iteration Newton Approximation') 90100 FORMAT (/I6,4X,A) 90110 FORMAT (/' Error in sample case number 4.'/) 90120 FORMAT (///' Sample 5.',8X,I5,' terms were added ', & 'to get Exp(1.23-2.34i)'/) 90130 FORMAT (' Result= ',A) 90140 FORMAT (/' Error in sample case number 5.'/) 90150 FORMAT (//A/) END PROGRAM test90 SHAR_EOF fi # end of overwriting check cd .. cd .. if test ! -d 'Src' then mkdir 'Src' fi cd 'Src' if test ! -d 'Dp' then mkdir 'Dp' fi cd 'Dp' if test -f 'fmlib.f90' then echo shar: will not over-write existing file "'fmlib.f90'" else cat << SHAR_EOF > 'fmlib.f90' ! FM 1.1 David M. Smith 5-19-97 ! The FM routines in this package perform floating-point ! multiple-precision arithmetic, and the IM routines perform ! integer multiple-precision arithmetic. ! 1. INITIALIZING THE PACKAGE ! Before calling any routine in the package, several variables in ! the common blocks /FMUSER/, /FM/, /FMBUFF/, and /FMSAVE/ must be ! initialized. These four common blocks contain information that ! is saved between calls, so they should be declared in the main ! program. ! Subroutine FMSET initializes these variables to default values and ! defines all machine-dependent values in the package. After calling ! FMSET once at the start of a program, the user may sometimes want ! to reset some of the variables in these common blocks. These ! variables are described below. ! 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 the PARAMETER statement at ! the top of each routine and is restricted only by the amount ! of memory available. ! Sometimes it is useful to dynamically vary NDIG during the program. ! Use FMEQU to round numbers to lower precision or zero-pad them to ! higher precision when changing NDIG. ! It is rare to need to change MBASE during a program. Use FMCONS to ! reset some saved constants that depend on MBASE. FMCONS should be ! called immediately after changing MBASE. ! There are two representations for a floating 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 easily 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) containing one digit of ! the mantissa, expressed in base MBASE. The array is dimensioned ! to start at MA(0), with the approximate number of bits of precision ! stored in MA(0). This precision value is intended to be used by FM ! functions that need to monitor cancellation error in addition and ! subtraction. The cancellation monitor code is usually disabled for ! user calls, and FM functions only check for cancellation when they ! must. Tracking cancellation causes most routines to run slower, ! with addition and subtraction being affected the most. ! The exponent is a power of MBASE and the implied radix point is ! immediately before the first digit of the mantissa. Every nonzero ! number is normalized so that the second array element (the first ! digit of the mantissa) is nonzero. ! In both representations the sign of the number is carried on the ! second array element only. Elements 3,4,... are always nonnegative. ! The exponent is a signed integer and may be as large in magnitude as ! MXEXP (defined in FMSET). ! For MBASE = 10,000 and NDIG = 4, the number -pi would have these ! representations: ! Word 1 2 3 4 5 ! Unpacked: 1 -3 1415 9265 3590 ! Packed: 1 -31415 92653590 ! Word 0 would be 42 in both formats, indicating that the mantissa ! has about 42 bits of precision. ! Because of normalization in a large base, the equivalent number ! of base 10 significant digits for an FM number may be as small as ! LOG10(MBASE)*(NDIG-1) + 1. ! The integer routines use the FMLIB 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. ! 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 common, so that a separate format definition ! does not have to be provided for each output call. ! The user sets JFORM1 and JFORM2 to determine the 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.EQ.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 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 printout except warnings and errors. ! = 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. ! 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 parameter 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. ! 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 NDIGMX in ! all the PARAMETER statements 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 FMSET are ! correct for the current machine. ! Zero was returned. ! 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 routine IMMPYM 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 PARAMETERS ! KRAD = 0 All angles in the trigonometric functions and ! inverse functions are measured in degrees. ! = 1 All angles are measured in radians. (Default) ! KROUND = 0 All final results are chopped (rounded toward ! zero). Intermediate results are rounded. ! = 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) ! 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. Default is for 'E7' to translate like '1.0E+7'. ! CMCHAR defines the exponent letter to be used for FM variable ! output. Default is 'M', as in 1.2345M+678. ! KDEBUG = 0 Error checking is not done for valid input arguments ! and parameters like NDIG and MBASE upon entry to ! each routine. (Default) ! = 1 Some error checking is done. (Slower speed) ! See FMSET 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 ! a PARAMETER statement at the top of each routine. The size of ! these arrays depends on the values of 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 FMLIB sets NDIGMX = 256, so on a 32-bit ! machine using MBASE = 10**7 the maximum precision is about ! 7*255+1 = 1786 significant digits. To change dimensions so that ! 10,000 significant digit calculation can be done, NDIGMX needs to ! be at least 10**4/7 + 5 = 1434. This allows for a few user guard ! digits to be defined when the package is initialized using ! CALL FMSET(10000). Changing 'NDIGMX = 256' to 'NDIGMX = 1434' ! everywhere in the package and the user's calling program 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 the formula ! 0.051*Log(MBASE)*NDIG**(1/3) + 1.85 ! For example, with MBASE=10**7 and NDIG=1434 this gives 11. Changing ! 'LJSUMS = 8*(LUNPCK+2)' to 'LJSUMS =11*(LUNPCK+2)' everywhere in the ! package and the user's calling program will give slightly better ! speed. ! FM numbers in packed format have dimension 0:LPACK, and those ! in unpacked format have dimension 0:LUNPCK. ! 8. PORTABILITY ! In FMSET there is some machine-dependent code that attempts to ! approximate the largest representable integer value. The current ! code works on all machines tested, but if an FM run fails, check ! the MAXINT and INTMAX loops in FMSET. Values for SPMAX and DPMAX ! are also defined in FMSET that should be set to values near overflow ! for single precision and double precision. Setting KDEBUG = 1 may ! also identify some errors if a run fails. ! Some compilers object to a function like FMCOMP with side effects ! such as changing KFLAG or other common variables. Blocks of code ! in FMCOMP and IMCOMP that modify common 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. ! 9. LIST OF ROUTINES ! These are the FM routines that are designed to be called by ! the user. All are subroutines except logical function FMCOMP. ! MA, MB, MC refer to FM format numbers. ! In each case it is permissible to use the same array more than ! once in the calling sequence. The statement MA = MA*MA can ! be written CALL FMMPY(MA,MA,MA). ! For each of these routines there is also a version available for ! which the argument list is the same but all FM numbers are in packed ! format. The routines using packed numbers have the same names except ! 'FM' is replaced by 'FP' at the start of each name. ! FMABS(MA,MB) MB = ABS(MA) ! FMACOS(MA,MB) MB = ACOS(MA) ! FMADD(MA,MB,MC) MC = MA + MB ! FMADDI(MA,IVAL) MA = MA + IVAL Increment an FM number by a one ! word integer. Note this call ! does not have an "MB" result ! like FMDIVI and FMMPYI. ! FMASIN(MA,MB) MB = ASIN(MA) ! FMATAN(MA,MB) MB = ATAN(MA) ! FMATN2(MA,MB,MC) MC = ATAN2(MA,MB) ! FMBIG(MA) MA = Biggest FM number less than overflow. ! FMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA). Faster than ! making two separate calls. ! FMCOMP(MA,LREL,MB) Logical comparison of MA and MB. ! LREL is a CHARACTER*2 value identifying ! which comparison is made. ! Example: IF (FMCOMP(MA,'GE',MB)) ... ! FMCONS Set several saved constants that depend ! on MBASE, the base being used. FMCONS ! should be called immediately after ! changing MBASE. ! FMCOS(MA,MB) MB = COS(MA) ! FMCOSH(MA,MB) MB = COSH(MA) ! FMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA). Faster than ! making two separate calls. ! FMDIG(NSTACK,KST) Find a set of precisions to use during ! Newton iteration for finding a simple ! root starting with about double ! precision accuracy. ! FMDIM(MA,MB,MC) MC = DIM(MA,MB) ! FMDIV(MA,MB,MC) MC = MA/MB ! FMDIVI(MA,IVAL,MB) MB = MA/IVAL IVAL is a one word integer. ! FMDP2M(X,MA) MA = X Convert from double precision to FM. ! FMDPM(X,MA) MA = X Convert from double precision to FM. ! Much 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 zero-padded if NB.GT.NA ! MB is rounded if NB.LT.NA ! FMEXP(MA,MB) MB = EXP(MA) ! FMFORM(FORM,MA,STRING) MA is converted to a character string ! using format FORM and returned in ! STRING. FORM can represent I, F, ! E, or 1PE formats. Example: ! CALL FMFORM('F60.40',MA,STRING) ! FMFPRT(FORM,MA) Print MA on unit KW using FORM format. ! FMI2M(IVAL,MA) MA = IVAL Convert from one word integer ! to FM. ! FMINP(LINE,MA,LA,LB) MA = LINE Input conversion. ! Convert LINE(LA) through LINE(LB) ! from characters to FM. ! FMINT(MA,MB) MB = INT(MA) Integer part of MA. ! FMIPWR(MA,IVAL,MB) MB = MA**IVAL Raise an FM number to a one ! word integer power. ! FMLG10(MA,MB) MB = LOG10(MA) ! FMLN(MA,MB) MB = LOG(MA) ! FMLNI(IVAL,MA) MA = LOG(IVAL) Natural log of a one word ! integer. ! FMM2DP(MA,X) X = MA Convert from FM to double precision. ! FMM2I(MA,IVAL) IVAL = MA Convert from FM to integer. ! FMM2SP(MA,X) X = MA Convert from FM to single precision. ! FMMAX(MA,MB,MC) MC = MAX(MA,MB) ! FMMIN(MA,MB,MC) MC = MIN(MA,MB) ! FMMOD(MA,MB,MC) MC = MA mod MB ! FMMPY(MA,MB,MC) MC = MA*MB ! FMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer. ! FMNINT(MA,MB) MB = NINT(MA) Nearest FM integer. ! FMOUT(MA,LINE,LB) LINE = MA Convert from FM to character. ! LINE is a character array of ! length LB. ! FMPI(MA) MA = pi ! FMPRNT(MA) Print MA on unit KW using current format. ! FMPWR(MA,MB,MC) MC = MA**MB ! 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 default values and machine-dependent ! variables to give at least NPREC base 10 ! digits plus three base 10 guard digits. ! Must be called to initialize FM package. ! FMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer. ! FMSIN(MA,MB) MB = SIN(MA) ! FMSINH(MA,MB) MB = SINH(MA) ! FMSP2M(X,MA) MA = X Convert from single precision to FM. ! FMSQR(MA,MB) MB = MA*MA Faster than FMMPY. ! FMSQRT(MA,MB) MB = SQRT(MA) ! FMST2M(STRING,MA) MA = STRING ! Convert from character string to FM. ! Often more convenient than FMINP, which ! converts an array of CHARACTER*1 values. ! Example: CALL FMST2M('123.4',MA). ! FMSUB(MA,MB,MC) MC = MA - MB ! FMTAN(MA,MB) MB = TAN(MA) ! FMTANH(MA,MB) MB = TANH(MA) ! FMULP(MA,MB) MB = One Unit in the Last Place of MA. ! 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 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 comparison is made. ! Example: IF (IMCOMP(MA,'GE',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. ! Many of the IM routines call FM routines, but none of the FM ! routines call IM routines, so the IM routines can be omitted ! if none are called explicitly from a program. ! 10. NEW FOR VERSION 1.1 ! Version 1.0 used integer arrays and integer arithmetic internally ! to perform the multiple precision operations. Version 1.1 uses ! 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.1 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. ! Several routines have undergone minor modification, but only a few ! changes should affect programs that used FM 1.0. Many of the ! routines are faster in version 1.1, because code has been added to ! take advantage of special cases for individual functions instead of ! using general formulas that are more compact. For example, there ! are separate routines using series for SINH and COSH instead of ! just calling EXP. ! FMEQU was the only routine that required the user to give the value ! of the current precision. This was to allow automatic ! rounding or zero-padding when changing precision. Since few ! user calls change precision, a new routine has been added for ! this case. ! FMEQ now handles this case and has a simple argument list that ! does not include the value of NDIG. ! FMEQU is used for changing precision. ! See the list of FM routines above for details. ! All variable names beginning with M in the package are now declared ! as double precision, so FM common blocks in the user's program need ! D.P. declarations, and FM variables (arrays) used in the calling ! program need to be D.P. ! /FMUSER/ is a common block holding parameters that define the ! arithmetic to be used and other user options. Several ! new variables have been added, including screen width to ! be used for output. See above for further description. ! /FMSAVE/ is a common block for saving constants to avoid ! re-computing them. Several new variables have been added. ! /FMBUFF/ is a common block containing a character array used to ! format FM numbers for output. Two new items have been ! added. ! New routines: ! All the IM routines are new for version 1.1. ! FMADDI increments an FM number by a small integer. ! It runs in O(1) time, on the average. ! FMCHSH returns both SINH(MA) and COSH(MA). ! When both are needed, this is almost twice as fast ! as making separate calls to FMCOSH and FMSINH. ! FMCSSN returns both SIN(MA) and COS(MA). ! When both are needed, this is almost twice as fast ! as making separate calls to FMCOS and FMSIN. ! FMFORM uses a format string to convert an FM number to a ! character string. ! FMFPRT prints an FM number using a format string. ! FMREAD reads an FM number written using FMWRIT. ! FMRPWR computes an FM number raised to a rational power. For cube ! roots and similar rational powers it is usually much faster ! than FMPWR. ! FMSQR squares an FM number. It is faster than using FMMPY. ! FMST2M converts character strings to FM format. Since FMINP converts ! character arrays, this routine can be more convenient for ! easily defining an FM number. ! For example, CALL FMST2M('123.4',MA). ! FMWRIT writes an FM number using a format for multi-line numbers ! with '&' at the end of all but the last line of a multi-line ! number. This allows automatic reading of FM numbers without ! needing to know the base, precision or format under which they ! were written. ! One extra word has been added to the dimensions of all FM numbers. ! Word zero in each array contains a value used to monitor cancellation ! error arising from addition or subtraction. This value approximates ! the number of bits of precision for an FM value. It allows higher ! level FM functions to detect cases where too much cancellation has ! occurred. KACCSW is a switch variable in COMMON /FM/ used internally ! to enable cancellation error monitoring. ! 11. EFFICIENCY ! To take advantage of hardware architecture on different machines, the ! package has been designed so that the arithmetic used to perform the ! multiple precision operations can easily be changed. All variables ! that must be changed to get a different arithmetic have names ! beginning with 'M' and are declared using REAL (KIND(0.0D0)) :: m.... ! For example, to change the package to use integer arithmetic ! internally, make these two changes everywhere in the package: ! change 'REAL (KIND(0.0D0)) :: m' to 'INTEGER m', ! change 'DINT(' to 'INT('. ! On some systems, changing 'DINT(' to '(' may give better speed. ! When changing to a different type of arithmetic, all FM common blocks ! and arrays in the user's program must be changed to agree. In a few ! places in FM, where a DINT function is not supposed to be changed, it ! is spelled 'DINT (' so the global change will not find it. ! This version 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 usually run faster. This would usually not be much ! faster than using 10**7 with double precision. ! The value of NBITS defined as a parameter in most FM routines ! 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 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 values in common that must be set before calling ! other FM routines. ! 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 is set to a large power of ten. ! JFORM1 and JFORM2 are set to 1PE format displaying NPREC ! significant digits. ! The trace option is set off. ! The mode for angles in trig functions is set to radians. ! The rounding mode is set to symmetric rounding. ! Warning error message level is set to 1. ! Cancellation error monitor is set off. ! Screen width for output is set to 80 columns. ! The exponent character for FM output is set to 'M'. ! Debug error checking is set off. ! KW, the unit number for all FM output, is set to 6. ! The size of all arrays is controlled by defining two parameters: ! NDIGMX is the maximum value the user can set NDIG, ! NBITS is the number of bits used to represent integers in an ! M-variable word. IMPLICIT NONE ! Define the array sizes: ! Here are all the common blocks used in FM. ! /FMUSER/, /FM/, /FMBUFF/, and /FMSAVE/ should also be declared in the ! main program, because some compilers allocate and free space used for ! labelled common that is declared only in subprograms. This causes ! the saved information to be lost. ! FMUSER contains values that may need to be ! changed by the calling program. ! FM contains the work array used by the low-level ! arithmetic routines, definitions for overflow ! and underflow thresholds, and other ! machine-dependent values. ! FMSAVE contains information about saved constants. ! MJSUMS is an array that can contain several FM numbers ! being used to accumulate concurrent sums in exponential ! and trigonometric functions. When NDIGMX = 256, eight is ! about the maximum number of sums needed (but this depends ! on MBASE). For larger NDIGMX, dimensioning MJSUMS to hold ! more than eight FM numbers could increase the speed of the ! functions. ! FMWA contains two work arrays similar to MWA. They are ! used in routines FMDIVD, FMMPYD, and FMMPYE. ! CMBUFF is a character array used by FMPRNT for printing ! output from FMOUT. This array may also be used ! for calls to FMOUT from outside the FM package. ! CMCHAR is the letter used before the exponent field ! in FMOUT. It is defined in FMSET. ! NAMEST is a stack for names of the routines. It is ! used for trace printing and error messages. ! FM1 contains scratch arrays for temporary storage of FM ! numbers while computing various functions. ! FMPCK contains scratch arrays used to hold input arguments ! in unpacked format when the packed versions of functions ! are used. ! .. Intrinsic Functions .. INTRINSIC dble, ichar, int, log, log10, max, min, sqrt ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: nprec ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ml, mld2, mlm1 REAL (KIND(0.0D0)) :: one, temp, two, yt INTEGER :: j, k, kpt, l, npsave ! .. ! .. Local Arrays .. INTEGER :: ltypes(21), lvals(21) CHARACTER (1) :: lchars(21) ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmdbl, fmmset ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mjsums(0:ljsums), & mlbsav(0:lunpck), mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), & mln4(0:lunpck), mpa(0:lunpck), mpb(0:lunpck), mpc(0:lunpck), & mpisav(0:lunpck), mwa(lmwa), mwd(lmwa), mwe(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmpck/mpa, mpb, mpc COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmsums/mjsums COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /fmwa/mwd, mwe ! .. ! .. Data Statements .. DATA lchars/'+', '-', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', & '.', 'E', 'D', 'Q', 'M', 'e', 'd', 'q', 'm'/ DATA ltypes/1, 1, 10*2, 3, 8*4/ DATA lvals/1, -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 9*0/ ! .. ! KW is the unit number for standard output from the ! FM package. This includes trace output and error ! messages. kw = 6 ! MAXINT should be set to a very large integer, possibly ! the largest representable integer for the current ! machine. For most 32-bit machines, MAXINT is set ! to 2**53 - 1 = 9.007D+15 when double precision ! arithmetic is used for M-variables. Using integer ! M-variables usually gives MAXINT = 2**31 - 1 = ! 2 147 483 647. ! Setting MAXINT to a smaller number is ok, but this ! unnecessarily restricts the permissible range of ! MBASE and MXEXP. ! The following code should set MAXINT to the largest ! representable number of the form 2**J - 1. ! The FMMSET call keeps some compilers from doing the 110 ! loop at the highest precision available and then rounding ! to the declared precision. maxint = 3 10 CALL fmmset(maxint,ml,mld2,mlm1) IF (mld2==maxint .AND. mlm1/=ml) THEN maxint = ml GO TO 10 END IF ! 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. ! WARNING: This loop causes integer overflow to occur, so it ! is a likely place for the program to fail when ! run on a different machine. The loop below has ! been used successfully with Fortran compilers ! for many different machines, but even different ! versions of the same compiler may give different ! results. Check the values of MAXINT and INTMAX ! if there are problems installing FM. intmax = 3 20 l = 2*intmax + 1 IF (int(l/2)==intmax) THEN intmax = l GO TO 20 END IF ! 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 = 1.0D+74 ! 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 = 1.0E+37 ! NDG2MX is the maximum value for NDIG that can be used ! internally. FM routines may raise NDIG above ! NDIGMX temporarily, to compute correctly ! rounded results. ! In the definition of LUNPCK, the '6/5' condition ! allows for converting from a large base to the ! (smaller) largest power of ten base for output ! conversion. ! The '+ 20' condition allows for the need to carry ! many guard digits when using a small base like 2. ndg2mx = lunpck - 1 ! MXBASE is the maximum value for MBASE. temp = maxint mxbase = int(min(dble(intmax),sqrt(temp))) ! MBASE is the currently used base for arithmetic. k = int(log10(dble(mxbase)/4)) mbase = 10**k ! NDIG is the number of digits currently being carried. npsave = nprec ndig = 2 + (nprec+2)/k IF (ndig<2 .OR. ndig>ndigmx) THEN ndig = max(2,min(ndigmx,ndig)) WRITE (kw,90000) nprec, ndig npsave = 0 END IF ! KFLAG is the flag for error conditions. kflag = 0 ! NTRACE is the trace switch. Default is no printing. ntrace = 0 ! LVLTRC is the trace level. Default is to trace only ! routines called directly by the user. lvltrc = 1 ! NCALL is the call stack pointer. ncall = 0 ! NAMEST is the call stack. DO 30 j = 0, 50 namest(j) = 'MAIN ' 30 CONTINUE ! Some constants that are often needed are stored with the ! maximum precision to which they have been computed in the ! currently used base. This speeds up the trig, log, power, ! and exponential functions. ! NDIGPI is the number of digits available in the currently ! stored value of pi (MPISAV). ndigpi = 0 ! MBSPI is the value of MBASE for the currently stored ! value of pi. mbspi = 0 ! NDIGE is the number of digits available in the currently ! stored value of e (MESAV). ndige = 0 ! MBSE is the value of MBASE for the currently stored ! value of e. mbse = 0 ! NDIGLB is the number of digits available in the currently ! stored value of LN(MBASE) (MLBSAV). ndiglb = 0 ! MBSLB is the value of MBASE for the currently stored ! value of LN(MBASE). mbslb = 0 ! NDIGLI is the number of digits available in the currently ! stored values of the four logarithms used by FMLNI ! MLN1 - MLN4. ndigli = 0 ! MBSLI is the value of MBASE for the currently stored ! values of MLN1 - MLN4. mbsli = 0 ! MXEXP is the current maximum exponent. ! MXEXP2 is the internal maximum exponent. This is used to ! define the overflow and underflow thresholds. ! These values are chosen so that FM routines can raise the ! overflow/underflow limit temporarily while computing ! intermediate results, and so that EXP(INTMAX) is greater ! than MXBASE**(MXEXP2+1). ! The overflow threshold is MBASE**(MXEXP+1), and the ! underflow threshold is MBASE**(-MXEXP-1). ! This means the valid exponents in the first word of an FM ! number can range from -MXEXP to MXEXP+1 (inclusive). mxexp = int((dble(intmax))/(2.0D0*log(dble(mxbase)))-1.0D0) mxexp2 = int(2*mxexp+mxexp/100) ! 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 = -mxexp2 - 5*ndigmx ! MEXPOV is the exponent used as a special symbol for ! overflowed results. mexpov = -mexpun ! MUNKNO is the exponent used as a special symbol for ! unknown FM results (1/0, SQRT(-3.0), ...). munkno = mexpov + 5*ndigmx ! 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) ! JFORM1 indicates the format used by FMOUT. jform1 = 1 ! JFORM2 indicates the number of digits used in FMOUT. jform2 = npsave ! KRAD = 1 indicates that trig functions use radians, ! = 0 means use degrees. krad = 1 ! KWARN = 0 indicates that no warning message is printed ! and execution continues when UNKNOWN or another ! exception is produced. ! = 1 means print a warning message and continue. ! = 2 means print a warning message and stop. kwarn = 1 ! KROUND = 1 causes all results to be rounded to the ! nearest FM number, or to the value with ! an even last digit if the result is halfway ! between two FM numbers. ! = 0 causes all results to be chopped. kround = 1 ! KSWIDE defines the maximum screen width to be used for ! all unit KW output. kswide = 80 ! KESWCH = 1 causes input to FMINP with no digits before ! the exponent letter to be treated as if there ! were a leading '1'. This is sometimes better ! for interactive input: 'E7' converts to ! 10.0**7. ! = 0 causes a leading zero to be assumed. This ! gives compatibility with Fortran: 'E7' ! converts to 0.0. keswch = 1 ! CMCHAR defines the exponent letter to be used for ! FM variable output from FMOUT, as in 1.2345M+678. ! Change it to 'E' for output to be read by a ! non-FM program. cmchar = 'M' ! KSUB is an internal flag set during subtraction so that ! the addition routine will negate its second argument. ksub = 0 ! KDEBUG = 0 Error checking is not done for valid input ! arguments and parameters like NDIG and MBASE ! upon entry to each routine. ! = 1 Error checking is done. kdebug = 0 ! Initialize two hash tables that are used for character ! look-up during input conversion. DO 40 j = lhash1, lhash2 khasht(j) = 5 khashv(j) = 0 40 CONTINUE DO 50 j = 1, 21 kpt = ichar(lchars(j)) IF (kptlhash2) THEN WRITE (kw,90010) lchars(j), kpt, lhash1, lhash2 ELSE khasht(kpt) = ltypes(j) khashv(kpt) = lvals(j) END IF 50 CONTINUE ! DPEPS is the approximate machine precision. one = 1.0D0 two = 128.0D0 dpeps = one 60 dpeps = dpeps/two CALL fmdbl(one,dpeps,yt) IF (yt>one) GO TO 60 dpeps = dpeps*two two = 2.0D0 70 dpeps = dpeps/two CALL fmdbl(one,dpeps,yt) IF (yt>one) GO TO 70 dpeps = dpeps*two ! FMCONS sets several real and double precision constants. CALL fmcons RETURN 90000 FORMAT (//' Precision out of range when calling FMSET.',' NPREC =', & I20/' The nearest valid NDIG will be used',' instead: NDIG =',I6//) 90010 FORMAT (/' Error in input conversion.'/ & ' ICHAR function was out of range for the current', & ' dimensions.'/' ICHAR(''',A,''') gave the value ',I12, & ', which is outside the currently'/' dimensioned',' bounds of (',I5, & ':',I5,') for variables KHASHT ','and KHASHV.'/ & ' Re-define the two parameters ', & 'LHASH1 and LHASH2 so the dimensions will'/' contain', & ' all possible output values from ICHAR.'//) END SUBROUTINE fmset SUBROUTINE fmabs(ma,mb) ! MB = ABS(MA) IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: md2b INTEGER :: kwrnsv ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMABS ' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kflag = 0 kwrnsv = kwarn kwarn = 0 CALL fmeq(ma,mb) mb(2) = abs(mb(2)) kwarn = kwrnsv IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),md2b) END IF IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END SUBROUTINE fmabs SUBROUTINE fmacos(ma,mb) ! MB = ACOS(MA) IMPLICIT NONE ! Scratch array usage during FMACOS: M01 - M06 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, macmax, mxsave INTEGER :: k, kasave, kovun, kreslt, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmatan, fmcons, fmdiv, fmentr, fmeq2, fmexit, fmi2m, & fmmpy, fmntr, fmpi, fmrslt, fmsqrt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF ma2 = ma(2) macca = ma(0) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) ! Use ACOS(X) = ATAN(SQRT(1-X*X)/X) mb(2) = abs(mb(2)) CALL fmi2m(1,m05) CALL fmsub(m05,mb,m03) CALL fmadd(m05,mb,m04) CALL fmmpy(m03,m04,m04) CALL fmsqrt(m04,m04) CALL fmdiv(m04,mb,mb) CALL fmatan(mb,mb) IF (ma2<0) THEN IF (krad==1) THEN CALL fmpi(m05) ELSE CALL fmi2m(180,m05) END IF CALL fmsub(m05,mb,mb) END IF ! Round the result and return. macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmacos SUBROUTINE fmadd(ma,mb,mc) ! MC = MA + MB ! This routine performs the trace printing for addition. ! FMADD2 is used to do the arithmetic. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmadd2, fmntr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMADD ' CALL fmntr(2,ma,mb,2) CALL fmadd2(ma,mb,mc) CALL fmntr(1,mc,mc,1) ELSE CALL fmadd2(ma,mb,mc) END IF ncall = ncall - 1 RETURN END SUBROUTINE fmadd SUBROUTINE fmadd2(ma,mb,mc) ! Internal addition routine. MC = MA + MB IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL :: b2rda, b2rdb REAL (KIND(0.0D0)) :: ma0, ma1, ma2, mb0, mb1, mb2, mb2rd INTEGER :: j, jcomp, jsign, kreslt, n1, nguard, nmwa ! .. ! .. External Subroutines .. EXTERNAL fmaddn, fmaddp, fmargs, fmcons, fmeq, fmmove, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons 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) END IF IF (kreslt/=0) THEN ncall = ncall + 1 IF (ksub==1) THEN namest(ncall) = 'FMSUB ' ELSE namest(ncall) = 'FMADD ' END IF CALL fmrslt(ma,mb,mc,kreslt) ncall = ncall - 1 RETURN END IF ELSE IF (ma(2)==0) THEN ma0 = min(ma(0),mb(0)) CALL fmeq(mb,mc) mc(0) = ma0 kflag = 1 IF (ksub==1) THEN IF (mc(1)/=munkno) mc(2) = -mc(2) kflag = 0 END IF RETURN END IF IF (mb(2)==0) THEN ma0 = min(ma(0),mb(0)) CALL fmeq(ma,mc) mc(0) = ma0 kflag = 1 RETURN END IF END IF ma0 = ma(0) IF (kaccsw==1) THEN mb0 = mb(0) ma1 = ma(1) mb1 = mb(1) END IF 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 END IF nmwa = n1 + nguard ! Save the signs of MA and MB and then work with ! positive numbers. ! JSIGN is the sign of the result of MA + MB. jsign = 1 ma2 = ma(2) mb2 = mb(2) IF (ksub==1) mb2 = -mb2 ma(2) = abs(ma(2)) mb(2) = abs(mb(2)) ! See which one is larger in absolute value. IF (ma(1)>mb(1)) THEN jcomp = 1 GO TO 20 END IF IF (mb(1)>ma(1)) THEN jcomp = 3 GO TO 20 END IF DO 10 j = 2, n1 IF (ma(j)>mb(j)) THEN jcomp = 1 GO TO 20 END IF IF (mb(j)>ma(j)) THEN jcomp = 3 GO TO 20 END IF 10 CONTINUE jcomp = 2 20 IF (jcomp<3) THEN IF (ma2<0) jsign = -1 IF (ma2*mb2>0) THEN CALL fmaddp(ma,mb,nguard,nmwa) ELSE CALL fmaddn(ma,mb,nguard,nmwa) END IF ELSE IF (mb2<0) jsign = -1 IF (ma2*mb2>0) THEN CALL fmaddp(mb,ma,nguard,nmwa) ELSE CALL fmaddn(mb,ma,nguard,nmwa) END IF END IF IF (ksub==1) mb2 = -mb2 mb(2) = mb2 ma(2) = ma2 ! Transfer to MC and fix the sign of the result. CALL fmmove(mwa,mc) IF (jsign<0) mc(2) = -mc(2) IF (kflag<0) THEN IF (ksub==1) THEN namest(ncall) = 'FMSUB ' ELSE namest(ncall) = 'FMADD ' END IF CALL fmwarn END IF 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) END IF ELSE mc(0) = ma0 END IF RETURN END SUBROUTINE fmadd2 SUBROUTINE fmaddi(ma,ival) ! MA = MA + IVAL ! Increment MA by one word integer IVAL. ! This routine is faster than FMADD when IVAL is small enough so ! that it can be added to a single word of MA without often causing ! a carry. Otherwise FMI2M and FMADD are used. IMPLICIT NONE ! Scratch array usage during FMADDI: M01 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maexp, md2b, mksum INTEGER :: kptma ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmi2m, fmntr, fmntri ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMADDI' CALL fmntr(2,ma,ma,1) CALL fmntri(2,ival,0) END IF kflag = 0 maexp = ma(1) IF (maexp<=0 .OR. maexp>ndig) GO TO 10 kptma = int(maexp) + 1 IF (kptma>2 .AND. ma(2)<0) THEN mksum = ma(kptma) - ival ELSE mksum = ma(kptma) + ival END IF IF (mksum>=mbase .OR. mksum<=(-mbase)) GO TO 10 IF (ma(2)<0) THEN IF (kptma>2) THEN IF (mksum>=0) THEN ma(kptma) = mksum GO TO 20 ELSE GO TO 10 END IF ELSE IF (mksum<0) THEN ma(kptma) = mksum GO TO 20 ELSE GO TO 10 END IF END IF ELSE IF (kptma>2) THEN IF (mksum>=0) THEN ma(kptma) = mksum GO TO 20 ELSE GO TO 10 END IF ELSE IF (mksum>0) THEN ma(kptma) = mksum GO TO 20 ELSE GO TO 10 END IF END IF END IF 10 CALL fmi2m(ival,m01) CALL fmadd(ma,m01,ma) 20 IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(ma(2))+1))/0.69315) ma(0) = min(ma(0),md2b) END IF IF (ntrace/=0) THEN CALL fmntr(1,ma,ma,1) END IF 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.GE.MB.GE.0. ! NGUARD is the number of guard digits being carried. ! NMWA is the number of words in MWA that will be used. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int, min ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: nguard, nmwa ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mk, mr INTEGER :: j, k, kl, kp1, kp2, kpt, ksh, n1, n2, nk, nk1 ! .. ! .. External Subroutines .. EXTERNAL fmrnd ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. n1 = ndig + 1 ! Check for an insignificant operand. mk = ma(1) - mb(1) IF (mk>=ndig+2) THEN DO 10 j = 1, n1 mwa(j) = ma(j) 10 CONTINUE mwa(n1+1) = 0 kflag = 1 RETURN END IF k = int(mk) IF (nguard<=1) nmwa = n1 + 2 ! Subtract MB from MA. kp1 = min(n1,k+1) mwa(k+1) = 0 DO 20 j = 1, kp1 mwa(j) = ma(j) 20 CONTINUE kp2 = k + 2 ! (Inner Loop) DO 30 j = kp2, n1 mwa(j) = ma(j) - mb(j-k) 30 CONTINUE n2 = ndig + 2 IF (n2-k<=1) n2 = 2 + k nk = min(nmwa,n1+k) DO 40 j = n2, nk mwa(j) = -mb(j-k) 40 CONTINUE nk1 = nk + 1 DO 50 j = nk1, nmwa mwa(j) = 0 50 CONTINUE ! Normalize. Fix the sign of any negative digit. IF (k>0) THEN DO 60 j = nmwa, kp2, -1 IF (mwa(j)<0) THEN mwa(j) = mwa(j) + mbase mwa(j-1) = mwa(j-1) - 1 END IF 60 CONTINUE kpt = kp2 - 1 70 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 70 END IF GO TO 90 END IF DO 80 j = n1, 3, -1 IF (mwa(j)<0) THEN mwa(j) = mwa(j) + mbase mwa(j-1) = mwa(j-1) - 1 END IF 80 CONTINUE ! Shift left if there are any leading zeros in the mantissa. 90 DO 100 j = 2, nmwa IF (mwa(j)>0) THEN ksh = j - 2 GO TO 110 END IF 100 CONTINUE mwa(1) = 0 RETURN 110 IF (ksh>0) THEN kl = nmwa - ksh DO 120 j = 2, kl mwa(j) = mwa(j+ksh) 120 CONTINUE DO 130 j = kl + 1, nmwa mwa(j) = 0 130 CONTINUE mwa(1) = mwa(1) - ksh END IF ! Round the result. mr = 2*mwa(ndig+2) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwa(n1)1) THEN mwa(n1) = mwa(n1) + 1 mwa(n1+1) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,0) END IF END IF ! See if the result is equal to one of the input arguments. IF (abs(ma(1)-mb(1))ndig+1) THEN kflag = 1 GO TO 150 END IF n2 = ndig + 4 DO 140 j = 3, n1 IF (mwa(n2-j)/=ma(n2-j)) GO TO 150 140 CONTINUE 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.GE.MB.GE.0. ! NMWA is the number of words in MWA that will be used. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, min ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: nguard, nmwa ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mk, mkt, mr INTEGER :: j, k, kp, kp2, kpt, kshift, n1, n2, nk ! .. ! .. External Subroutines .. EXTERNAL fmrnd ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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 10 j = 2, n1 mwa(j+1) = ma(j) 10 CONTINUE mwa(n1+2) = 0 kflag = 1 RETURN END IF k = int(mk) ! Add MA and MB. mwa(1) = ma(1) + 1 mwa(2) = 0 DO 20 j = 2, k + 1 mwa(j+1) = ma(j) 20 CONTINUE kp2 = k + 2 ! (Inner Loop) DO 30 j = kp2, n1 mwa(j+1) = ma(j) + mb(j-k) 30 CONTINUE n2 = ndig + 2 nk = min(nmwa,n1+k) DO 40 j = n2, nk mwa(j+1) = mb(j-k) 40 CONTINUE DO 50 j = nk + 1, nmwa mwa(j+1) = 0 50 CONTINUE ! Normalize. Fix any digit not less than MBASE. IF (k==ndig) GO TO 120 IF (k>0) THEN DO 60 j = n1 + 1, kp2, -1 IF (mwa(j)>=mbase) THEN mwa(j) = mwa(j) - mbase mwa(j-1) = mwa(j-1) + 1 END IF 60 CONTINUE kpt = kp2 - 1 70 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 70 END IF GO TO 90 END IF DO 80 j = n1 + 1, 3, -1 IF (mwa(j)>=mbase) THEN mwa(j) = mwa(j) - mbase mwa(j-1) = mwa(j-1) + 1 END IF 80 CONTINUE ! Shift right if the leading digit is not less than MBASE. 90 IF (mwa(2)>=mbase) THEN 100 kp = nmwa + 4 DO 110 j = 4, nmwa mwa(kp-j) = mwa(kp-j-1) 110 CONTINUE mkt = dint(mwa(2)/mbase) mwa(3) = mwa(2) - mkt*mbase mwa(2) = mkt mwa(1) = mwa(1) + 1 IF (mwa(2)>=mbase) GO TO 100 END IF ! Round the result. 120 kshift = 0 IF (mwa(2)==0) kshift = 1 mr = 2*mwa(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwa(n1+kshift)1) THEN mwa(n1+kshift) = mwa(n1+kshift) + 1 mwa(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,kshift) END IF END IF ! See if the result is equal to one of the input arguments. IF (abs(ma(1)-mb(1))ndig+1) THEN kflag = 1 GO TO 140 END IF n2 = ndig + 4 DO 130 j = 3, n1 IF (mwa(n2-j+1)/=ma(n2-j)) GO TO 140 130 CONTINUE IF (mwa(1)/=ma(1)+1) GO TO 140 IF (mwa(3)/=abs(ma(2))) GO TO 140 kflag = 1 140 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 IMPLICIT NONE ! These tables define the result codes to be returned for ! given values of the input argument(s). ! For example, in row 7 column 2 of this DATA statement ! 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. ! .. Intrinsic Functions .. INTRINSIC abs, int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kreslt, nargs CHARACTER (6) :: kroutn ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mbs INTEGER :: j, kwrnsv, ncatma, ncatmb, nds ! .. ! .. Local Arrays .. INTEGER :: kacos(15), kadd(15,15), kasin(15), katan(15), kcos(15), & kcosh(15), kdiv(15,15), kexp(15), klg10(15), kln(15), kmpy(15,15), & kpwr(15,15), ksin(15), ksinh(15), ksqrt(15), ktan(15), ktanh(15) ! .. ! .. External Subroutines .. EXTERNAL fmcat, fmcons, fmim, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! .. Data Statements .. DATA kadd/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/ DATA kmpy/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/ DATA kdiv/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/ DATA kpwr/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/ DATA ksqrt/12, 12, 12, 12, 12, 12, 12, 11, 12, 0, 0, 8, 0, 0, 12/ DATA kexp/6, 6, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0, 4, 4/ DATA kln/12, 12, 12, 12, 12, 12, 12, 12, 12, 0, 0, 11, 0, 0, 12/ DATA ksin/12, 12, 0, 0, 0, 0, 5, 11, 6, 0, 0, 0, 0, 12, 12/ DATA kcos/12, 12, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0, 12, 12/ DATA ktan/12, 12, 0, 0, 0, 0, 5, 11, 6, 0, 0, 0, 0, 12, 12/ DATA kasin/12, 12, 12, 9, 0, 0, 5, 11, 6, 0, 0, 10, 12, 12, 12/ DATA kacos/12, 12, 12, 13, 0, 10, 10, 10, 10, 10, 0, 11, 12, 12, 12/ DATA katan/9, 9, 0, 14, 0, 0, 5, 11, 6, 0, 0, 15, 0, 10, 10/ DATA ksinh/3, 3, 0, 0, 0, 1, 5, 11, 6, 1, 0, 0, 0, 4, 4/ DATA kcosh/4, 4, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0, 4, 4/ DATA ktanh/7, 7, 0, 0, 0, 1, 5, 11, 6, 1, 0, 0, 0, 8, 8/ DATA klg10/12, 12, 12, 12, 12, 12, 12, 12, 12, 0, 0, 11, 0, 0, 12/ ! .. kreslt = 12 kflag = -4 IF (ma(1)==munkno) RETURN IF (nargs==2) THEN IF (mb(1)==munkno) RETURN END IF 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 50 ! 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,90000) nds, ndig RETURN END IF ! 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,90010) int(mbs), int(mbase) CALL fmcons RETURN END IF ! Check exponent range. IF (ma(1)>mxexp+1 .OR. ma(1)<-mxexp) THEN IF (abs(ma(1))/=mexpov .OR. abs(ma(2))/=1) THEN CALL fmim(0,ma) kflag = -3 CALL fmwarn ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) RETURN END IF END IF IF (nargs==2) THEN IF (mb(1)>mxexp+1 .OR. mb(1)<-mxexp) THEN IF (abs(mb(1))/=mexpov .OR. abs(mb(2))/=1) THEN CALL fmim(0,mb) kflag = -3 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) RETURN END IF END IF END IF ! Check for properly normalized digits in the ! input arguments. IF (abs(ma(1)-int(ma(1)))/=0) kflag = 1 IF (ma(2)<=(-mbase) .OR. ma(2)>=mbase .OR. abs(ma(2)-int(ma(2)))/=0) & kflag = 2 IF (kdebug==0) GO TO 20 DO 10 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 20 END IF 10 CONTINUE 20 IF (kflag/=0) THEN j = kflag mbs = ma(j) CALL fmim(0,ma) 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, ') = ', mbs END IF ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) IF (kwarn>=2) THEN STOP END IF RETURN END IF IF (nargs==2) THEN IF (abs(mb(1)-int(mb(1)))/=0) kflag = 1 IF (mb(2)<=(-mbase) .OR. mb(2)>=mbase .OR. abs(mb(2)-int(mb(2)))/=0) & kflag = 2 IF (kdebug==0) GO TO 40 DO 30 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 40 END IF 30 CONTINUE 40 IF (kflag/=0) THEN j = kflag mbs = mb(j) CALL fmim(0,mb) 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, ') = ', mbs END IF mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) IF (kwarn>=2) THEN STOP END IF RETURN END IF END IF ! Check for special cases. 50 CALL fmcat(ma,ncatma) ncatmb = 0 IF (nargs==2) CALL fmcat(mb,ncatmb) IF (kroutn=='FMADD ') THEN kreslt = kadd(ncatmb,ncatma) GO TO 60 END IF IF (kroutn=='FMSUB ') THEN IF (ncatmb<16) ncatmb = 16 - ncatmb kreslt = kadd(ncatmb,ncatma) GO TO 60 END IF IF (kroutn=='FMMPY ') THEN kreslt = kmpy(ncatmb,ncatma) GO TO 60 END IF IF (kroutn=='FMDIV ') THEN kreslt = kdiv(ncatmb,ncatma) GO TO 60 END IF IF (kroutn=='FMPWR ') THEN kreslt = kpwr(ncatmb,ncatma) GO TO 60 END IF IF (kroutn=='FMSQRT') THEN kreslt = ksqrt(ncatma) GO TO 60 END IF IF (kroutn=='FMEXP ') THEN kreslt = kexp(ncatma) GO TO 60 END IF IF (kroutn=='FMLN ') THEN kreslt = kln(ncatma) GO TO 60 END IF IF (kroutn=='FMSIN ') THEN kreslt = ksin(ncatma) GO TO 60 END IF IF (kroutn=='FMCOS ') THEN kreslt = kcos(ncatma) GO TO 60 END IF IF (kroutn=='FMTAN ') THEN kreslt = ktan(ncatma) GO TO 60 END IF IF (kroutn=='FMASIN') THEN kreslt = kasin(ncatma) IF ((ncatma==7 .OR. ncatma==9) .AND. krad==0) kreslt = 12 GO TO 60 END IF IF (kroutn=='FMACOS') THEN kreslt = kacos(ncatma) GO TO 60 END IF IF (kroutn=='FMATAN') THEN kreslt = katan(ncatma) IF ((ncatma==7 .OR. ncatma==9) .AND. krad==0) kreslt = 12 GO TO 60 END IF IF (kroutn=='FMSINH') THEN kreslt = ksinh(ncatma) GO TO 60 END IF IF (kroutn=='FMCOSH') THEN kreslt = kcosh(ncatma) GO TO 60 END IF IF (kroutn=='FMTANH') THEN kreslt = ktanh(ncatma) GO TO 60 END IF IF (kroutn=='FMLG10') THEN kreslt = klg10(ncatma) GO TO 60 END IF kreslt = 0 RETURN 60 IF (kreslt==12) THEN kflag = -4 CALL fmwarn END IF 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 END IF END IF 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 END IF END IF RETURN 90000 FORMAT (' NDIG was',I10,'. It has been changed to',I10,'.') 90010 FORMAT (' MBASE was',I10,'. It has been changed to',I10,'.') END SUBROUTINE fmargs SUBROUTINE fmasin(ma,mb) ! MB = ARCSIN(MA) IMPLICIT NONE ! Scratch array usage during FMASIN: M01 - M06 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, macmax, mxsave INTEGER :: k, kasave, kovun, kreslt, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmatan, fmcons, fmdiv, fmentr, fmeq2, fmexit, fmi2m, & fmmpy, fmntr, fmrslt, fmsqrt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) ! Use ASIN(X) = ATAN(X/SQRT(1-X*X)) CALL fmi2m(1,m05) CALL fmsub(m05,mb,m03) CALL fmadd(m05,mb,m04) CALL fmmpy(m03,m04,m04) CALL fmsqrt(m04,m04) CALL fmdiv(mb,m04,mb) CALL fmatan(mb,mb) ! Round the result and return. macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmasin SUBROUTINE fmatan(ma,mb) ! MB = ARCTAN(MA) IMPLICIT NONE ! Scratch array usage during FMATAN: M01 - M06 ! .. Intrinsic Functions .. INTRINSIC abs, atan, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma1, ma2, macca, macmax, mxsave REAL (KIND(0.0D0)) :: x, xm INTEGER :: j, k, kasave, kovun, kreslt, krsave, kst, kwrnsv, ndsav1, & ndsave, ndsv ! .. ! .. Local Arrays .. INTEGER :: nstack(19) ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdig, fmdiv, fmdivi, fmdpm, fmentr, fmeq, & fmeq2, fmexit, fmi2m, fmm2dp, fmmpy, fmmpyi, fmntr, fmpi, fmrslt, & fmsin, fmsqr, fmsqrt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)==0) THEN CALL fmentr('FMATAN',ma,ma,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) CALL fmeq2(ma,m05,ndsave,ndig,0) m05(0) = nint(ndig*alogm2) ! If MA.GE.1 work with 1/MA. ma1 = ma(1) ma2 = ma(2) m05(2) = abs(m05(2)) IF (ma1>=1) THEN CALL fmi2m(1,mb) CALL fmdiv(mb,m05,m05) END IF 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=1) THEN CALL fmdivi(mpisav,2,m06) CALL fmsub(m06,mb,mb) END IF ! Convert to degrees if necessary, round and return. krad = krsave IF (krad==0) THEN CALL fmmpyi(mb,180,mb) CALL fmdiv(mb,mpisav,mb) END IF IF (mb(1)/=munkno .AND. ma2<0) mb(2) = -mb(2) IF (kflag==1) kflag = 0 kwarn = kwrnsv macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmatan SUBROUTINE fmatn2(ma,mb,mc) ! MC = ATAN2(MA,MB) ! MC is returned as the angle between -pi and pi (or -180 and 180 if ! degree mode is selected) for which TAN(MC) = MA/MB. MC is an angle ! for the point (MB,MA) in polar coordinates. IMPLICIT NONE ! Scratch array usage during FMATN2: M01 - M06 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, maccb, macmax, mxexp1, mxsave INTEGER :: jquad, k, kasave, kovun, kreslt, kwrnsv, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmatan, fmcons, fmdiv, fmdivi, fmentr, fmeq2, fmexit, fmi2m, & fmim, fmntr, fmpi, fmrslt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. abs(mb(1))>mexpab) THEN CALL fmentr('FMATN2',ma,mb,2,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF kwrnsv = kwarn kwarn = 0 macca = ma(0) maccb = mb(0) CALL fmeq2(ma,m01,ndsave,ndig,0) m01(0) = nint(ndig*alogm2) CALL fmeq2(mb,m02,ndsave,ndig,0) m02(0) = nint(ndig*alogm2) ! Check for special cases. IF (ma(1)==munkno .OR. mb(1)==munkno .OR. (ma(2)==0 .AND. mb(2)==0)) & THEN CALL fmim(0,mc) mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) kflag = -4 GO TO 10 END IF IF (mb(2)==0 .AND. ma(2)>0) THEN IF (krad==0) THEN CALL fmi2m(90,mc) ELSE CALL fmpi(mc) CALL fmdivi(mc,2,mc) END IF GO TO 10 END IF IF (mb(2)==0 .AND. ma(2)<0) THEN IF (krad==0) THEN CALL fmi2m(-90,mc) ELSE CALL fmpi(mc) CALL fmdivi(mc,-2,mc) END IF GO TO 10 END IF mxexp1 = int(mxexp2/2.01D0) IF (ma(1)==mexpov .AND. mb(1)=0 .AND. mb(2)>0) jquad = 1 IF (ma(2)>=0 .AND. mb(2)<0) jquad = 2 IF (ma(2)<0 .AND. mb(2)<0) jquad = 3 IF (ma(2)<0 .AND. mb(2)>0) jquad = 4 CALL fmdiv(m01,m02,mc) mc(2) = abs(mc(2)) CALL fmatan(mc,mc) IF (jquad==2 .OR. jquad==3) THEN IF (krad==0) THEN CALL fmi2m(180,m05) CALL fmsub(m05,mc,mc) ELSE CALL fmpi(m05) CALL fmsub(m05,mc,mc) END IF END IF IF ((jquad==3 .OR. jquad==4) .AND. mc(1)/=munkno) mc(2) = -mc(2) ! Round the result and return. 10 IF (kflag==1) kflag = 0 kwarn = kwrnsv macmax = nint((ndsave-1)*alogm2+log(real(abs(mc(2))+1))/0.69315) mc(0) = min(mc(0),macca,maccb,macmax) CALL fmexit(mc,mc,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmatn2 SUBROUTINE fmbig(ma) ! MA = The biggest representable FM number using the current base ! and precision. ! The smallest positive number is then 1.0/MA. ! Because of rounding, 1.0/(1.0/MA) will then overflow. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, n1 ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMBIG ' IF (mblogs/=mbase) CALL fmcons kflag = 0 n1 = ndig + 1 DO 10 j = 2, n1 ma(j) = mbase - 1 10 CONTINUE ma(1) = mxexp + 1 ma(0) = nint(ndig*alogm2) IF (ntrace/=0) CALL fmntr(1,ma,ma,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) .GE. 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) .GE. MAXEXP-NDIG+1 ) ! 8. 0 ! 9. +UN UN stands for underflowed results. ! 10. (+UN , +UNTH) ( MA(1) .LE. -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) .LE. -MAXEXP+NDIG-1 ) ! 16. UNKNOWN IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ncat ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, mxexp1 INTEGER :: j, nlast ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! Check for special symbols. ncat = 16 IF (ma(1)==munkno) RETURN IF (ma(1)==mexpov) THEN ncat = 15 IF (ma(2)<0) ncat = 1 RETURN END IF IF (ma(1)==mexpun) THEN ncat = 9 IF (ma(2)<0) ncat = 7 RETURN END IF IF (ma(2)==0) THEN ncat = 8 RETURN END IF ! 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 10 j = 3, nlast IF (ma(j)/=0) GO TO 20 10 CONTINUE END IF ncat = 12 IF (ma(2)<0) ncat = 4 RETURN END IF 20 mxexp1 = int(mxexp2/2.01D0) IF (ma(1)>=mxexp1-ndig+1) THEN ncat = 14 IF (ma(2)<0) ncat = 2 RETURN END IF IF (ma(1)>=1) THEN ncat = 13 IF (ma(2)<0) ncat = 3 RETURN END IF IF (ma(1)>=-mxexp1+ndig) THEN ncat = 11 IF (ma(2)<0) ncat = 5 RETURN END IF IF (ma(1)>=-mxexp2) THEN ncat = 10 IF (ma(2)<0) ncat = 6 RETURN END IF 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. IMPLICIT NONE ! Scratch array usage during FMCHSH: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, macmax, mxsave INTEGER :: k, kasave, kovun, kreslt, kwrnsv, ncsave, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmcosh, fmentr, fmeq, fmeq2, fmexit, fmi2m, & fmntr, fmntrj, fmprnt, fmsinh, fmsqr, fmsqrt ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons macca = ma(0) ma2 = ma(2) IF (abs(ma(1))>mexpab) THEN ncsave = ncall CALL fmentr('FMCHSH',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (ma(1)==munkno) kovun = 2 ncall = ncsave + 1 CALL fmeq(ma,m04) m04(0) = nint(ndig*alogm2) m04(2) = abs(m04(2)) CALL fmcosh(m04,mb) CALL fmsinh(m04,mc) GO TO 10 ELSE ncall = ncall + 1 namest(ncall) = 'FMCHSH' IF (ntrace/=0) CALL fmntr(2,ma,ma,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 END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF CALL fmeq2(ma,m04,ndsave,ndig,0) m04(0) = nint(ndig*alogm2) m04(2) = abs(m04(2)) k = 1 IF (m04(1)==0 .AND. m04(2)/=0) THEN IF (mbase/m04(2)>=100) k = 2 END IF 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 10 END IF CALL fmsqr(mb,m03) CALL fmi2m(-1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,mc) ELSE CALL fmsinh(m04,mc) CALL fmsqr(mc,m03) CALL fmi2m(1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,mb) END IF ! Round and return. 10 macmax = nint((ndsave-1)*alogm2+log(real(abs(mc(2))+1))/0.69315) mc(0) = min(mc(0),macca,macmax) IF (ma2<0 .AND. mc(1)/=munkno) mc(2) = -mc(2) CALL fmeq2(mc,mc,ndig,ndsave,1) macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) IF (kovun==2) THEN kwrnsv = kwarn kwarn = 0 END IF CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) IF (kovun==2) THEN kwarn = kwrnsv END IF 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) END IF END IF END IF RETURN END SUBROUTINE fmchsh FUNCTION fmcomp(ma,lrel,mb) ! Logical comparison of FM numbers MA and MB. ! LREL is a CHARACTER *2 description of the comparison to be done: ! LREL = 'EQ' returns FMCOMP = .TRUE. if MA.EQ.MB ! = 'NE', 'GE', 'GT', 'LE', 'LT' also work like a logical IF. ! 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 common variables. Blocks of code that ! modify common 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. IMPLICIT NONE ! .. Function Return Value .. LOGICAL :: fmcomp ! .. ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (2) :: lrel ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, jcomp, nlast CHARACTER (2) :: jrel ! .. ! .. External Subroutines .. EXTERNAL fmntrj, fmprnt ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! DELETE START ncall = ncall + 1 namest(ncall) = 'FMCOMP' IF (ncall<=lvltrc .AND. abs(ntrace)>=2) THEN WRITE (kw,90000) IF (ntrace>0) THEN CALL fmprnt(ma) WRITE (kw,90010) lrel CALL fmprnt(mb) ELSE CALL fmntrj(ma,ndig) WRITE (kw,90010) lrel CALL fmntrj(mb,ndig) END IF END IF ! DELETE STOP ! JCOMP will be 1 if MA.GT.MB ! 2 if MA.EQ.MB ! 3 if MA.LT.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') THEN jrel = 'EQ' ELSE IF (lrel=='ne') THEN jrel = 'NE' ELSE IF (lrel=='lt') THEN jrel = 'LT' ELSE IF (lrel=='gt') THEN jrel = 'GT' ELSE IF (lrel=='le') THEN jrel = 'LE' ELSE IF (lrel=='ge') THEN jrel = 'GE' ELSE fmcomp = .FALSE. ! DELETE START kflag = -4 IF (ncall/=1 .OR. kwarn<=0) GO TO 30 ! DELETE STOP IF (kwarn<=0) GO TO 30 WRITE (kw,90020) lrel IF (kwarn>=2) THEN STOP END IF GO TO 30 END IF END IF IF (ma(1)==munkno .OR. mb(1)==munkno) THEN fmcomp = .FALSE. ! DELETE START kflag = -4 ! DELETE STOP GO TO 30 END IF IF (abs(ma(1))==mexpov .AND. ma(1)==mb(1) .AND. ma(2)==mb(2)) THEN fmcomp = .FALSE. ! DELETE START kflag = -4 IF (ncall/=1 .OR. kwarn<=0) GO TO 30 ! DELETE STOP IF (kwarn<=0) GO TO 30 WRITE (kw,90030) IF (kwarn>=2) THEN STOP END IF GO TO 30 END IF ! Check for zero. ! DELETE START kflag = 0 ! DELETE STOP IF (ma(2)==0) THEN jcomp = 2 IF (mb(2)<0) jcomp = 1 IF (mb(2)>0) jcomp = 3 GO TO 20 END IF IF (mb(2)==0) THEN jcomp = 1 IF (ma(2)<0) jcomp = 3 GO TO 20 END IF ! Check for opposite signs. IF (ma(2)>0 .AND. mb(2)<0) THEN jcomp = 1 GO TO 20 END IF IF (mb(2)>0 .AND. ma(2)<0) THEN jcomp = 3 GO TO 20 END IF ! See which one is larger in absolute value. IF (ma(1)>mb(1)) THEN jcomp = 1 GO TO 20 END IF IF (mb(1)>ma(1)) THEN jcomp = 3 GO TO 20 END IF nlast = ndig + 1 DO 10 j = 2, nlast IF (abs(ma(j))>abs(mb(j))) THEN jcomp = 1 GO TO 20 END IF IF (abs(mb(j))>abs(ma(j))) THEN jcomp = 3 GO TO 20 END IF 10 CONTINUE jcomp = 2 ! Now match the JCOMP value to the requested comparison. 20 IF (jcomp==1 .AND. ma(2)<0) THEN jcomp = 3 ELSE IF (jcomp==3 .AND. mb(2)<0) THEN jcomp = 1 END IF 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. 30 CONTINUE ! DELETE START IF (ntrace/=0) THEN IF (ncall<=lvltrc .AND. abs(ntrace)>=1) THEN IF (kflag==0) THEN WRITE (kw,90040) ncall, int(mbase), ndig ELSE WRITE (kw,90050) ncall, int(mbase), ndig, kflag END IF IF (fmcomp) THEN WRITE (kw,90060) ELSE WRITE (kw,90070) END IF END IF END IF ncall = ncall - 1 ! DELETE STOP RETURN 90000 FORMAT (' Input to FMCOMP') 90010 FORMAT (7X,'.',A2,'.') 90020 FORMAT (/' Error of type KFLAG = -4 in FM package in', & ' routine FMCOMP'//1X,A,' is not one of the six', & ' recognized comparisons.'//' .FALSE. has been',' returned.'/) 90030 FORMAT (/' Error of type KFLAG = -4 in FM package in routine', & ' FMCOMP'//' Two numbers in the same overflow or', & ' underflow category cannot be compared.'// & ' .FALSE. has been returned.'/) 90040 FORMAT (' FMCOMP',15X,'Call level =',I2,5X,'MBASE =',I10,5X,'NDIG =',I6) 90050 FORMAT (' FMCOMP',6X,'Call level =',I2,4X,'MBASE =',I10,4X,'NDIG =',I6, & 4X,'KFLAG =',I3) 90060 FORMAT (7X,'.TRUE.') 90070 FORMAT (7X,'.FALSE.') END FUNCTION fmcomp SUBROUTINE fmcons ! Set several saved machine precision constants. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC atan, dble, dint, int, log, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. mblogs = mbase alogmb = log(real(mbase)) alogm2 = alogmb/log(2.0) alogmx = log(real(maxint)) alogmt = alogmb/log(10.0) ngrd21 = int(2.0/alogmt+1.0) ngrd52 = int(5.0/alogmt+2.0) ngrd22 = int(2.0/alogmt+2.0) mexpab = dint(mxexp2/5) dlogmb = log(dble(mbase)) dlogtn = log(10.0D0) dlogtw = log(2.0D0) dppi = 4.0D0*atan(1.0D0) dlogtp = log(2.0D0*dppi) dlogpi = log(dppi) dlogeb = -log(dpeps)/dlogmb RETURN END SUBROUTINE fmcons SUBROUTINE fmcos(ma,mb) ! MB = COS(MA) IMPLICIT NONE ! Scratch array usage during FMCOS: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, macmax, mxsave INTEGER :: jcos, jsin, jswap, k, kasave, kovun, kreslt, ndsave, ndsv ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmcos2, fmdivi, fmentr, fmeq2, fmexit, fmi2m, fmmpy, & fmntr, fmpi, fmrdc, fmrslt, fmsin2, fmsqr, fmsqrt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)==0) THEN CALL fmentr('FMCOS ',ma,ma,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) mb(2) = abs(mb(2)) ! Reduce the argument, convert to radians if the input is ! in degrees, and evaluate the function. CALL fmrdc(mb,mb,jsin,jcos,jswap) IF (mb(1)==munkno) GO TO 10 IF (krad==0) THEN IF (mbspi/=mbase .OR. ndigpindg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mb(j+1) = 0 10 CONTINUE ndig = ndsave kwarn = kwrnsv RETURN END IF ndsav1 = ndig ! Divide the argument by 2**K2. CALL fmeq2(ma,m02,ndsave,ndig,0) ktwo = 1 maxval = mxbase/2 IF (k2>0) THEN DO 20 j = 1, k2 ktwo = 2*ktwo IF (ktwo>maxval) THEN CALL fmdivi(m02,ktwo,m02) ktwo = 1 END IF 20 CONTINUE IF (ktwo>1) CALL fmdivi(m02,ktwo,m02) END IF ! Split into J2 concurrent sums and reduce NDIG while ! computing each term in the sum as the terms get smaller. CALL fmsqr(m02,m02) CALL fmeq(m02,m03) m03(2) = -m03(2) nterm = 2 DO 30 j = 1, j2 nbot = nterm*(nterm-1) CALL fmdivi(m03,nbot,m03) nterm = nterm + 2 kpt = (j-1)*(ndig+2) CALL fmeq(m03,mjsums(kpt)) m03(2) = -m03(2) 30 CONTINUE IF (m02(1)<-ndig) GO TO 60 CALL fmipwr(m02,j2,mb) 40 CALL fmmpy(m03,mb,m03) large = int(intmax/nterm) DO 50 j = 1, j2 nbot = nterm*(nterm-1) IF (nterm>large .OR. nbot>mxbase) THEN CALL fmdivi(m03,nterm,m03) nbot = nterm - 1 CALL fmdivi(m03,nbot,m03) ELSE CALL fmdivi(m03,nbot,m03) END IF kpt = (j-1)*(ndsav1+2) ndig = ndsav1 CALL fmadd(mjsums(kpt),m03,mjsums(kpt)) IF (kflag/=0) GO TO 60 ndig = ndsav1 - int(mjsums(kpt+1)-m03(1)) IF (ndig<2) ndig = 2 m03(2) = -m03(2) nterm = nterm + 2 50 CONTINUE GO TO 40 ! Next put the J2 separate sums back together. 60 kflag = 0 kpt = (j2-1)*(ndig+2) CALL fmeq(mjsums(kpt),mb) IF (j2>=2) THEN DO 70 j = 2, j2 CALL fmmpy(m02,mb,mb) kpt = (j2-j)*(ndig+2) CALL fmadd(mb,mjsums(kpt),mb) 70 CONTINUE END IF ! 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 80 j = 1, k2 CALL fmadd(mb,m02,m03) CALL fmmpy(mb,m03,m03) CALL fmadd(m03,m03,mb) 80 CONTINUE ELSE DO 90 j = 1, k2 CALL fmsqr(mb,m03) CALL fmadd(mb,mb,m02) CALL fmadd(m03,m02,m03) CALL fmadd(m03,m03,mb) 90 CONTINUE END IF END IF CALL fmi2m(1,m03) CALL fmadd(m03,mb,mb) CALL fmeq2(mb,mb,ndsav1,ndsave,1) ndig = ndsave kwarn = kwrnsv RETURN END SUBROUTINE fmcos2 SUBROUTINE fmcosh(ma,mb) ! MB = COSH(MA) IMPLICIT NONE ! Scratch array usage during FMCOSH: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, macmax, mxsave INTEGER :: k, kasave, kovun, kreslt, ndsave, nmethd ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmcsh2, fmdiv, fmdivi, fmentr, fmeq2, fmexit, & fmexp, fmi2m, fmntr, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab) THEN CALL fmentr('FMCOSH',ma,ma,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) mb(2) = abs(mb(2)) IF (ma(2)==0) THEN CALL fmi2m(1,mb) GO TO 20 END IF ! Use a series for small arguments, FMEXP for large ones. IF (mb(1)==munkno) GO TO 20 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 END IF ELSE IF (mb(1)<=0) THEN nmethd = 1 ELSE nmethd = 2 END IF END IF IF (nmethd==2) GO TO 10 CALL fmcsh2(mb,mb) GO TO 20 10 CALL fmexp(mb,mb) IF (mb(1)==mexpov) THEN GO TO 20 ELSE IF (mb(1)==mexpun) THEN mb(1) = mexpov GO TO 20 END IF IF (int(mb(1))<=(ndig+1)/2) THEN CALL fmi2m(1,m01) CALL fmdiv(m01,mb,m01) CALL fmadd(mb,m01,mb) END IF CALL fmdivi(mb,2,mb) ! Round and return. 20 macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmcosh SUBROUTINE fmcsh2(ma,mb) ! Internal subroutine for MB = COSH(MA). IMPLICIT NONE ! Scratch array usage during FMCSH2: M01 - M03 ! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent ! sums. Increasing this value will begin to improve the ! speed of COSH when the base is large and precision exceeds ! about 1,500 decimal digits. ! .. Intrinsic Functions .. INTRINSIC int, log, max, min, nint, real, sqrt ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL :: alog2, alogt, b, t, tj REAL (KIND(0.0D0)) :: maxval INTEGER :: j, j2, k, k2, kpt, ktwo, kwrnsv, l, l2, large, n2, nbot, & ndsav1, ndsave, nterm ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdivi, fmeq, fmeq2, fmi2m, fmipwr, fmmpy, & fmsqr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mjsums(0:ljsums), & mlbsav(0:lunpck), mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), & mln4(0:lunpck), mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmsums/mjsums COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (ma(2)==0) THEN CALL fmi2m(1,mb) RETURN END IF 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) END IF IF (j2<=1) j2 = 1 n2 = int(t*alogmb/(alogt+real(l)*alog2)) l2 = int(log(real(n2)+2.0**k2)/alogmb) ndig = ndig + l2 IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mb(j+1) = 0 10 CONTINUE ndig = ndsave kwarn = kwrnsv RETURN END IF ndsav1 = ndig CALL fmeq2(ma,m02,ndsave,ndig,0) ! Divide the argument by 2**K2. ktwo = 1 maxval = mxbase/2 IF (k2>0) THEN DO 20 j = 1, k2 ktwo = 2*ktwo IF (ktwo>maxval) THEN CALL fmdivi(m02,ktwo,m02) ktwo = 1 END IF 20 CONTINUE IF (ktwo>1) CALL fmdivi(m02,ktwo,m02) END IF ! Split into J2 concurrent sums and reduce NDIG while ! computing each term in the sum as the terms get smaller. CALL fmsqr(m02,m02) CALL fmeq(m02,m03) nterm = 2 DO 30 j = 1, j2 nbot = nterm*(nterm-1) CALL fmdivi(m03,nbot,m03) nterm = nterm + 2 kpt = (j-1)*(ndig+2) CALL fmeq(m03,mjsums(kpt)) 30 CONTINUE IF (m02(1)<-ndig) GO TO 60 CALL fmipwr(m02,j2,mb) 40 CALL fmmpy(m03,mb,m03) large = int(intmax/nterm) DO 50 j = 1, j2 nbot = nterm*(nterm-1) IF (nterm>large .OR. nbot>mxbase) THEN CALL fmdivi(m03,nterm,m03) nbot = nterm - 1 CALL fmdivi(m03,nbot,m03) ELSE CALL fmdivi(m03,nbot,m03) END IF kpt = (j-1)*(ndsav1+2) ndig = ndsav1 CALL fmadd(mjsums(kpt),m03,mjsums(kpt)) IF (kflag/=0) GO TO 60 ndig = ndsav1 - int(mjsums(kpt+1)-m03(1)) IF (ndig<2) ndig = 2 nterm = nterm + 2 50 CONTINUE GO TO 40 ! Next put the J2 separate sums back together. 60 kflag = 0 kpt = (j2-1)*(ndig+2) CALL fmeq(mjsums(kpt),mb) IF (j2>=2) THEN DO 70 j = 2, j2 CALL fmmpy(m02,mb,mb) kpt = (j2-j)*(ndig+2) CALL fmadd(mb,mjsums(kpt),mb) 70 CONTINUE END IF ! 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 80 j = 1, k2 CALL fmadd(mb,m02,m03) CALL fmmpy(mb,m03,m03) CALL fmadd(m03,m03,mb) 80 CONTINUE ELSE DO 90 j = 1, k2 CALL fmsqr(mb,m03) CALL fmadd(mb,mb,m02) CALL fmadd(m03,m02,m03) CALL fmadd(m03,m03,mb) 90 CONTINUE END IF END IF CALL fmi2m(1,m03) CALL fmadd(m03,mb,mb) CALL fmeq2(mb,mb,ndsav1,ndsave,1) ndig = ndsave kwarn = kwrnsv RETURN END SUBROUTINE fmcsh2 SUBROUTINE fmcssn(ma,mb,mc) ! MB = COS(MA), MC = SIN(MA) ! If both the sine and cosine are needed, this routine is faster ! than calling both FMCOS and FMSIN. ! MB and MC must be distinct arrays. IMPLICIT NONE ! Scratch array usage during FMCSSN: M01 - M05 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, macmax, mxsave INTEGER :: jcos, jsin, jswap, k, kasave, kovun, kreslt, kwrnsv, ncsave, & ndsave, ndsv ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmcos, fmcos2, fmdivi, fmentr, fmeq, fmeq2, fmexit, & fmi2m, fmmpy, fmntr, fmntrj, fmpi, fmprnt, fmrdc, fmsin, fmsin2, & fmsqr, fmsqrt, fmsub ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons macca = ma(0) ma2 = ma(2) IF (abs(ma(1))>mexpab .OR. ma(2)==0) THEN ncsave = ncall CALL fmentr('FMCSSN',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (ma(1)==munkno) kovun = 2 ncall = ncsave + 1 CALL fmeq(ma,m05) m05(0) = nint(ndig*alogm2) m05(2) = abs(m05(2)) CALL fmcos(m05,mb) CALL fmsin(m05,mc) GO TO 10 ELSE ncall = ncall + 1 namest(ncall) = 'FMCSSN' IF (ntrace/=0) CALL fmntr(2,ma,ma,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 END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF IF (ma(2)==0) THEN CALL fmi2m(1,mb) CALL fmi2m(0,mc) GO TO 10 END IF CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) mb(2) = abs(mb(2)) ! Reduce the argument, convert to radians if the input is ! in degrees, and evaluate the functions. CALL fmrdc(mb,mb,jsin,jcos,jswap) IF (mb(1)==munkno) THEN CALL fmeq(mb,mc) GO TO 10 END IF IF (krad==0) THEN IF (mbspi/=mbase .OR. ndigpi=1 .AND. ncall+1<=lvltrc) THEN IF (ntrace<0) THEN CALL fmntrj(mc,ndig) ELSE CALL fmprnt(mc) END IF END IF END IF 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. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kst ! .. ! .. Array Arguments .. INTEGER :: nstack(19) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: y INTEGER :: j, jt, l, nd, ndt, ne ! .. ! .. External Subroutines .. EXTERNAL fmcons ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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 (ndne .AND. nd>2) GO TO 10 ! Reverse the stack. l = kst/2 DO 20 j = 1, l jt = nstack(j) nstack(j) = nstack(kst+1-j) nstack(kst+1-j) = jt 20 CONTINUE RETURN END SUBROUTINE fmdig SUBROUTINE fmdim(ma,mb,mc) ! MC = DIM(MA,MB) ! Positive difference. MC = MA - MB if MA.GE.MB, ! = 0 otherwise. IMPLICIT NONE ! Scratch array usage during FMDIM: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, maccb, macmax, mxsave INTEGER :: k, kasave, kovun, kreslt, kwrnsv, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmentr, fmeq2, fmexit, fmi2m, fmntr, fmrslt, fmsub, & fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. abs(mb(1))>mexpab) THEN CALL fmentr('FMDIM ',ma,mb,2,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw mxsave = mxexp mxexp = mxexp2 END IF kwrnsv = kwarn kwarn = 0 mxexp = mxsave macca = ma(0) maccb = mb(0) CALL fmeq2(ma,m01,ndsave,ndig,0) m01(0) = nint(ndig*alogm2) CALL fmeq2(mb,m02,ndsave,ndig,0) m02(0) = nint(ndig*alogm2) IF (fmcomp(m01,'LT',m02)) THEN CALL fmi2m(0,mc) ELSE CALL fmsub(m01,m02,mc) END IF IF (kflag==1) kflag = 0 kwarn = kwrnsv macmax = nint((ndsave-1)*alogm2+log(real(abs(mc(2))+1))/0.69315) mc(0) = min(mc(0),macca,maccb,macmax) CALL fmexit(mc,mc,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmdim SUBROUTINE fmdiv(ma,mb,mc) ! MC = MA / MB ! This routine performs the trace printing for division. ! FMDIV2 is used to do the arithmetic. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmdiv2, fmntr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMDIV ' CALL fmntr(2,ma,mb,2) CALL fmdiv2(ma,mb,mc) CALL fmntr(1,mc,mc,1) ELSE CALL fmdiv2(ma,mb,mc) END IF ncall = ncall - 1 RETURN END SUBROUTINE fmdiv SUBROUTINE fmdiv2(ma,mb,mc) ! Internal division routine. MC = MA / MB IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dble, dint, int, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, ma2p, macca, maccb, maxmwa, mb1, mb2, mb2p, mbm1, & mcarry, md2b, mkt, mlmax, mlr, mqd REAL (KIND(0.0D0)) :: xb, xbase, xbr, xmwa INTEGER :: j, jb, jl, ka, kb, kl, kptmwa, kreslt, n1, ng, nguard, nl, & nmbwds, nzdmb ! .. ! .. External Subroutines .. EXTERNAL fmargs, fmcons, fmim, fmmove, fmrnd, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons 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) ncall = ncall - 1 RETURN END IF ELSE IF (mb(2)==0) THEN CALL fmim(0,mc) mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) namest(ncall) = 'FMDIV ' kflag = -4 CALL fmwarn RETURN END IF IF (ma(2)==0) THEN CALL fmim(0,mc) mc(0) = min(macca,maccb) RETURN END IF END IF 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 END IF ma2p = abs(ma(2)) mb2p = abs(mb(2)) n1 = ndig + 1 ng = ndig + nguard ! Copy MA into the working array. DO 10 j = 3, n1 mwa(j+1) = ma(j) 10 CONTINUE mwa(1) = ma(1) - mb(1) + 1 mwa(2) = 0 nl = n1 + nguard + 3 DO 20 j = ndig + 3, nl mwa(j) = 0 20 CONTINUE ! Save the sign of MA and MB and then work only with ! positive numbers. ma2 = ma(2) mb1 = mb(1) mb2 = mb(2) ma(2) = ma2p mwa(3) = ma(2) mb(1) = 0 mb(2) = mb2p ! NMBWDS is the number of words of MB used to ! compute the estimated quotient digit MQD. nmbwds = 4 IF (mbase<100) nmbwds = 7 ! XB is an approximation of MB used in ! estimating the quotient digits. xbase = dble(mbase) xb = 0 jl = nmbwds IF (jl<=n1) THEN DO 30 j = 2, jl xb = xb*xbase + dble(mb(j)) 30 CONTINUE ELSE DO 40 j = 2, jl IF (j<=n1) THEN xb = xb*xbase + dble(mb(j)) ELSE xb = xb*xbase END IF 40 CONTINUE END IF IF (jl+1<=n1) 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) ! Count the trailing zero digits of MB. DO 50 j = n1, 2, -1 IF (mb(j)/=0) THEN nzdmb = n1 - j GO TO 60 END IF 50 CONTINUE ! 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. 60 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. 70 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 80 j = kptmwa + 4, kl xmwa = xmwa*xbase + dble(mwa(j)) 80 CONTINUE ELSE xmwa = dble(mwa(kptmwa)) DO 90 j = kptmwa + 1, kl IF (j<=nl) THEN xmwa = xmwa*xbase + dble(mwa(j)) ELSE xmwa = xmwa*xbase END IF 90 CONTINUE END IF ! MQD is the estimated quotient digit. mqd = dint(xmwa*xbr) IF (mqd<0) mqd = mqd - 1 IF (mqd>0) THEN maxmwa = maxmwa + mqd ELSE maxmwa = maxmwa - mqd END IF ! See if MWA must be normalized. ka = kptmwa + 1 kb = min(ka+ndig-1-nzdmb,nl) IF (maxmwa>=mlmax) THEN DO 100 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 END IF 100 CONTINUE xmwa = 0 IF (kl<=nl) THEN DO 110 j = kptmwa, kl xmwa = xmwa*xbase + dble(mwa(j)) 110 CONTINUE ELSE DO 120 j = kptmwa, kl IF (j<=nl) THEN xmwa = xmwa*xbase + dble(mwa(j)) ELSE xmwa = xmwa*xbase END IF 120 CONTINUE END IF mqd = dint(xmwa*xbr) IF (mqd<0) mqd = mqd - 1 IF (mqd>0) THEN maxmwa = mqd ELSE maxmwa = -mqd END IF END IF ! Subtract MQD*MB from MWA. jb = ka - 2 IF (mqd/=0) THEN ! Major (Inner Loop) DO 130 j = ka, kb mwa(j) = mwa(j) - mqd*mb(j-jb) 130 CONTINUE END IF mwa(ka) = mwa(ka) + mwa(ka-1)*mbase mwa(kptmwa) = mqd kptmwa = kptmwa + 1 IF (kptmwa<=ng) GO TO 70 IF (mwa(2)==0 .AND. kptmwa<=ng+1) GO TO 70 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 140 j = kptmwa + 4, kl xmwa = xmwa*xbase + dble(mwa(j)) 140 CONTINUE ELSE xmwa = dble(mwa(kptmwa)) DO 150 j = kptmwa + 1, kl IF (j<=nl) THEN xmwa = xmwa*xbase + dble(mwa(j)) ELSE xmwa = xmwa*xbase END IF 150 CONTINUE END IF mqd = dint(xmwa*xbr) IF (mqd<0) mqd = mqd - 1 mwa(kptmwa) = mqd mwa(kptmwa+1) = 0 mwa(kptmwa+2) = 0 ! Final normalization. DO 160 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 END IF 160 CONTINUE ! Round, affix the sign, and return. ma(2) = ma2 mb(1) = mb1 mb(2) = mb2 IF (mwa(2)==0) THEN mlr = 2*mwa(ndig+3) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwa(n1+1)1) THEN mwa(n1+1) = mwa(n1+1) + 1 mwa(n1+2) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,1) END IF END IF ELSE mlr = 2*mwa(ndig+2) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwa(n1)1) THEN mwa(n1) = mwa(n1) + 1 mwa(n1+1) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,0) END IF END IF END IF CALL fmmove(mwa,mc) IF (kflag<0) THEN namest(ncall) = 'FMDIV ' CALL fmwarn END IF IF (ma2*mb2<0) mc(2) = -mc(2) IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(mc(2))+1))/0.69315) mc(0) = min(macca,maccb,md2b) ELSE mc(0) = min(macca,maccb) END IF RETURN END SUBROUTINE fmdiv2 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dble, dint, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck), & me(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, ma2p, macca, maccb, maccc, maxmwa, mb2, mb2p, mbm1, & mc1, mc2, mc2p, mcarry, md2b, mkt, mlmax, mlr, mqdmwa, mqdmwd, mtemp REAL (KIND(0.0D0)) :: xb, xbase, xbr, xmwa, xmwd INTEGER :: j, jb, jl, ka, kb, kl, kovun, kptmw, n1, ng, nguard, nl, & nmbwds, nzdmb ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmdiv2, fmeq, fmim, fmmove, fmntr, fmntrj, fmprnt, & fmrnd, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa), mwd(lmwa), mwe(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /fmwa/mwd, mwe ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMDIVD' CALL fmntr(2,ma,mb,2) IF (abs(ntrace)>=2 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN CALL fmntrj(mc,ndig) ELSE CALL fmprnt(mc) END IF END IF END IF 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) & 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) END IF namest(ncall) = 'FMDIVD' CALL fmwarn END IF CALL fmeq(mwd,md) GO TO 170 END IF IF (mc(2)==0) THEN CALL fmim(0,md) md(1) = munkno md(2) = 1 md(0) = nint(ndig*alogm2) CALL fmim(0,me) me(1) = munkno me(2) = 1 me(0) = nint(ndig*alogm2) namest(ncall) = 'FMDIVD' kflag = -4 CALL fmwarn GO TO 170 END IF 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 170 END IF 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 END IF 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 10 j = 3, n1 mwa(j+1) = ma(j) mwd(j+1) = mb(j) 10 CONTINUE mwa(1) = ma(1) - mc(1) + 1 mwd(1) = mb(1) - mc(1) + 1 mwa(2) = 0 mwd(2) = 0 nl = n1 + nguard + 3 DO 20 j = ndig + 3, nl mwa(j) = 0 mwd(j) = 0 20 CONTINUE ! Save the signs and then work only with ! positive numbers. ma2 = ma(2) mb2 = mb(2) mc1 = mc(1) mc2 = mc(2) ma(2) = ma2p mb(2) = mb2p mwa(3) = ma(2) mwd(3) = mb(2) mc(1) = 0 mc(2) = mc2p ! NMBWDS is the number of words used to compute ! the estimated quotient digits. nmbwds = 4 IF (mbase<100) nmbwds = 7 ! XB is an approximation of MC used in selecting ! estimated quotients. xbase = dble(mbase) xb = 0 jl = nmbwds IF (jl<=n1) THEN DO 30 j = 2, jl xb = xb*xbase + dble(mc(j)) 30 CONTINUE ELSE DO 40 j = 2, jl IF (j<=n1) THEN xb = xb*xbase + dble(mc(j)) ELSE xb = xb*xbase END IF 40 CONTINUE END IF 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 50 j = n1, 2, -1 IF (mc(j)/=0) THEN nzdmb = n1 - j GO TO 60 END IF 50 CONTINUE ! 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. 60 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. 70 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 80 j = kptmw + 4, kl xmwa = xmwa*xbase + dble(mwa(j)) xmwd = xmwd*xbase + dble(mwd(j)) 80 CONTINUE ELSE xmwa = dble(mwa(kptmw)) xmwd = dble(mwd(kptmw)) DO 90 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 END IF 90 CONTINUE END IF ! MQDMWA and MQDMWD are the estimated quotient digits. mqdmwa = dint(xmwa*xbr) IF (mqdmwa<0) mqdmwa = mqdmwa - 1 mqdmwd = dint(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 100 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 END IF 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 END IF 100 CONTINUE xmwa = 0 xmwd = 0 IF (kl<=nl) THEN DO 110 j = kptmw, kl xmwa = xmwa*xbase + dble(mwa(j)) xmwd = xmwd*xbase + dble(mwd(j)) 110 CONTINUE ELSE DO 120 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 END IF 120 CONTINUE END IF mqdmwa = dint(xmwa*xbr) IF (mqdmwa<0) mqdmwa = mqdmwa - 1 mqdmwd = dint(xmwd*xbr) IF (mqdmwd<0) mqdmwd = mqdmwd - 1 maxmwa = max(abs(mqdmwa),abs(mqdmwd)) END IF ! Subtract MQDMWA*MC from MWA and MQDMWD*MC from MWD. jb = ka - 2 ! Major (Inner Loop) DO 130 j = ka, kb mtemp = mc(j-jb) mwa(j) = mwa(j) - mqdmwa*mtemp mwd(j) = mwd(j) - mqdmwd*mtemp 130 CONTINUE 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 70 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 140 j = kptmw + 4, kl xmwa = xmwa*xbase + dble(mwa(j)) xmwd = xmwd*xbase + dble(mwd(j)) 140 CONTINUE ELSE xmwa = dble(mwa(kptmw)) xmwd = dble(mwd(kptmw)) DO 150 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 END IF 150 CONTINUE END IF mqdmwa = dint(xmwa*xbr) IF (mqdmwa<0) mqdmwa = mqdmwa - 1 mqdmwd = dint(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 160 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 END IF 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 END IF 160 CONTINUE ! Round, affix the sign, and return. ma(2) = ma2 mb(2) = mb2 mc(1) = mc1 mc(2) = mc2 IF (mwa(2)==0) THEN mlr = 2*mwa(ndig+3) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwa(n1+1)1) THEN mwa(n1+1) = mwa(n1+1) + 1 mwa(n1+2) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,1) END IF END IF ELSE mlr = 2*mwa(ndig+2) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwa(n1)1) THEN mwa(n1) = mwa(n1) + 1 mwa(n1+1) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,0) END IF END IF END IF CALL fmmove(mwa,md) IF (mwd(2)==0) THEN mlr = 2*mwd(ndig+3) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwd(n1+1)1) THEN mwd(n1+1) = mwd(n1+1) + 1 mwd(n1+2) = 0 END IF ELSE CALL fmrnd(mwd,ndig,nguard,1) END IF END IF ELSE mlr = 2*mwd(ndig+2) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwd(n1)1) THEN mwd(n1) = mwd(n1) + 1 mwd(n1+1) = 0 END IF ELSE CALL fmrnd(mwd,ndig,nguard,0) END IF END IF END IF CALL fmmove(mwd,me) IF (kflag<0) THEN namest(ncall) = 'FMDIVD' CALL fmwarn END IF IF (ma2*mc2<0) md(2) = -md(2) IF (mb2*mc2<0) me(2) = -me(2) IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(md(2))+1))/0.69315) md(0) = min(macca,maccc,md2b) md2b = nint((ndig-1)*alogm2+log(real(abs(me(2))+1))/0.69315) me(0) = min(maccb,maccc,md2b) ELSE md(0) = min(macca,maccc) me(0) = min(maccb,maccc) END IF 170 IF (ntrace/=0) THEN CALL fmntr(1,md,md,1) IF (abs(ntrace)>=1 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN CALL fmntrj(me,ndig) ELSE CALL fmprnt(me) END IF END IF END IF ncall = ncall - 1 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. IMPLICIT NONE ! Scratch array usage during FMDIVI: M01 ! .. Intrinsic Functions .. INTRINSIC abs, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, md2b ! .. ! .. External Subroutines .. EXTERNAL fmdivn, fmntr, fmntri ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 macca = ma(0) ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMDIVI' CALL fmntr(2,ma,ma,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 END IF CALL fmntr(1,mb,mb,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 END IF END IF ncall = ncall - 1 RETURN END SUBROUTINE fmdivi SUBROUTINE fmdivn(ma,ival,mb) ! Internal divide by integer routine. MB = MA / IVAL IMPLICIT NONE ! Scratch array usage during FMDIVN: M01 ! .. Intrinsic Functions .. INTRINSIC abs, int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma1, ma2, mkt, mlr, modint, mvalp INTEGER :: j, ka, kb, kl, kpt, kptwa, n1, nguard, nmval, nv2 ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmdiv2, fmeq, fmim, fmmove, fmrnd, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! Check for special cases. IF (mblogs/=mbase) CALL fmcons n1 = ndig + 1 IF (ma(1)==munkno .OR. ival==0) THEN ma1 = ma(1) CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -4 IF (ma1/=munkno) THEN namest(ncall) = 'FMDIVI' CALL fmwarn END IF RETURN END IF IF (ma(2)==0) THEN CALL fmeq(ma,mb) RETURN END IF IF (abs(ma(1))1) GO TO 20 IF (abs(ival)==1) THEN DO 10 j = 0, n1 mb(j) = ma(j) 10 CONTINUE mb(2) = ma(2)*ival IF (ma(1)==mexpov) kflag = -5 IF (ma(1)==mexpun) kflag = -6 RETURN END IF IF (ma(1)==mexpun) THEN ma2 = ma(2) CALL fmim(0,mb) mb(1) = mexpun mb(2) = 1 IF ((ma2<0 .AND. ival>0) .OR. (ma2>0 .AND. ival<0)) mb(2) = -1 mb(0) = nint(ndig*alogm2) kflag = -6 RETURN END IF IF (ma(1)==mexpov) THEN CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) namest(ncall) = 'FMDIVI' kflag = -4 CALL fmwarn RETURN END IF ! NGUARD is the number of guard digits used. 20 IF (ncall>1) THEN nguard = ngrd21 ELSE nguard = ngrd52 END IF ! If ABS(IVAL).GE.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) RETURN END IF ! Work with positive numbers. ma2 = ma(2) ma(2) = abs(ma(2)) ! Find the first significant digit of the quotient. mkt = ma(2) IF (mkt>=mvalp) THEN kpt = 2 GO TO 50 END IF DO 30 j = 3, n1 mkt = mkt*mbase + ma(j) IF (mkt>=mvalp) THEN kpt = j GO TO 50 END IF 30 CONTINUE kpt = n1 40 kpt = kpt + 1 mkt = mkt*mbase IF (mkt=mbase) THEN IF (mlr-1>mbase .AND. mwa(n1)1) THEN mwa(n1) = mwa(n1) + 1 mwa(n1+1) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,0) END IF END IF CALL fmmove(mwa,mb) IF (kflag<0) THEN namest(ncall) = 'FMDIVI' CALL fmwarn END IF IF ((ma2<0 .AND. ival>0) .OR. (ma2>0 .AND. ival<0)) mb(2) = -mb(2) RETURN END SUBROUTINE fmdivn SUBROUTINE fmdm(x,ma) ! Internal routine for converting double precision to multiple ! precision. Called by FMDPM. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, min, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mk, mn REAL (KIND(0.0D0)) :: one, xbase, y, yt INTEGER :: j, k, n1, ne ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmdbl, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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 10 j = 1, n1 ma(j) = 0 10 CONTINUE GO TO 140 END IF ! Get the exponent. IF (y>one) THEN IF (y/xbaseone) GO TO 20 IF (yy) THEN 40 k = k - 1 y = y*xbase IF (yone) THEN k = k + 1 y = y/xbase ma(1) = k GO TO 80 END IF ELSE DO 50 j = 1, ndig + 1 ma(j) = 0 50 CONTINUE ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) kflag = -4 CALL fmwarn RETURN END IF END IF 60 ma(1) = k + 1 ma(2) = 1 DO 70 j = 3, n1 ma(j) = 0 70 CONTINUE GO TO 140 ! Build the rest of the number. 80 DO 90 j = 2, ne y = y*xbase mk = dint(y) yt = -mk CALL fmdbl(y,yt,y) ma(j) = mk IF (j>=n1) GO TO 110 90 CONTINUE k = ne + 1 DO 100 j = k, n1 ma(j) = 0 100 CONTINUE ! Normalize. 110 IF (abs(ma(2))>=mbase) THEN k = n1 + 1 DO 120 j = 3, n1 k = k - 1 ma(k) = ma(k-1) 120 CONTINUE mn = dint(ma(2)/mbase) ma(3) = ma(2) - mn*mbase ma(2) = mn ma(1) = ma(1) + 1 GO TO 140 END IF IF (ma(2)==0) THEN DO 130 j = 2, ndig ma(j) = ma(j+1) 130 CONTINUE ma(1) = ma(1) - 1 ma(n1) = 0 END IF 140 IF (x<0.0) ma(2) = -ma(2) ma(0) = min(nint((ne-1)*alogm2),nint(ndig*alogm2)) RETURN END SUBROUTINE fmdm SUBROUTINE fmdm2(x,ma) ! Internal routine for converting double precision to multiple ! precision. Called by FMDP2M. IMPLICIT NONE ! Scratch array usage during FMDM2: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC abs, dble, int, log, max, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: two20, y INTEGER :: j, jexp, k, kexp, kreslt, n1, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmi2m, fmipwr, fmmpy, fmntr, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! Increase the working precision. ndsave = ndig IF (ncall==1) THEN k = max(ngrd21,1) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,ma,kreslt) IF (ntrace/=0) CALL fmntr(1,ma,ma,1) ncall = ncall - 1 RETURN END IF END IF IF (mblogs/=mbase) CALL fmcons kflag = 0 n1 = ndig + 1 IF (x==0.0D0) THEN DO 10 j = 1, n1 ma(j) = 0 10 CONTINUE GO TO 60 END IF 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 20 j = 1, k two20 = two20*2.0D0 20 CONTINUE END IF kexp = 0 IF (y>two20) THEN 30 y = y/two20 kexp = kexp + 1 IF (y>two20) GO TO 30 ELSE IF (y<1.0D0) THEN 40 y = y*two20 kexp = kexp - 1 IF (y<1.0D0) GO TO 40 END IF k = int(two20) CALL fmi2m(k,m04) k = int(y) CALL fmi2m(k,m02) y = (y-dble(k))*two20 jexp = 0 50 k = int(y) CALL fmi2m(k,m03) CALL fmmpy(m02,m04,m02) jexp = jexp + 1 CALL fmadd(m02,m03,m02) y = (y-dble(k))*two20 IF (jexp<=1000 .AND. y/=0.0D0) GO TO 50 k = kexp - jexp CALL fmipwr(m04,k,m03) CALL fmmpy(m02,m03,ma) 60 IF (x<0.0) ma(2) = -ma(2) ma(0) = nint((ndsave-1)*alogm2+log(real(abs(ma(2))+1))/0.69315) ndig = ndsave RETURN END SUBROUTINE fmdm2 SUBROUTINE fmdp2m(x,ma) ! MA = X ! Convert a double precision floating point number to FM format. ! This version tries to convert the double precision machine ! number to FM with accuracy of nearly full FM precision. ! If conversion to FM with approximately double precision accuracy ! is good enough, FMDPM is faster and uses less scratch space. ! This routine assumes the machine's base for double precision is ! a power of two. IMPLICIT NONE ! Scratch array usage during FMDP2M: M01 - M04 ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmdm2, fmntr, fmntrr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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) 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: y, yt INTEGER :: k ! .. ! .. External Subroutines .. EXTERNAL fmdivi, fmdm, fmim, fmntr, fmntrr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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)ndg2mx) THEN kflag = -9 CALL fmwarn kreslt = 12 ndig = ndsave END IF END IF 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) END IF IF (kreslt<=10) CALL fmdivi(mc,2,mc) IF (kreslt>=14) CALL fmdivi(mc,4,mc) CALL fmeq2(mc,mc,ndig,ndsave,1) ndig = ndsave IF (kreslt==9 .OR. kreslt==14) mc(2) = -mc(2) mc(0) = maccab IF (ntrace/=0) CALL fmntr(1,mc,mc,1) kasave = kaccsw mxsave = mxexp ncall = ncall - 1 RETURN END IF ndig = ndsave CALL fmrslt(ma,mb,mc,kreslt) IF (ntrace/=0) CALL fmntr(1,mc,mc,1) kasave = kaccsw mxsave = mxexp ncall = ncall - 1 RETURN END IF 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j ! .. ! .. External Subroutines .. EXTERNAL fmtrap ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. DO 10 j = 0, ndig + 1 mb(j) = ma(j) 10 CONTINUE ! 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 END IF IF (mb(1)==munkno) kflag = -4 END IF RETURN END SUBROUTINE fmeq SUBROUTINE fmeq2(ma,mb,nda,ndb,ksame) ! Set MB (having NDB digits) equal to MA (having NDA digits). ! If MA and MB are the same array, setting KSAME = 1 before calling ! FMEQ2 gives faster performance. ! If MB has less precision than MA the result is rounded to NDB digits. ! If MB has more precision the result has zero digits padded on the ! right. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ksame, nda, ndb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: m2, macca, mb2, mkt INTEGER :: j, jt, k, kb, l, n1, ndg ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmtrap, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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,90000) nda, ndb DO 10 j = 1, ndig + 1 mb(j) = 0 10 CONTINUE mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) ncall = ncall - 1 RETURN END IF ! Check for special symbols. kflag = 0 IF (abs(ma(1))>=mexpov) THEN DO 20 j = 2, ndb mb(j+1) = 0 20 CONTINUE mb(1) = ma(1) mb(2) = ma(2) GO TO 150 END IF IF (ndb==nda) GO TO 100 IF (ndb>nda) GO TO 120 ! Round to NDB digits. ndg = ndb n1 = ndb + 1 IF (ksame/=1) THEN DO 30 j = 1, n1 mb(j) = ma(j) 30 CONTINUE END IF IF (ndg<1 .OR. (kround==0 .AND. ncall<=1)) GO TO 150 l = ndb + 2 IF (2*(ma(l)+1)0) GO TO 60 40 CONTINUE END IF ! Round to even. IF (int(mb(n1)-dint(mb(n1)/m2)*m2)==0) GO TO 150 END IF ELSE IF (2*ma(l)+1==mbase) THEN IF (l<=nda) THEN DO 50 j = l, nda IF (2*(ma(j+1)+1)mbase) GO TO 60 50 CONTINUE GO TO 150 END IF END IF END IF 60 mb(ndg+1) = mb(ndg+1) + 1 mb(ndg+2) = 0 ! Check whether there was a carry in the rounded digit. mb2 = mb(2) mb(2) = abs(mb(2)) kb = ndg + 1 IF (kb>=3) THEN k = kb + 1 DO 70 j = 3, kb k = k - 1 IF (mb(k)=4) THEN k = kb + 1 DO 80 j = 4, kb k = k - 1 mb(k) = mb(k-1) 80 CONTINUE END IF mkt = dint(mb(2)/mbase) IF (kb>=3) mb(3) = mb(2) - mkt*mbase mb(2) = mkt mb(1) = mb(1) + 1 90 IF (mb2<0) mb(2) = -mb(2) GO TO 150 ! MA and MB have the same precision. 100 IF (ksame/=1) THEN DO 110 j = 1, nda + 1 mb(j) = ma(j) 110 CONTINUE END IF GO TO 150 ! Extend to NDB digits by padding with zeros. 120 IF (ksame/=1) THEN DO 130 j = 1, nda + 1 mb(j) = ma(j) 130 CONTINUE END IF DO 140 j = nda + 2, ndb + 1 mb(j) = 0 140 CONTINUE ! 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 END IF IF (mb(1)==munkno) kflag = -4 END IF 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)) END IF ELSE mb(0) = ma(0) END IF RETURN 90000 FORMAT (/' The two precisions in FMEQU were NDA =',I10,' NDB =',I10/) END SUBROUTINE fmeq2 SUBROUTINE fmequ(ma,mb,nda,ndb) ! Set MB (having NDB digits) equal to MA (having NDA digits). ! If MB has less precision than MA, the result is rounded to ! NDB digits. ! If MB has more precision, the result has its precision extended ! by padding with zero digits on the right. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: nda, ndb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmeq2 ! .. CALL fmeq2(ma,mb,nda,ndb,0) RETURN END SUBROUTINE fmequ SUBROUTINE fmexit(mt,mc,ndsave,mxsave,kasave,kovun) ! Upon exit from an FM routine the result MT (having precision NDIG) ! is rounded and returned in MC (having precision NDSAVE). ! The values of NDIG, MXEXP, and KACCSW are restored. ! KOVUN is nonzero if one of the routine's input arguments was overflow ! or underflow. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: mxsave INTEGER :: kasave, kovun, ndsave ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: mc(0:lunpck), mt(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kfsave, kwrnsv ! .. ! .. External Subroutines .. EXTERNAL fmeq2, fmntr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kwrnsv = kwarn kwarn = 0 mxexp = mxsave kfsave = kflag CALL fmeq2(mt,mc,ndig,ndsave,0) IF (kflag/=-5 .AND. kflag/=-6) kflag = kfsave ndig = ndsave kwarn = kwrnsv IF (kflag==1) kflag = 0 IF ((mc(1)==munkno .AND. kflag/=-9) .OR. (mc(1)==mexpun .AND. kovun==0) & .OR. (mc(1)==mexpov .AND. kovun==0)) CALL fmwarn IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 kaccsw = kasave RETURN END SUBROUTINE fmexit SUBROUTINE fmexp(ma,mb) ! MB = EXP(MA) IMPLICIT NONE ! Scratch array usage during FMEXP: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: m1, ma1, ma2, macca, macmax, mxsave REAL :: xma, xov INTEGER :: iextra, j, k, kasave, kovun, kreslt, kt, kwrnsv, ndmb, & ndsave, ndsv, nmethd CHARACTER (155) :: string ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmcsh2, fmdiv, fmentr, fmeq2, fmexit, fmexp2, & fmi2m, fmim, fmint, fmipwr, fmm2i, fmmpy, fmntr, fmrslt, fmsnh2, & fmsqr, fmsqrt, fmst2m, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)==0) THEN CALL fmentr('FMEXP ',ma,ma,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF ma1 = ma(1) ma2 = ma(2) macca = ma(0) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) ! Check for obvious underflow or overflow. ! XOV is LN(LN(slightly above overflow)) ! XMA is LN(LN(EXP(MA))) approximately. xov = log(1.01*real(mxexp)) + log(alogmb) m1 = 1 xma = log(real(max(abs(ma2),m1))) - alogmb + real(ma1)*alogmb 10 IF (xma>=xov) THEN CALL fmim(0,mb) IF (ma2>0) THEN kflag = -5 mb(1) = mexpov mb(2) = 1 mb(0) = nint(ndig*alogm2) ELSE kflag = -6 mb(1) = mexpun mb(2) = 1 mb(0) = nint(ndig*alogm2) END IF ndig = ndsave mxexp = mxsave kaccsw = kasave CALL fmwarn IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF ! Split MA into integer and fraction parts. ! Work with a positive argument. ! M02 = integer part of ABS(MA) ! MB = fraction part of ABS(MA) mb(2) = abs(mb(2)) CALL fmint(mb,m02) CALL fmsub(mb,m02,mb) ! If the integer part is not zero, use FMIPWR to compute ! E**(M02). If M02 is too large to represent as a one word ! integer, the definition of MXEXP insures that E**(M02) ! overflows or underflows. kwrnsv = kwarn kwarn = 0 CALL fmm2i(m02,kt) kwarn = kwrnsv IF (kflag/=0) THEN xma = xov GO TO 10 END IF IF (kt>0) THEN ! Compute IEXTRA, the number of extra digits required ! to get EXP(KT) correct to the current precision. iextra = int(log(real(kt))/alogmb+0.5) IF (iextra>0 .AND. ndig+iextra<=ndg2mx) THEN CALL fmeq2(mb,mb,ndig,ndig+iextra,1) END IF ndig = ndig + iextra IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 20 j = 2, ndsave mb(j+1) = 0 20 CONTINUE ndig = ndig - iextra CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END IF ! Check whether the current precision of e is large ! enough. IF (mbse/=mbase .OR. ndig>ndige) THEN ndmb = int(150.0*2.302585/alogmb) IF (ndmb>=ndig) THEN ndsv = ndig ndig = min(ndmb,ndg2mx) string = '2.718281828459045235360287471352662497757247' // & '09369995957496696762772407663035354759457138217852516' // & '6427427466391932003059921817413596629043572900334295261' CALL fmst2m(string,mesav) mesav(0) = nint(ndig*alogm2) mbse = mbase ndige = ndig IF (abs(mesav(1))>10) ndige = 0 ndig = ndsv ELSE ndsv = ndig ndig = min(ndig+2,ndg2mx) CALL fmi2m(1,mesav) CALL fmexp2(mesav,mesav) mesav(0) = nint(ndig*alogm2) mbse = mbase ndige = ndig IF (abs(mesav(1))>10) ndige = 0 ndig = ndsv END IF END IF END IF ! Now do the fraction part of MA and combine the results. kwrnsv = kwarn kwarn = 0 nmethd = 1 IF (ndig>50) nmethd = 2 IF (mb(2)/=0 .AND. kt>0 .AND. nmethd==1) THEN CALL fmexp2(mb,mb) CALL fmipwr(mesav,kt,m03) CALL fmmpy(mb,m03,mb) ELSE IF (mb(2)/=0 .AND. kt==0 .AND. nmethd==1) THEN CALL fmexp2(mb,mb) ELSE IF (mb(2)/=0 .AND. kt>0 .AND. nmethd==2) THEN ndsv = ndig ndig = min(ndig+ngrd21,ndg2mx) CALL fmeq2(mb,mb,ndsv,ndig,1) IF (mb(1)>=0) THEN CALL fmcsh2(mb,mb) CALL fmsqr(mb,m03) CALL fmi2m(-1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,m03) CALL fmadd(mb,m03,mb) ELSE CALL fmsnh2(mb,mb) CALL fmsqr(mb,m03) CALL fmi2m(1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,m03) CALL fmadd(mb,m03,mb) END IF ndig = ndsv CALL fmipwr(mesav,kt,m03) CALL fmmpy(mb,m03,mb) ELSE IF (mb(2)/=0 .AND. kt==0 .AND. nmethd==2) THEN ndsv = ndig ndig = min(ndig+ngrd21,ndg2mx) CALL fmeq2(mb,mb,ndsv,ndig,1) IF (mb(1)>=0) THEN CALL fmcsh2(mb,mb) CALL fmsqr(mb,m03) CALL fmi2m(-1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,m03) CALL fmadd(mb,m03,mb) ELSE CALL fmsnh2(mb,mb) CALL fmsqr(mb,m03) CALL fmi2m(1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,m03) CALL fmadd(mb,m03,mb) END IF ndig = ndsv ELSE IF (mb(2)==0 .AND. kt>0) THEN CALL fmipwr(mesav,kt,mb) ELSE CALL fmi2m(1,mb) END IF ! Invert if MA was negative. IF (ma2<0) THEN CALL fmi2m(1,m02) CALL fmdiv(m02,mb,mb) END IF kwarn = kwrnsv ! Round the result and return. macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmexp SUBROUTINE fmexp2(ma,mb) ! MB = EXP(MA) ! Internal exponential routine (called with 0.LT.MA.LE.1). IMPLICIT NONE ! Scratch array usage during FMEXP2: M01 - M03 ! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent ! sums. Increasing this value will begin to improve the ! speed of EXP when the base is large and precision exceeds ! about 1,500 decimal digits. ! .. Intrinsic Functions .. INTRINSIC int, log, max, min, nint, real, sqrt ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL :: alog2, alogt, b, t, tj, xn REAL (KIND(0.0D0)) :: maxval INTEGER :: j, j2, k, k2, kpt, ktwo, l, l2, n2, nbig, nbot, ndsav1, & ndsave, nterm, ntop ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdivi, fmeq, fmeq2, fmi2m, fmipwr, fmmpy, & fmmpyi, fmsqr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mjsums(0:ljsums), & mlbsav(0:lunpck), mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), & mln4(0:lunpck), mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmsums/mjsums COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons ndsave = ndig IF (ma(1)==1) THEN ! Here the special case EXP(1.0) is computed. ! Use the direct series e = 1/0! + 1/1! + 1/2! + ... ! Do as much of the work as possible using small integers ! to minimize the number of FM calls. ! Reduce NDIG while computing each term in the ! sum as the terms get smaller. t = ndig xn = t*alogmb/log(t) k = int(log(xn)/alogmb) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mb(j+1) = 0 10 CONTINUE ndig = ndsave RETURN END IF ndsav1 = ndig CALL fmi2m(2,mb) CALL fmi2m(1,m02) j = 2 nbig = int(mxbase) 20 ntop = 1 nbot = j 30 IF (nbot>nbig/(j+1)) GO TO 40 j = j + 1 ntop = j*ntop + 1 nbot = j*nbot GO TO 30 40 CALL fmdivi(m02,nbot,m02) IF (ntop>1) THEN CALL fmmpyi(m02,ntop,m03) ndig = ndsav1 CALL fmadd(mb,m03,mb) ndig = ndsav1 - int(mb(1)-m03(1)) ELSE ndig = ndsav1 CALL fmadd(mb,m02,mb) ndig = ndsav1 - int(mb(1)-m02(1)) END IF IF (ndig<2) ndig = 2 IF (kflag/=1) THEN j = j + 1 GO TO 20 END IF ndig = ndsave CALL fmi2m(-1,m02) CALL fmadd(mb,m02,m03) kflag = 0 RETURN END IF ! Here is the general case. Compute EXP(MA) where ! 0 .LT. MA .LT. 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) END IF IF (j2<=1) j2 = 1 n2 = int(t*alogmb/(alogt+real(l)*alog2)) l2 = int(log(real(n2)+2.0**k2)/alogmb) ndig = ndig + l2 IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 50 j = 2, ndsave mb(j+1) = 0 50 CONTINUE ndig = ndsave RETURN END IF ndsav1 = ndig ! Halve the argument K2 times. CALL fmeq2(ma,m02,ndsave,ndig,0) ktwo = 1 maxval = mxbase/2 IF (k2>0) THEN DO 60 j = 1, k2 ktwo = 2*ktwo IF (ktwo>maxval) THEN CALL fmdivi(m02,ktwo,m02) ktwo = 1 END IF 60 CONTINUE IF (ktwo>1) CALL fmdivi(m02,ktwo,m02) END IF ! 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 70 j = 1, j2 CALL fmdivi(mb,nterm,mb) nterm = nterm + 1 kpt = (j-1)*(ndig+2) CALL fmeq(mb,mjsums(kpt)) 70 CONTINUE IF (m02(1)<-ndig) GO TO 100 CALL fmipwr(m02,j2,m03) 80 CALL fmmpy(mb,m03,mb) DO 90 j = 1, j2 CALL fmdivi(mb,nterm,mb) kpt = (j-1)*(ndsav1+2) ndig = ndsav1 CALL fmadd(mjsums(kpt),mb,mjsums(kpt)) IF (kflag/=0) GO TO 100 ndig = ndsav1 - int(mjsums(kpt+1)-mb(1)) IF (ndig<2) ndig = 2 nterm = nterm + 1 90 CONTINUE GO TO 80 ! Put the J2 separate sums back together. 100 kflag = 0 kpt = (j2-1)*(ndig+2) CALL fmeq(mjsums(kpt),m03) IF (j2>=2) THEN DO 110 j = 2, j2 CALL fmmpy(m02,m03,m03) kpt = (j2-j)*(ndig+2) CALL fmadd(m03,mjsums(kpt),m03) 110 CONTINUE END IF ! 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 120 j = 1, k2 CALL fmadd(m03,m02,mb) CALL fmmpy(mb,m03,m03) 120 CONTINUE ELSE DO 130 j = 1, k2 CALL fmsqr(m03,mb) CALL fmadd(m03,m03,m02) CALL fmadd(mb,m02,m03) 130 CONTINUE END IF END IF CALL fmi2m(1,m02) CALL fmadd(m02,m03,mb) CALL fmeq2(mb,mb,ndsav1,ndsave,1) ndig = ndsave RETURN END SUBROUTINE fmexp2 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. IMPLICIT NONE ! Scratch array usage during FMFORM: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC abs, index, int, len, log10, max, min, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: form, string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, jf1sav, jf2sav, jpt, k1, k2, k3, kd, ksave, kwd, kwi, & last, lb, lengfm, lengst, lfirst, nd, nexp CHARACTER (20) :: formb ! .. ! .. External Subroutines .. EXTERNAL fmnint, fmout ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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,90000) k2 - k1 + 1 IF (k2>=k1) THEN READ (form(k1:k2),formb) kwi ELSE kwi = lengst END IF kwi = max(1,min(kwi,lengst)) jform1 = 2 jform2 = 0 kwd = kwi + 21 IF (kwd>lmbuff) GO TO 140 CALL fmnint(ma,m02) IF (m02(2)/=0) THEN CALL fmout(m02,cmbuff,kwd) ELSE DO 10 j = 1, kwd cmbuff(j) = ' ' 10 CONTINUE cmbuff(2) = '0' END IF lfirst = 1 last = 1 DO 20 j = 1, kwd IF (cmbuff(kwd+1-j)/=' ') lfirst = kwd + 1 - j IF (cmbuff(j)/=' ') last = j 20 CONTINUE jpt = 1 IF (last-lfirst+1>kwi) GO TO 140 IF (last<=kwi) THEN DO 30 j = last, lfirst, -1 jpt = kwi - last + j string(jpt:jpt) = cmbuff(j) 30 CONTINUE DO 40 j = 1, jpt - 1 string(j:j) = ' ' 40 CONTINUE ELSE DO 50 j = lfirst, last jpt = kwi - last + j string(jpt:jpt) = cmbuff(j) 50 CONTINUE END IF 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,90000) k2 - k1 READ (form(k1:k2-1),formb) kwi ELSE kwi = 50 END IF IF (k3>k2) THEN WRITE (formb,90000) k3 - k2 READ (form(k2+1:k3),formb) kd ELSE kd = 0 END IF 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 60 j = 1, kwd IF (cmbuff(kwd+1-j)/=' ') lfirst = kwd + 1 - j IF (cmbuff(j)/=' ') last = j 60 CONTINUE 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 140 ELSE jform1 = 0 jform2 = nd CALL fmout(ma,cmbuff,kwi) lfirst = 1 last = 1 DO 70 j = 1, kwi IF (cmbuff(kwi+1-j)/=' ') lfirst = kwi + 1 - j IF (cmbuff(j)/=' ') last = j 70 CONTINUE END IF END IF jpt = 1 IF (last<=kwi) THEN DO 80 j = last, lfirst, -1 jpt = kwi - last + j string(jpt:jpt) = cmbuff(j) 80 CONTINUE DO 90 j = 1, jpt - 1 string(j:j) = ' ' 90 CONTINUE ELSE DO 100 j = lfirst, last jpt = kwi - last + j string(jpt:jpt) = cmbuff(j) 100 CONTINUE END IF 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,90000) k2 - k1 READ (form(k1:k2-1),formb) kwi ELSE kwi = 50 END IF IF (k3>k2) THEN WRITE (formb,90000) k3 - k2 READ (form(k2+1:k3),formb) kd ELSE kd = 0 END IF kwi = max(1,min(kwi,lengst)) kd = max(0,min(kd,kwi-2)) jform1 = 1 jform2 = kd IF (kwi>lmbuff) GO TO 140 CALL fmout(ma,cmbuff,kwi) DO 110 j = kwi, 1, -1 IF (j>lengst) THEN IF (cmbuff(j)/=' ') GO TO 140 ELSE string(j:j) = cmbuff(j) END IF 110 CONTINUE 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,90000) k2 - k1 READ (form(k1:k2-1),formb) kwi ELSE kwi = 50 END IF IF (k3>k2) THEN WRITE (formb,90000) k3 - k2 READ (form(k2+1:k3),formb) kd ELSE kd = 0 END IF kwi = max(1,min(kwi,lengst)) kd = max(0,min(kd,kwi-2)) jform1 = 0 jform2 = kd IF (kwi>lmbuff) GO TO 140 CALL fmout(ma,cmbuff,kwi) DO 120 j = kwi, 1, -1 IF (j>lengst) THEN IF (cmbuff(j)/=' ') GO TO 140 ELSE string(j:j) = cmbuff(j) END IF 120 CONTINUE ELSE GO TO 140 END IF 130 kflag = ksave jform1 = jf1sav jform2 = jf2sav ncall = ncall - 1 RETURN ! Error condition. 140 kflag = -8 DO 150 j = 1, lengst string(j:j) = '*' 150 CONTINUE GO TO 130 90000 FORMAT ('(I',I5,')') 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. IMPLICIT NONE ! Scratch array usage during FMFPRT: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC abs, index, int, len, log10, max, min, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: form ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, jf1sav, jf2sav, jpt, k, k1, k2, k3, kd, ksave, kwd, kwi, & last, lb, lengfm, lfirst, nd, nexp CHARACTER (20) :: form2, formb ! .. ! .. External Subroutines .. EXTERNAL fmnint, fmout ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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,90000) k2 - k1 + 1 IF (k2>=k1) THEN READ (form(k1:k2),formb) kwi ELSE kwi = 50 END IF 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 10 j = 1, kwd cmbuff(j) = ' ' 10 CONTINUE cmbuff(2) = '0' END IF lfirst = 1 last = 1 DO 20 j = 1, kwd IF (cmbuff(kwd+1-j)/=' ') lfirst = kwd + 1 - j IF (cmbuff(j)/=' ') last = j 20 CONTINUE jpt = 1 IF (last-lfirst+1>kwi) GO TO 130 IF (last<=kwi) THEN DO 30 j = last, lfirst, -1 jpt = kwi - last + j IF (jpt/=j) cmbuff(jpt) = cmbuff(j) 30 CONTINUE DO 40 j = 1, jpt - 1 cmbuff(j) = ' ' 40 CONTINUE ELSE DO 50 j = lfirst, last jpt = kwi - last + j IF (jpt/=j) cmbuff(jpt) = cmbuff(j) 50 CONTINUE END IF 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,90000) k2 - k1 READ (form(k1:k2-1),formb) kwi ELSE kwi = 50 END IF IF (k3>k2) THEN WRITE (formb,90000) k3 - k2 READ (form(k2+1:k3),formb) kd ELSE kd = 0 END IF 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 60 j = 1, kwd IF (cmbuff(kwd+1-j)/=' ') lfirst = kwd + 1 - j IF (cmbuff(j)/=' ') last = j 60 CONTINUE 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 130 ELSE jform1 = 0 jform2 = nd CALL fmout(ma,cmbuff,kwi) lfirst = 1 last = 1 DO 70 j = 1, kwi IF (cmbuff(kwi+1-j)/=' ') lfirst = kwi + 1 - j IF (cmbuff(j)/=' ') last = j 70 CONTINUE END IF END IF jpt = 1 IF (last<=kwi) THEN DO 80 j = last, lfirst, -1 jpt = kwi - last + j IF (jpt/=j) cmbuff(jpt) = cmbuff(j) 80 CONTINUE DO 90 j = 1, jpt - 1 cmbuff(j) = ' ' 90 CONTINUE ELSE DO 100 j = lfirst, last jpt = kwi - last + j IF (jpt/=j) cmbuff(jpt) = cmbuff(j) 100 CONTINUE END IF 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,90000) k2 - k1 READ (form(k1:k2-1),formb) kwi ELSE kwi = 50 END IF IF (k3>k2) THEN WRITE (formb,90000) k3 - k2 READ (form(k2+1:k3),formb) kd ELSE kd = 0 END IF 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,90000) k2 - k1 READ (form(k1:k2-1),formb) kwi ELSE kwi = 50 END IF IF (k3>k2) THEN WRITE (formb,90000) k3 - k2 READ (form(k2+1:k3),formb) kd ELSE kd = 0 END IF 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 130 END IF 110 last = kwi + 1 WRITE (form2,90010) kswide - 7 IF (kflag/=-8) kflag = ksave jform1 = jf1sav jform2 = jf2sav DO 120 j = kwi, 1, -1 IF (cmbuff(j)/=' ' .OR. j==1) THEN WRITE (kw,form2) (cmbuff(k),k=1,j) ncall = ncall - 1 RETURN END IF 120 CONTINUE ncall = ncall - 1 RETURN ! Error condition. 130 kflag = -8 DO 140 j = 1, kwi cmbuff(j) = '*' 140 CONTINUE GO TO 110 90000 FORMAT ('(I',I5,')') 90010 FORMAT (' (6X,',I3,'A1) ') 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. ! .. Intrinsic Functions .. INTRINSIC max, min, mod ! .. ! .. Scalar Arguments .. INTEGER :: n1, n2 ! .. ! .. Local Scalars .. INTEGER :: k1, k2, k3 ! .. k1 = max(n1,n2) k2 = min(n1,n2) 10 k3 = mod(k1,k2) IF (k3==0) THEN n1 = n1/k2 n2 = n2/k2 RETURN ELSE k1 = k2 k2 = k3 GO TO 10 END IF END SUBROUTINE fmgcdi 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. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmim, fmntr, fmntri ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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) ELSE CALL fmim(ival,ma) END IF 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mk, ml, mval REAL (KIND(0.0D0)) :: x INTEGER :: j, jm2, kb, kb1, n1, nmval, nv2 ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmdm, fmims ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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 50 END IF ! Check for small IVAL. IF (mval0) THEN mval = mk j = j - 1 IF (j>=2) GO TO 20 ! Here IVAL cannot be expressed exactly. x = ival CALL fmdm(x,ma) RETURN END IF ! Normalize MA. kb = n1 - j + 2 jm2 = j - 2 DO 30 j = 2, kb ma(j) = ma(j+jm2) 30 CONTINUE kb1 = kb + 1 IF (kb1<=n1) THEN DO 40 j = kb1, n1 ma(j) = 0 40 CONTINUE END IF IF (ival<0) ma(2) = -ma(2) 50 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ml REAL (KIND(0.0D0)) :: x INTEGER :: j, jm2, kb, kb1, kbase, kmk, kval, n1 ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmdm ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons kflag = 0 n1 = ndig + 1 ! Check for small IVAL. kval = abs(ival) kbase = int(mbase) IF (kval0) THEN kval = kmk j = j - 1 IF (j>=2) GO TO 20 ! Here IVAL cannot be expressed exactly. x = ival CALL fmdm(x,ma) RETURN END IF ! Normalize MA. kb = n1 - j + 2 jm2 = j - 2 DO 30 j = 2, kb ma(j) = ma(j+jm2) 30 CONTINUE kb1 = kb + 1 IF (kb1<=n1) THEN DO 40 j = kb1, n1 ma(j) = 0 40 CONTINUE END IF IF (ival<0) ma(2) = -ma(2) 50 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. IMPLICIT NONE ! 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 DATA statement note the array is loaded by columns. ! State 1 2 3 4 5 6 7 8 ! Type ! .. Intrinsic Functions .. INTRINSIC abs, dble, ichar, int, log10, max, min, mod, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: la, lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) CHARACTER (1) :: line(lb) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: m2, mndsv1 INTEGER :: j, jstate, k, k10pwr, kasave, kdflag, kexp, kf1, kf2, kmn, & kof, kpower, kpt, krsave, ksign, ksignx, kstart, kstop, ktenex, & ktenf1, ktenf2, ktype, kuf, kuk, kval, kwrnsv, large, n2, ndsav1, & ndsave ! .. ! .. Local Arrays .. REAL (KIND(0.0D0)) :: mlv2(0:lunpck), mlv3(0:lunpck), mlv4(0:lunpck), & mlv5(0:lunpck) INTEGER :: jtrans(8,4) CHARACTER (1) :: kovfl(4), kunfl(4), kunkn(4), lovfl(4), lunfl(4), & lunkn(4) ! .. ! .. External Subroutines .. EXTERNAL fmadd2, fmcons, fmdiv2, fmeq, fmeq2, fmim, fminp2, fmmi, & fmmpy2, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! .. Data Statements .. DATA jtrans/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/ DATA kovfl/'O', 'V', 'F', 'L'/, kunfl/'U', 'N', 'F', 'L'/, kunkn/'U', & 'N', 'K', 'N'/ DATA lovfl/'o', 'v', 'f', 'l'/, lunfl/'u', 'n', 'f', 'l'/, lunkn/'u', & 'n', 'k', 'n'/ ! .. ! 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 ! Check for special symbols. kmn = 1 kof = 1 kuf = 1 kuk = 1 DO 10 j = la, lb kpt = ichar(line(j)) IF (kpt>=lhash1 .AND. kpt<=lhash2) THEN ktype = khasht(kpt) IF (ktype==2) GO TO 20 END IF IF (line(j)=='-') kmn = -1 IF (line(j)==kovfl(kof) .OR. line(j)==lovfl(kof)) THEN kof = kof + 1 IF (kof==5) THEN CALL fmim(0,ma) ma(1) = mexpov ma(2) = kmn ma(0) = nint(ndig*alogm2) GO TO 140 END IF END IF IF (line(j)==kunfl(kuf) .OR. line(j)==lunfl(kof)) THEN kuf = kuf + 1 IF (kuf==5) THEN CALL fmim(0,ma) ma(1) = mexpun ma(2) = kmn ma(0) = nint(ndig*alogm2) GO TO 140 END IF END IF 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 140 END IF END IF 10 CONTINUE ! Increase the working precision. 20 IF (ncall<=2) THEN k = ngrd52 ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 ncall = ncall - 1 CALL fmwarn ncall = ncall + 1 ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) DO 30 j = 2, ndsave ma(j+1) = 0 30 CONTINUE GO TO 140 END IF END IF ndsav1 = ndig m2 = 2 mndsv1 = ndsav1 kstart = la kstop = lb jstate = 1 ksign = 1 CALL fmim(0,mlv2) CALL fmim(0,mlv3) CALL fmim(0,mlv4) CALL fmim(0,mlv5) ! If MBASE is a power of ten then call FMINP2 for ! faster input conversion. kpower = int(log10(dble(mbase))+0.5D0) IF (mbase==10**kpower) THEN CALL fminp2(ma,line,kstart,kstop,jtrans,kpower,mlv3,mlv4,mlv5) GO TO 130 END IF 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 100 j = kstart, kstop IF (line(j)==' ') GO TO 100 kpt = ichar(line(j)) IF (kptlhash2) THEN WRITE (kw,90000) line(j), kpt, lhash1, lhash2 ktype = 5 kval = 0 ELSE ktype = khasht(kpt) kval = khashv(kpt) END IF IF (ktype>=5) GO TO 150 jstate = jtrans(jstate,ktype) GO TO (150,40,50,100,60,70,80,90,150) jstate ! State 2. Sign of the number. 40 ksign = kval GO TO 100 ! State 3. Digits before a decimal point. 50 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 END IF IF (mlv3(2)==0) THEN CALL fmim(kf1,mlv3) ELSE ndig = int(max(m2,min(mlv3(1)+ma(1),mndsv1))) CALL fmmpy2(mlv3,ma,mlv3) ndig = ndsav1 CALL fmim(kf1,mlv2) ndig = int(max(m2,min(max(mlv3(1),mlv2(1))+1,mndsv1))) IF (kf1/=0) CALL fmadd2(mlv3,mlv2,mlv3) ndig = ndsav1 END IF kf1 = 0 ktenf1 = 1 END IF GO TO 100 ! State 5. Digits after a decimal point. 60 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 END IF IF (mlv4(2)==0) THEN CALL fmim(kf2,mlv4) ELSE ndig = int(max(m2,min(mlv4(1)+ma(1),mndsv1))) CALL fmmpy2(mlv4,ma,mlv4) ndig = ndsav1 CALL fmim(kf2,mlv2) ndig = int(max(m2,min(max(mlv4(1),mlv2(1))+1,mndsv1))) IF (kf2/=0) CALL fmadd2(mlv4,mlv2,mlv4) ndig = ndsav1 END IF kf2 = 0 ktenf2 = 1 END IF GO TO 100 ! State 6. Precision indicator. 70 IF (kdflag==0 .AND. keswch==1) CALL fmim(1,mlv3) GO TO 100 ! State 7. Sign of the exponent. 80 ksignx = kval GO TO 100 ! State 8. Digits of the exponent. 90 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 END IF IF (mlv5(2)==0) THEN CALL fmim(kexp,mlv5) ELSE ndig = int(max(m2,min(mlv5(1)+ma(1),mndsv1))) CALL fmmpy2(mlv5,ma,mlv5) ndig = ndsav1 CALL fmim(kexp,mlv2) ndig = int(max(m2,min(max(mlv5(1),mlv2(1))+1,mndsv1))) IF (kexp/=0) CALL fmadd2(mlv5,mlv2,mlv5) ndig = ndsav1 END IF kexp = 0 ktenex = 1 END IF 100 CONTINUE ! 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 END IF IF (mlv3(2)==0) THEN CALL fmim(kf1,mlv3) ELSE ndig = int(max(m2,min(mlv3(1)+ma(1),mndsv1))) CALL fmmpy2(mlv3,ma,mlv3) ndig = ndsav1 CALL fmim(kf1,mlv2) ndig = int(max(m2,min(max(mlv3(1),mlv2(1))+1,mndsv1))) IF (kf1/=0) CALL fmadd2(mlv3,mlv2,mlv3) ndig = ndsav1 END IF END IF IF (ktenf2>1) THEN IF (ktenf2/=k10pwr .AND. mlv4(2)/=0) THEN CALL fmim(ktenf2,ma) k10pwr = ktenf2 END IF IF (mlv4(2)==0) THEN CALL fmim(kf2,mlv4) ELSE ndig = int(max(m2,min(mlv4(1)+ma(1),mndsv1))) CALL fmmpy2(mlv4,ma,mlv4) ndig = ndsav1 CALL fmim(kf2,mlv2) ndig = int(max(m2,min(max(mlv4(1),mlv2(1))+1,mndsv1))) IF (kf2/=0) CALL fmadd2(mlv4,mlv2,mlv4) ndig = ndsav1 END IF END IF IF (ktenex>1) THEN IF (ktenex/=k10pwr .AND. mlv5(2)/=0) THEN CALL fmim(ktenex,ma) k10pwr = ktenex END IF IF (mlv5(2)==0) THEN CALL fmim(kexp,mlv5) ELSE ndig = int(max(m2,min(mlv5(1)+ma(1),mndsv1))) CALL fmmpy2(mlv5,ma,mlv5) ndig = ndsav1 CALL fmim(kexp,mlv2) ndig = int(max(m2,min(max(mlv5(1),mlv2(1))+1,mndsv1))) IF (kexp/=0) CALL fmadd2(mlv5,mlv2,mlv5) ndig = ndsav1 END IF END IF IF (ksignx==-1) mlv5(2) = -mlv5(2) IF (mlv4(2)/=0) THEN CALL fmim(10,mlv2) k = n2 IF (mod(k,2)==0) THEN CALL fmim(1,ma) ELSE CALL fmeq(mlv2,ma) END IF 110 k = k/2 ndig = int(max(m2,min(2*mlv2(1),mndsv1))) CALL fmmpy2(mlv2,mlv2,mlv2) IF (mod(k,2)==1) THEN ndig = int(max(m2,min(mlv2(1)+ma(1),mndsv1))) CALL fmmpy2(mlv2,ma,ma) END IF IF (k>1) GO TO 110 ndig = ndsav1 CALL fmdiv2(mlv4,ma,mlv4) END IF IF (mlv5(2)/=0) THEN CALL fmim(10,mlv2) kwrnsv = kwarn kwarn = 0 CALL fmmi(mlv5,kexp) kwarn = kwrnsv IF (kflag/=0) GO TO 150 k = abs(kexp) IF (mod(k,2)==0) THEN CALL fmim(1,mlv5) ELSE CALL fmeq(mlv2,mlv5) END IF 120 k = k/2 ndig = int(max(m2,min(2*mlv2(1),mndsv1))) CALL fmmpy2(mlv2,mlv2,mlv2) IF (mod(k,2)==1) THEN ndig = int(max(m2,min(mlv2(1)+mlv5(1),mndsv1))) CALL fmmpy2(mlv2,mlv5,mlv5) END IF IF (k>1) GO TO 120 ndig = ndsav1 IF (kexp<0) THEN CALL fmim(1,mlv2) CALL fmdiv2(mlv2,mlv5,mlv5) END IF END IF CALL fmadd2(mlv3,mlv4,ma) IF (mlv5(2)/=0) CALL fmmpy2(ma,mlv5,ma) IF (ksign==-1) ma(2) = -ma(2) 130 CALL fmeq2(ma,ma,ndig,ndsave,1) IF (ma(1)==munkno) GO TO 150 140 ndig = ndsave kaccsw = kasave kround = krsave IF (kflag==1) kflag = 0 ma(0) = nint(ndig*alogm2) ncall = ncall - 2 RETURN ! Error in converting the number. 150 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 140 90000 FORMAT (/' Error in input conversion.'/ & ' ICHAR function was out of range for the current', & ' dimensions.'/' ICHAR(''',A,''') gave the value ',I12, & ', which is outside the currently'/' dimensioned',' bounds of (',I5, & ':',I5,') for variables KHASHT ','and KHASHV.'/ & ' Re-define the two parameters ', & 'LHASH1 and LHASH2 so the dimensions will'/' contain', & ' all possible output values from ICHAR.'//) END SUBROUTINE fminp SUBROUTINE fminp2(ma,line,kstart,kstop,jtrans,kpower,mlv3,mlv4,mlv5) ! Internal routine for input conversion for a power of ten MBASE. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC ichar, int, mod, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kpower, kstart, kstop ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mlv3(0:lunpck), mlv4(0:lunpck), mlv5(0:lunpck) INTEGER :: jtrans(8,4) CHARACTER (1) :: line(kstop) ! .. ! .. Local Scalars .. INTEGER :: j, jstate, kdflag, kexp, kf1, kf1dig, kf2, kf2dig, kf2pt, & knzdig, kpt, kshift, ksign, ksignx, ktype, kval, large ! .. ! .. External Subroutines .. EXTERNAL fmadd2, fmdivn, fmim, fmmpy2, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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 70 j = kstart, kstop IF (line(j)==' ') GO TO 70 kpt = ichar(line(j)) IF (kptlhash2) THEN WRITE (kw,90000) line(j), kpt, lhash1, lhash2 ktype = 5 kval = 0 ELSE ktype = khasht(kpt) kval = khashv(kpt) END IF IF (ktype>=5) GO TO 80 jstate = jtrans(jstate,ktype) GO TO (80,10,20,70,30,40,50,60,80) jstate ! State 2. Sign of the number. 10 ksign = kval GO TO 70 ! State 3. Digits before a decimal point. 20 kdflag = 1 kf1 = 10*kf1 + kval IF (kval>0 .OR. knzdig/=0) THEN knzdig = 1 kf1dig = kf1dig + 1 END IF IF (kf1dig==kpower) THEN mlv3(1) = mlv3(1) + 1 IF (mlv3(1)ndig+1) GO TO 70 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 END IF kf2 = 0 kf2dig = 0 END IF GO TO 70 ! State 6. Precision indicator. 40 IF (kdflag==0 .AND. keswch==1) CALL fmim(1,mlv3) GO TO 70 ! State 7. Sign of the exponent. 50 ksignx = kval GO TO 70 ! State 8. Digits of the exponent. 60 IF (kexp>=large) THEN IF (mlv3(2)==0 .AND. mlv4(2)==0) THEN CALL fmim(0,ma) RETURN END IF CALL fmim(0,ma) IF (ksignx==1) THEN ma(1) = mexpov kflag = -4 ELSE ma(1) = mexpun kflag = -4 END IF ma(2) = ksign ma(0) = nint(ndig*alogm2) ncall = ncall - 1 CALL fmwarn ncall = ncall + 1 RETURN END IF kexp = 10*kexp + kval 70 CONTINUE ! 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)1) THEN CALL fmdivn(mlv3,kshift,mlv3) END IF END IF IF (kf2dig/=0) THEN kshift = 10**(kpower-kf2dig) mlv4(kf2pt) = kf2*kshift END IF 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 END IF END IF END IF CALL fmadd2(mlv3,mlv4,ma) IF (kexp>0) CALL fmmpy2(ma,mlv5,ma) ma(2) = ksign*ma(2) RETURN ! Error in converting the number. 80 CALL fmim(0,ma) ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) RETURN 90000 FORMAT (/' Error in input conversion.'/ & ' ICHAR function was out of range for the current', & ' dimensions.'/' ICHAR(''',A,''') gave the value ',I12, & ', which is outside the currently'/' dimensioned',' bounds of (',I5, & ':',I5,') for variables KHASHT ','and KHASHV.'/ & ' Re-define the two parameters ', & 'LHASH1 and LHASH2 so the dimensions will'/' contain', & ' all possible output values from ICHAR.'//) 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, macmax INTEGER :: j, ka, kb, kreslt, n1 ! .. ! .. External Subroutines .. EXTERNAL fmargs, fmcons, fmntr, fmrslt ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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) 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) ncall = ncall - 1 RETURN END IF END IF n1 = ndig + 1 ! If MA is less than one in magnitude, return zero. IF (ma(1)<=0) THEN DO 10 j = 1, n1 mb(j) = 0 10 CONTINUE GO TO 50 END IF ! 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 20 j = 1, n1 mb(j) = ma(j) 20 CONTINUE GO TO 50 END IF ! 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 30 j = 1, kb mb(j) = ma(j) 30 CONTINUE DO 40 j = ka, n1 mb(j) = 0 40 CONTINUE 50 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 END IF IF (ntrace/=0) CALL fmntr(1,mb,mb,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. IMPLICIT NONE ! Scratch array usage during FMIPWR: M01 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, mod, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, macmax REAL :: xval INTEGER :: j, jsign, k, kwrnsv, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmdiv, fmeq, fmeq2, fmi2m, fmim, fmmpy, fmntr, fmntri, & fmsqr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons kflag = 0 ncall = ncall + 1 namest(ncall) = 'FMIPWR' IF (ntrace/=0) THEN CALL fmntr(2,ma,ma,1) CALL fmntri(2,ival,0) END IF ! Check for special cases. IF (ma(1)==munkno .OR. (ival<=0 .AND. ma(2)==0)) THEN ma2 = ma(2) CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -4 IF (ival<=0 .AND. ma2==0) CALL fmwarn IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF IF (ival==0) THEN CALL fmim(1,mb) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF 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) END IF IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 kwarn = kwrnsv RETURN END IF IF (ma(2)==0) THEN CALL fmeq(ma,mb) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF IF (ma(1)==mexpov) THEN jsign = 1 IF (ma(2)<0) jsign = -1 CALL fmim(0,mb) IF (ival>0) THEN mb(1) = mexpov mb(2) = jsign**mod(ival,2) mb(0) = nint(ndig*alogm2) kflag = -5 ELSE mb(1) = mexpun mb(2) = jsign**mod(ival,2) mb(0) = nint(ndig*alogm2) kflag = -6 END IF IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF IF (ma(1)==mexpun) THEN jsign = 1 IF (ma(2)<0) jsign = -1 CALL fmim(0,mb) IF (ival>0) THEN mb(1) = mexpun mb(2) = jsign**mod(ival,2) mb(0) = nint(ndig*alogm2) kflag = -6 ELSE mb(1) = mexpov mb(2) = jsign**mod(ival,2) mb(0) = nint(ndig*alogm2) kflag = -5 END IF IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF ! 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) ELSE xval = abs(ival) IF (xval>10.0 .OR. real(mbase)<=999.0) THEN k = int(log(xval)/alogmb+1.0) ndig = ndig + k END IF END IF IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mb(j+1) = 0 10 CONTINUE ndig = ndsave IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF ! Initialize. kwrnsv = kwarn kwarn = 0 k = abs(ival) macca = ma(0) CALL fmeq2(ma,m01,ndsave,ndig,0) m01(0) = nint(ndig*alogm2) IF (mod(k,2)==0) THEN CALL fmi2m(1,mb) ELSE CALL fmeq(m01,mb) END IF ! This is the multiplication loop. 20 k = k/2 CALL fmsqr(m01,m01) IF (mod(k,2)==1) CALL fmmpy(m01,mb,mb) IF (k>1) GO TO 20 ! Invert if the exponent is negative. IF (ival<0) THEN CALL fmi2m(1,m01) CALL fmdiv(m01,mb,mb) END IF kwarn = kwrnsv ! Round the result and return. CALL fmeq2(mb,mb,ndig,ndsave,1) ndig = ndsave IF (kaccsw==1) THEN macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) ELSE mb(0) = macca END IF IF (kflag<0) CALL fmwarn IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END SUBROUTINE fmipwr SUBROUTINE fmlg10(ma,mb) ! MB = LOG10(MA) IMPLICIT NONE ! Scratch array usage during FMLG10: M01 - M05 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, macmax, mxsave INTEGER :: k, kasave, kovun, kreslt, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdiv, fmentr, fmeq2, fmexit, fmln, fmlni, & fmntr, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)<=0) THEN CALL fmentr('FMLG10',ma,ma,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) CALL fmln(mb,mb) IF (mbase/=mbsli .OR. ndig>ndigli) THEN CALL fmlni(10,m03) ELSE CALL fmadd(mln1,mln3,m03) END IF CALL fmdiv(mb,m03,mb) ! Round the result and return. macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmlg10 SUBROUTINE fmln(ma,mb) ! MB = LOG(MA) (Natural logarithm) IMPLICIT NONE ! Scratch array usage during FMLN: M01 - M05 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma1, macca, macmax, mxsave REAL (KIND(0.0D0)) :: y REAL :: x INTEGER :: iextra, ival, j, k, k2, k2exp, kasave, kbot, km1, kovun, & kreslt, kscale, kst, kwrnsv, last, n1, n3, ndsav1, ndsave, ndsv ! .. ! .. Local Arrays .. INTEGER :: nstack(19) ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdig, fmdiv, fmdivi, fmdpm, fmentr, fmeq, & fmeq2, fmexit, fmexp, fmi2m, fmlni, fmm2dp, fmm2i, fmmpy, fmmpyi, & fmntr, fmrslt, fmsqr, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)<=0) THEN CALL fmentr('FMLN ',ma,ma,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF ! 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 END IF IF (x>0.9999 .AND. x<=1.0001) THEN macca = ma(0) CALL fmeq2(ma,m03,ndsave,ndig,0) m03(0) = nint(ndig*alogm2) CALL fmi2m(-1,m01) CALL fmadd(m03,m01,m03) ! The sum will be done as two concurrent series. ndsav1 = ndig CALL fmeq(m03,m04) CALL fmdivi(m03,2,m05) CALL fmsqr(m03,mb) CALL fmeq(m03,m02) kbot = 2 10 kbot = kbot + 1 CALL fmmpy(m02,mb,m02) CALL fmdivi(m02,kbot,m01) ndig = ndsav1 CALL fmadd(m04,m01,m04) ndig = max(2,ndsav1-int(m04(1)-m01(1))) kbot = kbot + 1 CALL fmdivi(m02,kbot,m01) ndig = ndsav1 CALL fmadd(m05,m01,m05) ndig = max(2,ndsav1-int(m04(1)-m01(1))) IF (kflag/=1) GO TO 10 ndig = ndsav1 CALL fmmpy(m05,m03,m05) CALL fmsub(m04,m05,mb) GO TO 70 END IF ma1 = ma(1) macca = ma(0) CALL fmeq2(ma,m05,ndsave,ndig,0) m05(0) = nint(ndig*alogm2) ! Compute IEXTRA, the number of extra digits required. CALL fmi2m(1,m04) CALL fmsub(m04,m05,m04) iextra = max(0-int(m04(1)),0) IF (iextra>0 .AND. ndig+iextra<=ndg2mx) THEN CALL fmeq2(m05,m05,ndig,ndig+iextra,1) END IF ndig = ndig + iextra IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 20 j = 2, ndsave mb(j+1) = 0 20 CONTINUE ndig = ndig - iextra CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END IF ! 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. ival10) ndiglb = 0 ndig = ndsv END IF IF (kscale/=0 .AND. km1==0) THEN CALL fmmpyi(mlbsav,kscale,mb) CALL fmadd(m04,mb,mb) ELSE IF (kscale/=0 .AND. km1==1) THEN CALL fmmpyi(mlbsav,kscale,mb) ELSE IF (kscale==0 .AND. km1==0) THEN CALL fmeq(m04,mb) ELSE IF (kscale==0 .AND. km1==1) THEN CALL fmi2m(0,mb) END IF IF (k2exp/=0) THEN IF (mbase/=mbsli .OR. ndig>ndigli) THEN CALL fmlni(2,m04) END IF CALL fmmpyi(mln1,k2exp,m04) CALL fmadd(mb,m04,mb) END IF ! Round the result and return. 70 macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmln SUBROUTINE fmlni(ival,ma) ! MA = LOG(IVAL) ! Compute the natural logarithm of an integer IVAL. ! If IVAL has only powers of 2, 3, 5, and 7 in its factorization then ! FMLNI is faster than FMLN. Otherwise, if IVAL.GE.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. IMPLICIT NONE ! Scratch array usage during FMLNI: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC abs, dble, int, log, max, min, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL :: xval INTEGER :: int2, j, j2, j3, j5, j7, jtemp2, jtemp3, jtemp5, jtemp7, k, & k2, k3, k5, k7, kasave, kdelta, last, nd, ndmb, ndsave, ndsv, nt CHARACTER (155) :: string ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdivi, fmeq2, fmi2m, fmim, fmlni2, fmmpyi, & fmntr, fmntri, fmst2m, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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 CALL fmim(0,ma) ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) kflag = -4 CALL fmwarn IF (ntrace/=0) CALL fmntr(1,ma,ma,1) ncall = ncall - 1 RETURN END IF IF (ival==1) THEN CALL fmi2m(0,ma) IF (ntrace/=0) CALL fmntr(1,ma,ma,1) ncall = ncall - 1 RETURN END IF ! 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 ma(1) = munkno ma(2) = 1 ma(0) = nint(ndsave*alogm2) DO 10 j = 2, ndsave ma(j+1) = 0 10 CONTINUE ndig = ndsave IF (ntrace/=0) CALL fmntr(1,ma,ma,1) ncall = ncall - 1 RETURN END IF END IF 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 80 j7 = 1, last IF (jtemp7>int2 .AND. abs(jtemp7-int2)>kdelta) GO TO 90 jtemp5 = jtemp7 DO 60 j5 = 1, last IF (jtemp5>int2 .AND. abs(jtemp5-int2)>kdelta) GO TO 70 jtemp3 = jtemp5 DO 40 j3 = 1, last IF (jtemp3>int2 .AND. abs(jtemp3-int2)>kdelta) GO TO 50 jtemp2 = jtemp3 DO 20 j2 = 1, last IF (abs(jtemp2-int2)<=kdelta) THEN IF (abs(jtemp2-int2)==kdelta .AND. jtemp2int2) GO TO 30 jtemp2 = 2*jtemp2 20 CONTINUE 30 jtemp3 = 3*jtemp3 40 CONTINUE 50 jtemp5 = 5*jtemp5 60 CONTINUE 70 jtemp7 = 7*jtemp7 80 CONTINUE ! If IVAL was too close to the integer overflow limit, ! restore NT to an approximation of IVAL. 90 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 END IF END IF ! End of the search. Now compute LN(NT) as a linear ! combination of LN(2), LN(3), LN(5), and LN(7). IF (mbase/=mbsli .OR. ndig>ndigli) THEN ndmb = int(150.0*2.302585/alogmb) IF (ndmb>=ndig) THEN ndsv = ndig ndig = min(ndmb,ndg2mx) string = '0.693147180559945309417232121458176568075500' // & '13436025525412068000949339362196969471560586332699641' // & '8687542001481020570685733685520235758130557032670751635' CALL fmst2m(string,mln1) string = '1.098612288668109691395245236922525704647490' // & '55782274945173469433363749429321860896687361575481373' // & '2088787970029065957865742368004225930519821052801870767' CALL fmst2m(string,mln2) string = '1.609437912434100374600759333226187639525601' // & '35426851772191264789147417898770765776463013387809317' // & '9610799966303021715562899724005229324676199633616617464' CALL fmst2m(string,mln3) string = '1.945910149055313305105352743443179729637084' // & '72958186118845939014993757986275206926778765849858787' // & '1526993061694205851140911723752257677786843148958095164' CALL fmst2m(string,mln4) mbsli = mbase ndigli = ndig IF (abs(mln1(1))>10 .OR. abs(mln2(1))>10 .OR. abs(mln3( & 1))>10 .OR. abs(mln4(1))>10) ndigli = 0 ELSE ndsv = ndig ndig = min(ndig+2,ndg2mx) mbsli = mbase ndigli = ndig CALL fmlni2(1,126,mln1) CALL fmlni2(1,225,mln2) CALL fmlni2(1,2401,mln3) CALL fmlni2(1,4375,mln4) ! Get Ln(2). CALL fmmpyi(mln1,-72,mln1) CALL fmmpyi(mln2,-27,ma) CALL fmadd(mln1,ma,mln1) CALL fmmpyi(mln3,19,ma) CALL fmadd(mln1,ma,mln1) CALL fmmpyi(mln4,-31,ma) CALL fmadd(mln1,ma,mln1) ! Get Ln(3). CALL fmmpyi(mln2,-3,mln2) CALL fmmpyi(mln1,19,ma) CALL fmadd(mln2,ma,mln2) CALL fmsub(mln2,mln3,mln2) CALL fmadd(mln2,mln4,mln2) CALL fmdivi(mln2,12,mln2) ! Get Ln(5). CALL fmsub(mln3,mln1,mln3) CALL fmmpyi(mln2,27,ma) CALL fmadd(mln3,ma,mln3) CALL fmmpyi(mln4,-4,ma) CALL fmadd(mln3,ma,mln3) CALL fmdivi(mln3,18,mln3) ! Get Ln(7). CALL fmsub(mln1,mln4,mln4) CALL fmmpyi(mln2,7,ma) CALL fmadd(mln4,ma,mln4) CALL fmmpyi(mln3,-4,ma) CALL fmadd(mln4,ma,mln4) END IF 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 END IF ! If NT.NE.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) END IF CALL fmmpyi(mln1,k2,m02) CALL fmmpyi(mln2,k3,m01) CALL fmadd(m02,m01,m02) CALL fmmpyi(mln3,k5,m01) CALL fmadd(m02,m01,m02) CALL fmmpyi(mln4,k7,m01) IF (nt/=ival) CALL fmadd(m02,ma,m02) CALL fmadd(m02,m01,ma) ! Round and move the result to MA. kaccsw = kasave CALL fmeq2(ma,ma,ndig,ndsave,1) ndig = ndsave IF (ntrace/=0) CALL fmntr(1,ma,ma,1) 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. IMPLICIT NONE ! Scratch array usage during FMLNI2: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: int1, int2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmdivi, fmeq, fmi2m, fmmpyi ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. CALL fmi2m(int1,m02) CALL fmdivi(m02,int2,m02) CALL fmeq(m02,ma) ndsave = ndig j = 1 10 j = j + 1 IF (int1/=1) CALL fmmpyi(m02,int1,m02) CALL fmdivi(m02,int2,m02) CALL fmdivi(m02,j,m01) ndig = ndsave CALL fmadd(ma,m01,ma) ndig = ndsave - int(ma(1)-m01(1)) IF (ndig<2) ndig = 2 IF (kflag/=1) GO TO 10 ndig = ndsave ma(0) = nint(ndig*alogm2) ma(2) = -ma(2) RETURN END SUBROUTINE fmlni2 SUBROUTINE fmm2dp(ma,x) ! X = MA ! Convert an FM number to double precision. ! If KFLAG = -4 is returned for a value of MA that is in the range ! of the machine's double precision number system, change the ! definition of DPMAX in routine FMSET to reflect the current machine's ! range. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dble ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kreslt ! .. ! .. External Subroutines .. EXTERNAL fmargs, fmmd, fmntr, fmntrr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMM2DP' kreslt = 0 IF (abs(ma(1))>mexpab) THEN CALL fmargs('FMM2DP',1,ma,ma,kreslt) END IF IF (ntrace/=0) CALL fmntr(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 fmntrr(1,x,1) ncall = ncall - 1 RETURN END IF 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. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmmi, fmntr, fmntri ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMM2I ' IF (ntrace/=0) CALL fmntr(2,ma,ma,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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dble, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: y INTEGER :: kreslt ! .. ! .. External Subroutines .. EXTERNAL fmargs, fmmd, fmntr, fmntrr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMM2SP' kreslt = 0 IF (abs(ma(1))>mexpab) THEN CALL fmargs('FMM2SP',1,ma,ma,kreslt) END IF IF (ntrace/=0) CALL fmntr(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 = runkno kflag = -4 IF (ma(1)/=munkno) CALL fmwarn y = dble(x) IF (ntrace/=0) CALL fmntrr(1,y,1) ncall = ncall - 1 RETURN END IF CALL fmmd(ma,y) x = real(y) IF (ntrace/=0) THEN y = dble(x) CALL fmntrr(1,y,1) END IF ncall = ncall - 1 RETURN END SUBROUTINE fmm2sp SUBROUTINE fmmax(ma,mb,mc) ! MC = MAX(MA,MB) IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwrnsv ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmim, fmntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 ncall = ncall + 1 namest(ncall) = 'FMMAX ' IF (ntrace/=0) CALL fmntr(2,ma,mb,2) kwrnsv = kwarn kwarn = 0 IF (ma(1)==munkno .OR. mb(1)==munkno) THEN CALL fmim(0,mc) mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) kflag = -4 ELSE IF (fmcomp(ma,'LT',mb)) THEN CALL fmeq(mb,mc) ELSE CALL fmeq(ma,mc) END IF kwarn = kwrnsv IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END SUBROUTINE fmmax SUBROUTINE fmmd(ma,x) ! X = MA ! Internal routine for conversion to double precision. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dble, log ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma1, ma2 REAL (KIND(0.0D0)) :: dlogdp, one, pmax, rzero, xbase, y, yt INTEGER :: j, kwrnsv, n1, ncase ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmmi, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! 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) END IF dlogdp = log(pmax) ma1 = ma(1) ncase = 0 IF (dble(ma(1)-1)*dlogmb>dlogdp) THEN kflag = -4 x = dble(runkno) CALL fmwarn RETURN ELSE IF (dble(ma(1)+1)*dlogmb>dlogdp) THEN ma(1) = ma(1) - 2 ncase = 1 ELSE IF (dble(ma(1)+1)*dlogmb<-dlogdp) THEN kflag = -10 x = 0.0D0 CALL fmwarn RETURN ELSE IF (dble(ma(1)-1)*dlogmb<-dlogdp) THEN ma(1) = ma(1) + 2 ncase = 2 END IF ! 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 END IF kflag = 0 ma2 = ma(2) ma(2) = abs(ma2) rzero = 0.0D0 one = 1.0D0 n1 = ndig + 1 xbase = mbase x = rzero y = one DO 10 j = 2, n1 y = y/xbase yt = ma(j) x = x + y*yt yt = one + y*xbase IF (yt<=one) GO TO 20 10 CONTINUE 20 x = x*xbase**ma(1) IF (ma2<0) x = -x ma(2) = ma2 ! Check the result if it is near overflow or underflow. IF (ncase==1) THEN IF (x<=pmax/(xbase*xbase)) THEN x = x*xbase*xbase ELSE kflag = -4 x = dble(runkno) CALL fmwarn END IF 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 END IF END IF ma(1) = ma1 RETURN END SUBROUTINE fmmd SUBROUTINE fmmi(ma,ival) ! IVAL = MA. Internal FM to integer conversion routine. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, ka, kb, large, n1 ! .. ! .. External Subroutines .. EXTERNAL fmwarn ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 n1 = ndig + 1 large = int(intmax/mbase) ival = 0 IF (ma(1)<=0) THEN IF (ma(2)/=0) kflag = 2 RETURN END IF kb = int(ma(1)) + 1 ival = int(abs(ma(2))) IF (kb>=3) THEN DO 10 j = 3, kb IF (ival>large) THEN kflag = -4 IF (ma(1)/=munkno) CALL fmwarn ival = iunkno RETURN END IF 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)) END IF ELSE ival = ival*int(mbase) END IF 10 CONTINUE END IF IF (ma(2)<0) ival = -ival ! Check to see if MA is an integer. ka = kb + 1 IF (ka<=n1) THEN DO 20 j = ka, n1 IF (ma(j)/=0) THEN kflag = 2 RETURN END IF 20 CONTINUE END IF RETURN END SUBROUTINE fmmi SUBROUTINE fmmin(ma,mb,mc) ! MC = MIN(MA,MB) IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwrnsv ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmim, fmntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 ncall = ncall + 1 namest(ncall) = 'FMMIN ' IF (ntrace/=0) CALL fmntr(2,ma,mb,2) kwrnsv = kwarn kwarn = 0 IF (ma(1)==munkno .OR. mb(1)==munkno) THEN CALL fmim(0,mc) mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) kflag = -4 ELSE IF (fmcomp(ma,'GT',mb)) THEN CALL fmeq(mb,mc) ELSE CALL fmeq(ma,mc) END IF kwarn = kwrnsv IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END SUBROUTINE fmmin SUBROUTINE fmmod(ma,mb,mc) ! MC = MA(MOD MB). IMPLICIT NONE ! Scratch array usage during FMMOD: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, mod, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, maccb, macmax, mvb, mvc, mvy, mvz, mxsave INTEGER :: j, k, kasave, kb, ke, kn, kovun, kreslt, kwrnsv, ndsave, & ntrsav ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdiv, fmentr, fmeq2, fmexit, fmi2m, fmint, & fmm2i, fmmpy, fmntr, fmrslt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. abs(mb(1))>mexpab) THEN CALL fmentr('FMMOD ',ma,mb,2,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw mxsave = mxexp mxexp = mxexp2 END IF kwrnsv = kwarn kwarn = 0 macca = ma(0) maccb = mb(0) IF (mb(1)>ma(1) .AND. mb(2)/=0) THEN CALL fmeq2(ma,m01,ndsave,ndig,0) m01(0) = nint(ndig*alogm2) ELSE ! Special cases when MB is a small integer. CALL fmeq2(ma,m02,ndsave,ndig,0) m02(0) = nint(ndig*alogm2) CALL fmeq2(mb,m03,ndsave,ndig,0) m03(0) = nint(ndig*alogm2) CALL fmm2i(m03,kb) IF (kflag==0 .AND. kb=ndig) THEN CALL fmi2m(0,m01) GO TO 70 ELSE CALL fmint(m02,m03) CALL fmsub(m02,m03,m01) GO TO 70 END IF ELSE IF (m02(1)==mexpov .OR. kb==0) THEN kflag = -4 kwarn = kwrnsv kaccsw = kasave mxexp = mxsave CALL fmwarn mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mc(j+1) = 0 10 CONTINUE ndig = ndsave IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 RETURN ELSE IF (m02(1)>ndig .AND. mod(int(mbase),kb)==0) THEN CALL fmi2m(0,m01) GO TO 70 END IF IF (m02(1)1) GO TO 40 END IF mvz = mod(mvz*mvc,mvb) ke = int(mvz) CALL fmi2m(ke,m01) GO TO 70 END IF ! General case. 50 IF (ma(2)/=0) THEN ndig = ndig + int(ma(1)-mb(1)) END IF 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 mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) DO 60 j = 2, ndsave mc(j+1) = 0 60 CONTINUE ndig = ndsave IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END IF CALL fmeq2(ma,m02,ndsave,ndig,0) m02(0) = nint(ndig*alogm2) CALL fmeq2(mb,m03,ndsave,ndig,0) m03(0) = nint(ndig*alogm2) m02(2) = abs(m02(2)) m03(2) = abs(m03(2)) CALL fmdiv(m02,m03,m01) CALL fmint(m01,m01) CALL fmmpy(m01,m03,m01) CALL fmsub(m02,m01,m01) ! Due to rounding, M01 may not be between 0 and MB here. ntrsav = ntrace ntrace = 0 IF (fmcomp(m01,'GE',m03)) THEN ntrace = ntrsav CALL fmsub(m01,m03,m01) END IF ntrace = ntrsav IF (m01(2)<0) CALL fmadd(m01,m03,m01) IF (ma(2)<0 .AND. m01(1)/=munkno) m01(2) = -m01(2) END IF 70 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mw(lmwa) ! .. ! .. Local Scalars .. INTEGER :: j, n1, n2 ! .. ! .. External Subroutines .. EXTERNAL fmtrap ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mw(2)/=0) THEN n1 = ndig + 1 ! Major (Inner Loop) DO 10 j = 1, n1 ma(j) = mw(j) 10 CONTINUE ELSE n2 = ndig + 2 DO 20 j = 3, n2 ma(j-1) = mw(j) 20 CONTINUE IF (ma(2)/=0) THEN ma(1) = mw(1) - 1 ELSE ma(1) = 0 END IF END IF 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. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmmpy2, fmntr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMMPY ' CALL fmntr(2,ma,mb,2) CALL fmmpy2(ma,mb,mc) CALL fmntr(1,mc,mc,1) ELSE CALL fmmpy2(ma,mb,mc) END IF ncall = ncall - 1 RETURN END SUBROUTINE fmmpy SUBROUTINE fmmpy2(ma,mb,mc) ! Internal multiplication routine. MC = MA * MB IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, maccb, mb2, md2b, mr INTEGER :: j, kreslt, kshift, n1, nguard, nzma, nzmb ! .. ! .. External Subroutines .. EXTERNAL fmargs, fmcons, fmim, fmmove, fmmpy3, fmrnd, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons 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) ncall = ncall - 1 RETURN END IF ELSE IF (ma(2)==0 .OR. mb(2)==0) THEN CALL fmim(0,mc) mc(0) = min(macca,maccb) RETURN END IF kflag = 0 ! Save the sign of MA and MB and then work only with ! positive numbers. ma2 = ma(2) mb2 = mb(2) ma(2) = abs(ma(2)) mb(2) = abs(mb(2)) ! NGUARD is the number of guard digits used. IF (ncall>1) THEN nguard = ngrd22 IF (nguard>ndig) nguard = ndig ELSE nguard = ngrd52 IF (nguard>ndig) nguard = ndig END IF IF (ma(2)*mb(2)=6*mbase) THEN nzma = 0 nzmb = 0 DO 10 j = 2, n1 IF (ma(j)==0) nzma = nzma + 1 IF (mb(j)==0) nzmb = nzmb + 1 10 CONTINUE ! It is faster if the second argument is the one with ! more zero digits. IF (nzma>nzmb) THEN CALL fmmpy3(mb,ma,nguard,kshift) ELSE CALL fmmpy3(ma,mb,nguard,kshift) END IF ELSE CALL fmmpy3(ma,mb,nguard,kshift) END IF ! The multiplication is complete. Round the result, ! move it to MC, and append the correct sign. ma(2) = ma2 mb(2) = mb2 mr = 2*mwa(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwa(n1+kshift)1) THEN mwa(n1+kshift) = mwa(n1+kshift) + 1 mwa(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,kshift) END IF END IF CALL fmmove(mwa,mc) IF (kflag<0) THEN namest(ncall) = 'FMMPY ' CALL fmwarn END IF IF (ma2*mb2<0) mc(2) = -mc(2) IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(mc(2))+1))/0.69315) mc(0) = min(macca,maccb,md2b) ELSE mc(0) = min(macca,maccb) END IF RETURN END SUBROUTINE fmmpy2 SUBROUTINE fmmpy3(ma,mb,nguard,kshift) ! Internal multiplication of MA*MB. The result is returned in MWA. ! Both MA and MB are positive. ! NGUARD is the number of guard digits that will be used. ! KSHIFT = 1 is returned if a left shift is pending (i.e., MWA(2)=0). ! The shift will be done in FMMOVE. KSHIFT = 0 is returned ! if no shift is pending. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC dint, int, min ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kshift, nguard ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maxmwa, mbj, mbkj, mbm1, mbnorm, mk, mkt, mmax, mt INTEGER :: j, jm1, k, kb, ki, kj, kl, knz, kwa, l, n1 ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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 = dint(maxint/(mbm1*mbm1)) mmax = intmax - mbase mmax = min(dint(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 10 j = ndig, 2, -1 IF (ma(j)/=0) THEN knz = j GO TO 20 END IF 10 CONTINUE END IF 20 mwa(2) = 0 DO 30 k = ndig + 2, l mwa(k) = 0 30 CONTINUE ! (Inner Loop) DO 40 k = 2, n1 mwa(k+1) = ma(k)*mbj 40 CONTINUE maxmwa = mbj DO 70 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 50 k = j + 1, j + kl - 1 mwa(k) = mwa(k) + ma(k-jm1)*mbj 50 CONTINUE END IF IF (maxmwa>mmax) THEN maxmwa = 0 ! Here normalization is only required for the ! range of digits currently changing in MWA. DO 60 kb = jm1 + kl, jm1 + 2, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase 60 CONTINUE END IF 70 CONTINUE ! Perform the final normalization. (Inner Loop) DO 80 kb = l, 3, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase 80 CONTINUE ELSE ! If normalization must be done for each digit, combine ! the two loops and normalize as the digits are multiplied. DO 90 j = 2, l mwa(j) = 0 90 CONTINUE kj = ndig + 2 DO 110 j = 2, n1 kj = kj - 1 mbkj = mb(kj) IF (mbkj==0) GO TO 110 kl = l - kj + 1 IF (kl>n1) kl = n1 ki = kl + 2 kwa = kl + kj + 1 mk = 0 DO 100 k = 2, kl mt = ma(ki-k)*mbkj + mwa(kwa-k) + mk mk = int(mt/mbase) mwa(kwa-k) = mt - mbase*mk 100 CONTINUE mwa(kwa-kl-1) = mk 110 CONTINUE END IF ! Set KSHIFT = 1 if a shift left is necessary. IF (mwa(2)==0) THEN kshift = 1 RETURN ELSE kshift = 0 RETURN END IF 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck), & me(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, maccb, maccc, maxmwa, mb2, mbj, mbkj, mbm1, & mbnorm, mc2, mcj, mckj, md2b, mkb, mkc, mkt, mmax, mr, mt, mtemp INTEGER :: j, jm1, k, kb, ki, kj, kl, knz, kovun, kshift, kwa, l, n1, & nguard ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmeq, fmim, fmmove, fmmpy2, fmntr, fmntrj, fmprnt, & fmrnd, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa), mwd(lmwa), mwe(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /fmwa/mwd, mwe ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMMPYD' CALL fmntr(2,ma,mb,2) IF (abs(ntrace)>=2 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN CALL fmntrj(mc,ndig) ELSE CALL fmprnt(mc) END IF END IF END IF 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) & 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) END IF namest(ncall) = 'FMMPYD' CALL fmwarn END IF CALL fmeq(mwd,md) GO TO 120 END IF 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 END IF IF (mb(2)==0) THEN CALL fmmpy2(ma,mc,me) CALL fmim(0,md) md(0) = min(macca,maccb) GO TO 120 END IF IF (mc(2)==0) THEN CALL fmmpy2(ma,mb,md) CALL fmim(0,me) me(0) = min(macca,maccc) GO TO 120 END IF 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 END IF IF ((ma(2)*mb(2)1) THEN mbj = mb(2) mcj = mc(2) ! Count the trailing zeros in MA. IF (ma(n1)/=0) THEN knz = n1 ELSE DO 10 j = ndig, 2, -1 IF (ma(j)/=0) THEN knz = j GO TO 20 END IF 10 CONTINUE END IF 20 mwa(2) = 0 mwd(2) = 0 DO 30 k = ndig + 2, l mwa(k) = 0 mwd(k) = 0 30 CONTINUE ! (Inner Loop) DO 40 k = 2, n1 mtemp = ma(k) mwa(k+1) = mtemp*mbj mwd(k+1) = mtemp*mcj 40 CONTINUE IF (mbj>mcj) THEN maxmwa = mbj ELSE maxmwa = mcj END IF DO 70 j = 3, n1 mbj = mb(j) mcj = mc(j) IF (mbj>mcj) THEN maxmwa = maxmwa + mbj ELSE maxmwa = maxmwa + mcj END IF jm1 = j - 1 kl = min(knz,l-jm1) ! Major (Inner Loop) DO 50 k = j + 1, j + kl - 1 mtemp = ma(k-jm1) mwa(k) = mwa(k) + mtemp*mbj mwd(k) = mwd(k) + mtemp*mcj 50 CONTINUE IF (maxmwa>mmax) THEN maxmwa = 0 ! Here normalization is only required for the ! range of digits currently changing in MWA. DO 60 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 60 CONTINUE END IF 70 CONTINUE ! Perform the final normalization. (Inner Loop) DO 80 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 80 CONTINUE ELSE ! If normalization must be done for each digit, combine ! the two loops and normalize as the digits are multiplied. DO 90 j = 2, l mwa(j) = 0 mwd(j) = 0 90 CONTINUE kj = ndig + 2 DO 110 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 100 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 100 CONTINUE mwa(kwa-kl-1) = mkb mwd(kwa-kl-1) = mkc 110 CONTINUE END IF ! Set KSHIFT = 1 if a shift left is necessary. IF (mwa(2)==0) THEN kshift = 1 ELSE kshift = 0 END IF ! The multiplications are complete. ma(2) = ma2 mb(2) = mb2 mc(2) = mc2 mr = 2*mwa(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwa(n1+kshift)1) THEN mwa(n1+kshift) = mwa(n1+kshift) + 1 mwa(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,kshift) END IF END IF CALL fmmove(mwa,md) IF (mwd(2)==0) THEN kshift = 1 ELSE kshift = 0 END IF mr = 2*mwd(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwd(n1+kshift)1) THEN mwd(n1+kshift) = mwd(n1+kshift) + 1 mwd(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwd,ndig,nguard,kshift) END IF END IF CALL fmmove(mwd,me) IF (kflag<0) THEN namest(ncall) = 'FMMPYD' CALL fmwarn END IF IF (ma2*mb2<0) md(2) = -md(2) IF (ma2*mc2<0) me(2) = -me(2) IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(md(2))+1))/0.69315) md(0) = min(macca,maccb,md2b) md2b = nint((ndig-1)*alogm2+log(real(abs(me(2))+1))/0.69315) me(0) = min(macca,maccc,md2b) ELSE md(0) = min(macca,maccb) me(0) = min(macca,maccc) END IF 120 IF (ntrace/=0) THEN CALL fmntr(1,md,md,1) IF (abs(ntrace)>=1 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN CALL fmntrj(me,ndig) ELSE CALL fmprnt(me) END IF END IF END IF ncall = ncall - 1 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck), & me(0:lunpck), mf(0:lunpck), mg(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, maccb, maccc, maccd, maxj, maxmwa, mb2, mbj, & mbkj, mbm1, mbnorm, mc2, mcj, mckj, md2, md2b, mdj, mdkj, mkb, mkc, & mkd, mkt, mmax, mr, mt, mtemp INTEGER :: j, jm1, k, kb, ki, kj, kl, knz, kovun, kshift, kwa, l, n1, & nguard ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmeq, fmim, fmmove, fmmpy2, fmntr, fmntrj, fmprnt, & fmrnd, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa), mwd(lmwa), mwe(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /fmwa/mwd, mwe ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMMPYE' CALL fmntr(2,ma,mb,2) 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) END IF END IF END IF 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) 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) END IF namest(ncall) = 'FMMPYE' CALL fmwarn END IF CALL fmeq(mwd,me) CALL fmeq(mwe,mf) GO TO 120 END IF 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 END IF 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 END IF 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 END IF IF ((ma(2)*mb(2)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 10 j = ndig, 2, -1 IF (ma(j)/=0) THEN knz = j GO TO 20 END IF 10 CONTINUE END IF 20 mwa(2) = 0 mwd(2) = 0 mwe(2) = 0 DO 30 k = ndig + 2, l mwa(k) = 0 mwd(k) = 0 mwe(k) = 0 30 CONTINUE ! (Inner Loop) DO 40 k = 2, n1 mtemp = ma(k) mwa(k+1) = mtemp*mbj mwd(k+1) = mtemp*mcj mwe(k+1) = mtemp*mdj 40 CONTINUE maxmwa = mbj IF (mcj>maxmwa) maxmwa = mcj IF (mdj>maxmwa) maxmwa = mdj DO 70 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 50 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 50 CONTINUE IF (maxmwa>mmax) THEN maxmwa = 0 ! Here normalization is only required for the ! range of digits currently changing in MWA. DO 60 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 60 CONTINUE END IF 70 CONTINUE ! Perform the final normalization. (Inner Loop) DO 80 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 80 CONTINUE ELSE ! If normalization must be done for each digit, combine ! the two loops and normalize as the digits are multiplied. DO 90 j = 2, l mwa(j) = 0 mwd(j) = 0 mwe(j) = 0 90 CONTINUE kj = ndig + 2 DO 110 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 100 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 100 CONTINUE mwa(kwa-kl-1) = mkb mwd(kwa-kl-1) = mkc mwe(kwa-kl-1) = mkd 110 CONTINUE END IF ! Set KSHIFT = 1 if a shift left is necessary. IF (mwa(2)==0) THEN kshift = 1 ELSE kshift = 0 END IF ! The multiplications are complete. ma(2) = ma2 mb(2) = mb2 mc(2) = mc2 md(2) = md2 mr = 2*mwa(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwa(n1+kshift)1) THEN mwa(n1+kshift) = mwa(n1+kshift) + 1 mwa(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,kshift) END IF END IF CALL fmmove(mwa,me) IF (mwd(2)==0) THEN kshift = 1 ELSE kshift = 0 END IF mr = 2*mwd(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwd(n1+kshift)1) THEN mwd(n1+kshift) = mwd(n1+kshift) + 1 mwd(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwd,ndig,nguard,kshift) END IF END IF CALL fmmove(mwd,mf) IF (mwe(2)==0) THEN kshift = 1 ELSE kshift = 0 END IF mr = 2*mwe(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwe(n1+kshift)1) THEN mwe(n1+kshift) = mwe(n1+kshift) + 1 mwe(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwe,ndig,nguard,kshift) END IF END IF CALL fmmove(mwe,mg) IF (kflag<0) THEN namest(ncall) = 'FMMPYE' CALL fmwarn END IF IF (ma2*mb2<0) me(2) = -me(2) IF (ma2*mc2<0) mf(2) = -mf(2) IF (ma2*md2<0) mg(2) = -mg(2) IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(me(2))+1))/0.69315) me(0) = min(macca,maccb,md2b) md2b = nint((ndig-1)*alogm2+log(real(abs(mf(2))+1))/0.69315) mf(0) = min(macca,maccc,md2b) md2b = nint((ndig-1)*alogm2+log(real(abs(mg(2))+1))/0.69315) mg(0) = min(macca,maccd,md2b) ELSE me(0) = min(macca,maccb) mf(0) = min(macca,maccc) mg(0) = min(macca,maccd) END IF 120 IF (ntrace/=0) THEN CALL fmntr(1,me,me,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) END IF END IF END IF ncall = ncall - 1 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. IMPLICIT NONE ! Scratch array usage during FMMPYI: M01 ! .. Intrinsic Functions .. INTRINSIC abs, dble, int, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, mcarry, md2b, mkt, mlr, mval INTEGER :: j, ka, kb, kc, kshift, n1, nguard, nmval, nv2 ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmeq, fmim, fmmove, fmmpy2, fmntr, fmntri, fmrnd, & fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons macca = ma(0) ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMMPYI' CALL fmntr(2,ma,ma,1) CALL fmntri(2,ival,0) END IF 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) END IF ncall = ncall - 1 RETURN END IF IF (abs(ma(1))1) GO TO 20 IF (ma(1)==munkno) THEN CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -4 IF (ntrace/=0) THEN CALL fmntr(1,mb,mb,1) END IF ncall = ncall - 1 RETURN END IF IF (ival==0) THEN CALL fmim(0,mb) IF (ntrace/=0) THEN CALL fmntr(1,mb,mb,1) END IF ncall = ncall - 1 RETURN END IF IF (abs(ival)==1) THEN DO 10 j = 0, n1 mb(j) = ma(j) 10 CONTINUE IF (ma(1)==mexpov) kflag = -5 IF (ma(1)==mexpun) kflag = -6 mb(2) = ma(2)*ival IF (ntrace/=0) THEN CALL fmntr(1,mb,mb,1) END IF ncall = ncall - 1 RETURN END IF IF (ma(1)==mexpov) THEN ma2 = ma(2) CALL fmim(0,mb) kflag = -5 mb(1) = mexpov mb(2) = 1 mb(0) = nint(ndig*alogm2) IF ((ma2<0 .AND. ival>0) .OR. (ma2>0 .AND. ival<0)) mb(2) = -1 IF (ntrace/=0) THEN CALL fmntr(1,mb,mb,1) END IF ncall = ncall - 1 RETURN END IF IF (ma(1)==mexpun) THEN CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) namest(ncall) = 'FMMPYI' kflag = -4 CALL fmwarn IF (ntrace/=0) THEN CALL fmntr(1,mb,mb,1) END IF ncall = ncall - 1 RETURN END IF ! Work with positive numbers. 20 ma2 = ma(2) ma(2) = abs(ma(2)) mval = abs(ival) nmval = int(mval) nv2 = nmval - 1 ! To leave room for the normalization, shift the product ! to the right KSHIFT places in MWA. kshift = int((log(dble(ma(2)+1)*dble(mval)))/dlogmb) ! If IVAL is too big use FMMPY. IF (kshift>ndig .OR. mval>maxint/mbase .OR. nmval/=abs(ival) .OR. & nv2/=abs(ival)-1) THEN CALL fmim(ival,m01) ma(2) = ma2 CALL fmmpy2(ma,m01,mb) IF (ntrace/=0) THEN CALL fmntr(1,mb,mb,1) END IF ncall = ncall - 1 RETURN END IF mwa(1) = ma(1) + kshift ka = 2 + kshift kb = n1 + kshift kc = ndig + 5 DO 30 j = kb, kc mwa(j) = 0 30 CONTINUE mcarry = 0 ! This is the main multiplication loop. DO 40 j = kb, ka, -1 mkt = ma(j-kshift)*mval + mcarry mcarry = int(mkt/mbase) mwa(j) = mkt - mcarry*mbase 40 CONTINUE ! Resolve the final carry. DO 50 j = ka - 1, 2, -1 mkt = int(mcarry/mbase) mwa(j) = mcarry - mkt*mbase mcarry = mkt 50 CONTINUE ! Now the first significant digit in the product is in ! MWA(2) or MWA(3). Round the result and move it to MB. ma(2) = ma2 IF (mwa(2)==0) THEN mlr = 2*mwa(ndig+3) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwa(n1+1)1) THEN mwa(n1+1) = mwa(n1+1) + 1 mwa(n1+2) = 0 END IF ELSE nguard = kshift - 1 CALL fmrnd(mwa,ndig,nguard,1) END IF END IF ELSE mlr = 2*mwa(ndig+2) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwa(n1)1) THEN mwa(n1) = mwa(n1) + 1 mwa(n1+1) = 0 END IF ELSE CALL fmrnd(mwa,ndig,kshift,0) END IF END IF END IF CALL fmmove(mwa,mb) IF (kflag<0) THEN namest(ncall) = 'FMMPYI' CALL fmwarn END IF ! Put the sign on the result. IF ((ival>0 .AND. ma2<0) .OR. (ival<0 .AND. ma2>0)) mb(2) = -mb(2) IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(macca,md2b) ELSE mb(0) = macca END IF IF (ntrace/=0) THEN CALL fmntr(1,mb,mb,1) END IF ncall = ncall - 1 RETURN END SUBROUTINE fmmpyi SUBROUTINE fmmset(maxint,ml,mld2,mlm1) ! Internal routine to keep some compilers from doing a loop at ! the highest precision available and then rounding to the ! declared precision. For example, it is used in FMSET while ! trying to find the threshold beyond which integers cannot ! be represented exactly using (M) precision. ! .. Intrinsic Functions .. INTRINSIC dint ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: maxint, ml, mld2, mlm1 ! .. ml = 2*maxint + 1 mld2 = dint(ml/2) mlm1 = ml - 1 RETURN END SUBROUTINE fmmset SUBROUTINE fmnint(ma,mb) ! MB = NINT(MA) -- MB is returned as the nearest integer to MA. IMPLICIT NONE ! Scratch array usage during FMNINT: M01 ! .. Intrinsic Functions .. INTRINSIC abs, int, max ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, mxsave INTEGER :: k, kasave, kovun, kreslt, kwrnsv, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdivi, fmentr, fmeq2, fmexit, fmi2m, fmint, & fmntr, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab) THEN CALL fmentr('FMNINT',ma,ma,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF kwrnsv = kwarn kwarn = 0 CALL fmeq2(ma,mb,ndsave,ndig,0) IF (ndsave>int(ma(1))) THEN ma2 = ma(2) mb(2) = abs(mb(2)) CALL fmi2m(1,m01) CALL fmdivi(m01,2,m01) CALL fmadd(mb,m01,mb) CALL fmint(mb,mb) IF (ma2<0) mb(2) = -mb(2) END IF kwarn = kwrnsv ! Round the result and return. CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmnint SUBROUTINE fmntr(ntr,ma,mb,narg) ! 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. ! NTRACE and LVLTRC (in COMMON /FMUSER/) 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: narg, ntr ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. CHARACTER (6) :: name ! .. ! .. External Subroutines .. EXTERNAL fmntrj, fmprnt ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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,90000) name ELSE name = namest(ncall) IF (kflag==0) THEN WRITE (kw,90010) name, ncall, int(mbase), ndig ELSE WRITE (kw,90020) name, ncall, int(mbase), ndig, kflag END IF END IF ! Check for base MBASE internal format trace. IF (ntrace<0) THEN CALL fmntrj(ma,ndig) IF (narg==2) CALL fmntrj(mb,ndig) END IF ! Check for base 10 trace using FMOUT. IF (ntrace>0) THEN CALL fmprnt(ma) IF (narg==2) THEN CALL fmprnt(mb) END IF END IF RETURN 90000 FORMAT (' Input to ',A6) 90010 FORMAT (' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10,5X,'NDIG =',I6) 90020 FORMAT (' ',A6,6X,'Call level =',I2,4X,'MBASE =',I10,4X,'NDIG =',I6,4X, & 'KFLAG =',I3) 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: knam, n, ntr ! .. ! .. Local Scalars .. CHARACTER (6) :: name ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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,90000) name END IF IF (ntr==1 .AND. knam>0) THEN name = namest(ncall) IF (kflag==0) THEN WRITE (kw,90010) name, ncall, int(mbase), ndig ELSE WRITE (kw,90020) name, ncall, int(mbase), ndig, kflag END IF END IF WRITE (kw,90030) n RETURN 90000 FORMAT (' Input to ',A6) 90010 FORMAT (' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10,5X,'NDIG =',I6) 90020 FORMAT (' ',A6,6X,'Call level =',I2,4X,'MBASE =',I10,4X,'NDIG =',I6,4X, & 'KFLAG =',I3) 90030 FORMAT (1X,I18) 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC dble, int, log10 ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: nd ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, l, n, n1 CHARACTER (50) :: form ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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,90000) l + 2, n - 1, l ELSE WRITE (form,90010) l + 2, n - 1, l, n, l END IF WRITE (kw,form) (int(ma(j)),j=1,n1) RETURN 90000 FORMAT (' (1X,I19,I',I2,',',I3,'I',I2,') ') 90010 FORMAT (' (1X,I19,I',I2,',',I3,'I',I2,'/(22X,',I3,'I',I2,')) ') 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.EQ.1 ! KNAM - Positive if the routine name is to be printed. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x INTEGER :: knam, ntr ! .. ! .. Local Scalars .. CHARACTER (6) :: name ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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,90000) name END IF IF (ntr==1 .AND. knam>0) THEN name = namest(ncall) IF (kflag==0) THEN WRITE (kw,90010) name, ncall, int(mbase), ndig ELSE WRITE (kw,90020) name, ncall, int(mbase), ndig, kflag END IF END IF WRITE (kw,90030) x RETURN 90000 FORMAT (' Input to ',A6) 90010 FORMAT (' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10,5X,'NDIG =',I6) 90020 FORMAT (' ',A6,6X,'Call level =',I2,4X,'MBASE =',I10,4X,'NDIG =',I6,4X, & 'KFLAG =',I3) 90030 FORMAT (1X,D30.20) 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 COMMON) 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.EQ.0 and JFORM1.NE.2 then a default number of ! digits is chosen. The default is roughly the full precision ! of MA. ! If JFORM2.EQ.0 and JFORM1.EQ.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.EQ.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, .... IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dble, dint, int, log10, max, min, mod, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) CHARACTER (1) :: line(lb) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: m2, mbsave, mexp, mexp10, mkt, mndgms, ms1, ms2, msd2, mt10, & mxsave REAL :: x 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 CHARACTER (1) :: kchar ! .. ! .. Local Arrays .. REAL (KIND(0.0D0)) :: md(0:lunpck), ms(0:lunpck), mt(0:lunpck) CHARACTER (1) :: nexpov(12), nexpun(12), numb(10), nunkno(12) ! .. ! .. External Subroutines .. EXTERNAL fmadd2, fmcons, fmdiv2, fmeq, fmeq2, fmim, fmmpy2, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! .. Data Statements .. DATA numb/'0', '1', '2', '3', '4', '5', '6', '7', '8', '9'/ DATA nunkno/' ', ' ', ' ', 'U', 'N', 'K', 'N', 'O', 'W', 'N', ' ', ' '/ DATA nexpov/' ', ' ', ' ', 'O', 'V', 'E', 'R', 'F', 'L', 'O', 'W', ' '/ DATA nexpun/' ', ' ', ' ', 'U', 'N', 'D', 'E', 'R', 'F', 'L', 'O', 'W'/ ! .. ! 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 10 j = 1, lb line(j) = ' ' 10 CONTINUE ! Check for special cases. IF (ma(1)==munkno) THEN DO 20 j = 1, 12 line(j) = nunkno(j) 20 CONTINUE ncall = ncall - 2 RETURN END IF IF (ma(1)==mexpov) THEN DO 30 j = 1, 12 line(j) = nexpov(j) 30 CONTINUE line(2) = '+' IF (ma(2)<0) line(2) = '-' ncall = ncall - 2 RETURN END IF IF (ma(1)==mexpun) THEN DO 40 j = 1, 12 line(j) = nexpun(j) 40 CONTINUE line(2) = '+' IF (ma(2)<0) line(2) = '-' ncall = ncall - 2 RETURN END IF IF (ma(2)==0 .AND. jform1==2 .AND. jform2==0) THEN line(2) = '0' ncall = ncall - 2 RETURN END IF 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. 50 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) END IF IF (jform2<=0 .AND. jform1<=1) nd = int(1.1+real(ndig-1)*log10(real( & mbase))) IF (nd<2) nd = 2 IF (lbndg2mx) THEN kflag = -9 ncall = ncall - 1 CALL fmwarn ncall = ncall + 1 GO TO 270 END IF IF (ma(2)==0) THEN CALL fmim(0,ms) GO TO 110 END IF ! 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 60 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 270 END IF CALL fmeq2(ma,ms,ndsave,ndig,0) ms(2) = abs(ms(2)) GO TO 110 END IF 60 CONTINUE IF (mblogs/=mbase) CALL fmcons CALL fmim(int(mbsave),md) nds2 = ndsave + 1 CALL fmim(1,mt) kmt = 1 ! Convert the fraction part of MA to the new base. kpt = nds2 + 1 DO 70 j = 3, nds2 kpt = kpt - 1 IF (ma(kpt)/=0) GO TO 80 70 CONTINUE 80 kexpsh = kpt - 1 kdigit = int(abs(ma(2))) CALL fmim(kdigit,ms) ndigms = ndig DO 90 j = 3, kpt kdigit = int(ma(j)) IF (mbsave==2) THEN ndig = min(ndigms,max(2,int(ms(1))+1)) CALL fmadd2(ms,ms,ms) ELSE ndig = min(ndigms,max(2,int(ms(1)+md(1)))) CALL fmmpy2(ms,md,ms) END IF IF (kdigit>0) THEN IF (kmt/=kdigit) THEN ndig = min(ndigms,max(2,int(md(1)))) CALL fmim(kdigit,mt) kmt = kdigit END IF ndig = min(ndigms,max(2,int(max(ms(1),mt(1)))+1)) CALL fmadd2(ms,mt,ms) END IF 90 CONTINUE ! Convert the exponent. ndig = ndigms CALL fmim(1,mt) k = abs(int(ma(1))-kexpsh) IF (mod(k,2)==1) THEN CALL fmeq(md,mt) ELSE CALL fmim(1,mt) END IF 100 k = k/2 m2 = 2 mndgms = ndigms ndig = int(min(mndgms,max(m2,md(1)*m2))) IF (k>0) CALL fmmpy2(md,md,md) IF (mod(k,2)==1) THEN ndig = int(min(mndgms,max(m2,mt(1)+md(1)))) CALL fmmpy2(mt,md,mt) END IF IF (k>1) GO TO 100 ndig = ndigms IF (ma(1)-kexpsh<0) THEN CALL fmdiv2(ms,mt,ms) ELSE CALL fmmpy2(ms,mt,ms) END IF ! Now MS is the value of MA converted to a ! power of ten base. ! Convert it to a character string base 10 for output. ! MEXP10 is the base 10 exponent. ! KMS2SD is the number of base 10 significant digits ! in MS(2). 110 ms1 = ms(1) 120 mexp10 = npower*ms(1) kms2sd = npower k = int(mbase) DO 130 j = 1, npower k = k/10 IF (ms(2)nd) THEN nsd2 = nd ELSE nsd2 = int(msd2) END IF 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 END IF nsd1 = kms2sd + npower*(nword-2) IF (nword<2) THEN nval = 0 ELSE nval = 10**(nsd1-nsd2) END IF ! Now do the base 10 rounding. IF (nword>=2) THEN x = 0.0 IF (nval>1) x = mod(int(ms(nword)),nval) IF (nword=mbase) THEN nword1 = nword - 1 nword2 = nword - 2 IF (nword>2) THEN CALL fmeq2(ms,ms,nword1,nword2,1) ELSE ms(1) = ms(1) + 1 ms(2) = int(ms(2)/mbase) ms(3) = 0 END IF END IF IF (ms(1)/=ms1 .OR. ms(2)/=ms2) GO TO 120 END IF ! Build the base 10 character string. 140 IF (ma(2)<0) line(1) = '-' line(2) = '.' k = 10**kms2sd l = 2 IF (nword==-1) nsd2 = nd DO 150 j = 1, nsd2 k = k/10 IF (k==0) THEN k = int(mbase)/10 l = l + 1 END IF kdigit = int(ms(l))/k ms(l) = mod(int(ms(l)),k) line(j+2) = numb(kdigit+1) 150 CONTINUE ka = nsd2 + 3 kb = nd + 2 IF (kb>=ka) THEN DO 160 j = ka, kb line(j) = numb(1) 160 CONTINUE END IF 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 180 j = 1, lb mkt = dint(mexp/mt10) kdigit = int(mexp-mkt*mt10) line(nd+4+j) = numb(kdigit+1) mexp = mkt IF (mexp==0) GO TO 190 IF (nd+5+j>lb) THEN DO 170 k = 1, lb line(k) = '*' 170 CONTINUE GO TO 210 END IF nde = nde + 1 180 CONTINUE 190 nde2 = nde/2 IF (nde2<1) GO TO 210 k1 = nd + 4 k2 = nd + 5 + nde DO 200 j = 1, nde2 k1 = k1 + 1 k2 = k2 - 1 kchar = line(k1) line(k1) = line(k2) line(k2) = kchar 200 CONTINUE ! If JFORM1 is 1 put the first digit left of the decimal. 210 IF (jform1==1) THEN kchar = line(2) line(2) = line(3) line(3) = kchar END IF ! 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 220 j = 1, lb line(j) = ' ' 220 CONTINUE GO TO 50 END IF ka = nd + 3 DO 230 j = ka, lb line(j) = numb(1) 230 CONTINUE kexp = int(mexp10) IF (mexp10>0) THEN DO 240 j = 1, kexp line(j+1) = line(j+2) 240 CONTINUE line(kexp+2) = '.' END IF IF (mexp10<0) THEN kexp = -int(mexp10) ka = 3 + kexp kb = lb + 1 kc = kb - kexp DO 250 j = ka, lb kb = kb - 1 kc = kc - 1 line(kb) = line(kc) line(kc) = numb(1) 250 CONTINUE END IF jdpt = 0 DO 260 j = 1, lb IF (line(j)=='.') jdpt = j IF (jdpt>0 .AND. j>jdpt+jform2) line(j) = ' ' 260 CONTINUE IF (jform2==0 .AND. jdpt>0) line(kexp+2) = ' ' END IF ! Restore values and return GO TO 290 ! LINE is not big enough to hold the number ! of digits specified. 270 kflag = -8 DO 280 j = 1, lb line(j) = '*' 280 CONTINUE ncall = ncall - 1 CALL fmwarn ncall = ncall + 1 290 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, mod ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mp(0:lpack) ! .. ! .. Local Scalars .. INTEGER :: j, kp ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kp = 2 mp(0) = ma(0) mp(1) = ma(1) mp(2) = abs(ma(2))*mbase + ma(3) IF (ma(2)<0) mp(2) = -mp(2) IF (ndig>=4) THEN DO 10 j = 4, ndig, 2 kp = kp + 1 mp(kp) = ma(j)*mbase + ma(j+1) 10 CONTINUE END IF IF (mod(ndig,2)==1) mp(kp+1) = ma(ndig+1)*mbase RETURN END SUBROUTINE fmpack SUBROUTINE fmpi(ma) ! MA = pi IMPLICIT NONE ! Scratch array usage during FMPI: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC abs, int, max, min, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, k, kasave, ndmb, ndsave, ndsv CHARACTER (155) :: string ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmeq2, fmntr, fmpi2, fmst2m, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons kflag = 0 ncall = ncall + 1 namest(ncall) = 'FMPI ' IF (abs(ntrace)>=2 .AND. ncall<=lvltrc) THEN WRITE (kw,90000) END IF 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 ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave ma(j+1) = 0 10 CONTINUE GO TO 20 END IF END IF ! Check to see if pi has previously been computed ! in base MBASE with sufficient precision. IF (mbspi==mbase .AND. ndigpi>=ndig) THEN IF (namest(ncall-1)/='NOEQ ') THEN kaccsw = kasave CALL fmeq2(mpisav,ma,ndigpi,ndsave,0) END IF 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 END IF IF (namest(ncall-1)/='NOEQ ') THEN kaccsw = kasave CALL fmeq2(mpisav,ma,ndig,ndsave,0) END IF ndig = ndsv END IF 20 ndig = ndsave kaccsw = kasave IF (ntrace/=0) CALL fmntr(1,ma,ma,1) ncall = ncall - 1 RETURN 90000 FORMAT (' Input to FMPI') 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. IMPLICIT NONE ! Scratch array usage during FMPI2: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC int, max, nint, sqrt ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: mpi(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mx REAL (KIND(0.0D0)) :: x INTEGER :: j, k, kst, large, n, ndigrd, ndsave ! .. ! .. Local Arrays .. INTEGER :: nstack(19) ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdig, fmdiv, fmdivi, fmdpm, fmi2m, fmmpy, & fmmpyi ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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 10 n = n + 1 large = int(mx)/(4*n+3) j = 4*n + 1 IF (j>large) THEN CALL fmmpyi(m02,j,m02) j = j + 1 CALL fmmpyi(m02,j,m02) j = j + 1 CALL fmmpyi(m02,j,m02) ELSE IF (j*(j+1)>large) THEN k = j*(j+1) CALL fmmpyi(m02,k,m02) j = j + 2 CALL fmmpyi(m02,j,m02) ELSE k = j*(j+1)*(j+2) CALL fmmpyi(m02,k,m02) END IF j = n + 1 large = int(mxbase)/j IF (j>large) THEN CALL fmdivi(m02,j,m02) CALL fmdivi(m02,j,m02) CALL fmdivi(m02,j,m02) ELSE IF (j*j>large) THEN k = j*j CALL fmdivi(m02,k,m02) CALL fmdivi(m02,j,m02) ELSE k = j*j*j CALL fmdivi(m02,k,m02) END IF ! Break 4/396**4 into 1/(2178*2178*1296). j = 2178 large = int(mxbase)/j IF (j>large) THEN CALL fmdivi(m02,j,m02) CALL fmdivi(m02,j,m02) CALL fmdivi(m02,1296,m02) ELSE k = j*j CALL fmdivi(m02,k,m02) CALL fmdivi(m02,1296,m02) END IF ndigrd = ndig ndig = ndsave CALL fmadd(m03,m04,m04) ndig = ndigrd CALL fmmpy(m02,m04,m01) ndig = ndsave CALL fmadd(mpi,m01,mpi) ndig = max(2,ndsave-int(mpi(1)-m01(1))) IF (kflag/=1) GO TO 10 ndig = ndsave CALL fmi2m(8,m02) x = 8 x = sqrt(x) CALL fmdpm(x,m04) CALL fmdig(nstack,kst) DO 20 j = 1, kst ndig = nstack(j) CALL fmdiv(m02,m04,m01) CALL fmadd(m04,m01,m04) CALL fmdivi(m04,2,m04) 20 CONTINUE m04(0) = nint(ndig*alogm2) CALL fmi2m(9801,m03) CALL fmmpy(mpi,m04,mpi) CALL fmdiv(m03,mpi,mpi) RETURN END SUBROUTINE fmpi2 SUBROUTINE fmprnt(ma) ! Print MA in base 10 format. ! FMPRNT can be called directly by the user for easy output ! in M format. MA is converted using FMOUT and printed. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int, log10, max, min, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, k, ksave, l, last, lb, nd, nexp CHARACTER (20) :: form ! .. ! .. External Subroutines .. EXTERNAL fmout ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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,90000) kswide - 7 DO 10 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 END IF 10 CONTINUE ncall = ncall - 1 RETURN 90000 FORMAT (' (6X,',I3,'A1) ') 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. IMPLICIT NONE ! Scratch array usage during FMPWR: M01 - M06 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, maccb, macmax, mxsave INTEGER :: iextra, intmb, j, k, kasave, kfl, kovun, kreslt, kwrnsv, & ndsave ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmentr, fmeq2, fmexit, fmexp, fmim, fmipwr, fmln, fmmi, & fmmpy, fmntr, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! Convert MB to an integer before changing NDIG. kwrnsv = kwarn kwarn = 0 CALL fmmi(mb,intmb) kwarn = kwrnsv kfl = kflag IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. abs(mb(1))>mexpab .OR. ma(2)<=0) THEN CALL fmentr('FMPWR ',ma,mb,2,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF ! 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))) END IF IF (mb(1)-ndig>log(alogmb*real(mxexp2))) THEN iextra = 0 END IF ndig = ndig + iextra IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mc(j+1) = 0 10 CONTINUE ndig = ndig - iextra CALL fmexit(mc,mc,ndsave,mxsave,kasave,kovun) RETURN END IF ! If the exponent is a small integer, call FMIPWR. kwrnsv = kwarn kwarn = 0 macca = ma(0) maccb = nint(ndig*alogm2) CALL fmeq2(ma,m06,ndsave,ndig,0) m06(0) = nint(ndig*alogm2) IF (kfl==0) THEN CALL fmipwr(m06,intmb,mc) ELSE IF (m06(2)<=0) THEN CALL fmim(0,mc) mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) kflag = -4 ELSE CALL fmln(m06,m06) maccb = mb(0) CALL fmeq2(mb,m02,ndsave,ndig,0) m02(0) = nint(ndig*alogm2) CALL fmmpy(m06,m02,m06) CALL fmexp(m06,mc) END IF kwarn = kwrnsv ! Round the result and return. macmax = nint((ndsave-1)*alogm2+log(real(abs(mc(2))+1))/0.69315) mc(0) = min(mc(0),macca,maccb,macmax) CALL fmexit(mc,mc,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmpwr SUBROUTINE fmrdc(ma,mb,jsin,jcos,jswap) ! Reduce MA using various trigonometric identities to an equivalent ! angle MB between 0 and 45 degrees. The reduction is done in radians ! if KRAD (in common /FMUSER/) is 1, in degrees if KRAD is 0. ! JSIN and JCOS are returned +1 or -1 and JSWAP is returned to indicate ! that the sin and cos functions have been interchanged as follows: ! JSWAP = 0 means SIN(MA) = JSIN*SIN(MB) ! COS(MA) = JCOS*COS(MB) ! JSWAP = 1 means SIN(MA) = JSIN*COS(MB) ! COS(MA) = JCOS*SIN(MB) IMPLICIT NONE ! Scratch array usage during FMRDC: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC abs, int, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: jcos, jsin, jswap ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: x INTEGER :: j, kasave, ndsave, ndsv ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdiv, fmdivi, fmeq, fmeq2, fmi2m, fmint, & fmm2dp, fmmpy, fmpi, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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 mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mb(j+1) = 0 10 CONTINUE ndig = ndsave RETURN END IF ma(0) = ma(0) + nint(alogm2*real(max(0,int(ma(1))))) ! If MA is less than 1/MBASE, no reduction is needed. IF (ma(1)<0) THEN ndig = ndsave CALL fmeq(ma,mb) IF (mb(2)<0) THEN mb(2) = -mb(2) jsin = -1 END IF RETURN END IF j = 1 IF (krad==1) THEN 20 IF (mbspi/=mbase .OR. ndigpindg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 30 j = 2, ndsave mb(j+1) = 0 30 CONTINUE ndig = ndsave RETURN END IF jsin = 1 jcos = 1 jswap = 0 ma(0) = ma(0) + nint(alogm2*real(-m04(1))) GO TO 20 END IF ELSE CALL fmeq2(ma,m04,ndsave,ndig,0) IF (ma(2)<0) jsin = -1 m04(2) = abs(m04(2)) IF (m04(1)==0) THEN CALL fmm2dp(m04,x) IF (x<=44.0) THEN ndig = ndsave CALL fmeq(m04,mb) RETURN END IF END IF CALL fmi2m(360,m02) IF (fmcomp(m04,'GE',m02)) THEN CALL fmdiv(m04,m02,m01) CALL fmint(m01,m01) CALL fmmpy(m01,m02,m01) CALL fmsub(m04,m01,m04) END IF CALL fmi2m(180,m03) IF (fmcomp(m04,'GE',m03)) THEN jsin = -jsin CALL fmsub(m02,m04,m04) END IF CALL fmi2m(90,m02) IF (fmcomp(m04,'GE',m02)) THEN jcos = -jcos CALL fmsub(m03,m04,m04) END IF CALL fmi2m(45,m03) IF (fmcomp(m04,'GE',m03)) THEN jswap = 1 CALL fmsub(m02,m04,m04) END IF END IF ! Round the result and return. CALL fmeq2(m04,mb,ndig,ndsave,0) ndig = ndsave RETURN END SUBROUTINE fmrdc SUBROUTINE fmread(kread,ma) ! Read MA on unit KREAD. Multi-line numbers will have '&' as the ! last nonblank character on all but the last line. Only one ! number is allowed on the line(s). IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC max, min, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kread ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, lb, ndsave ! .. ! .. Local Arrays .. CHARACTER (1) :: line(80) ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmeq2, fminp, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons ncall = ncall + 1 namest(ncall) = 'FMREAD' ndsave = ndig ndig = min(ndg2mx,max(ndig+ngrd52,2)) lb = 0 10 READ (kread,90000,err=30,end=30) line ! Scan the line and look for '&' DO 20 j = 1, 80 IF (line(j)=='&') GO TO 10 IF (line(j)/=' ') THEN lb = lb + 1 IF (lb>lmbuff) THEN kflag = -8 GO TO 40 END IF cmbuff(lb) = line(j) END IF 20 CONTINUE CALL fminp(cmbuff,m01,1,lb) CALL fmeq2(m01,ma,ndig,ndsave,0) ndig = ndsave ncall = ncall - 1 RETURN ! If there is an error, return UNKNOWN. 30 kflag = -4 40 CALL fmwarn ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) DO 50 j = 2, ndig ma(j+1) = 0 50 CONTINUE ncall = ncall - 1 RETURN 90000 FORMAT (80A1) 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC dint, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kshift, nd, nguard ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: mw(lmwa) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: m2, mfactr, mkt INTEGER :: j, k, kb, l ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (kround==0 .AND. ncall<=1) RETURN l = nd + 2 + kshift IF (2*(mw(l)+1)mbase) THEN mw(l-1) = mw(l-1) + 1 mw(l) = 0 IF (mw(l-1)=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) END IF IF (mw(l+1)==mfactr) RETURN END IF DO 10 j = 2, nguard IF (mw(l+j-1)>0) GO TO 30 10 CONTINUE END IF ! Round to even. IF (int(mw(l-1)-dint(mw(l-1)/m2)*m2)==0) RETURN END IF ELSE IF (2*mw(l)+1==mbase) THEN IF (nguard>=2) THEN DO 20 j = 2, nguard IF (2*(mw(l+j-1)+1)mbase) GO TO 30 20 CONTINUE RETURN END IF END IF END IF 30 mw(l-1) = mw(l-1) + 1 mw(l) = 0 ! Check whether there was a carry in the rounded digit. 40 kb = l - 1 IF (kb>=3) THEN k = kb + 1 DO 50 j = 3, kb k = k - 1 IF (mw(k)=mbase) THEN IF (kb>=4) THEN k = kb + 1 DO 60 j = 4, kb k = k - 1 mw(k) = mw(k-1) 60 CONTINUE END IF mkt = dint(mw(2)/mbase) IF (kb>=3) mw(3) = mw(2) - mkt*mbase mw(2) = mkt mw(1) = mw(1) + 1 END IF 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. IMPLICIT NONE ! Scratch array usage during FMRPWR: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC abs, dble, int, log, max, min, mod, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival, jval ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: f, x REAL (KIND(0.0D0)) :: ma1, ma2, macca, macmax, mxsave REAL :: xval INTEGER :: ijsign, invert, ival2, j, jval2, k, kasave, kovun, kreslt, & kst, kwrnsv, l, lval, ndsave ! .. ! .. Local Arrays .. INTEGER :: nstack(19) ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdig, fmdiv, fmdivi, fmdpm, fmeq, fmeq2, & fmexit, fmgcdi, fmi2m, fmim, fmipwr, fmm2dp, fmmpyi, fmntr, fmntri, & fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons ncall = ncall + 1 namest(ncall) = 'FMRPWR' IF (ntrace/=0) THEN CALL fmntr(2,ma,ma,1) CALL fmntri(2,ival,0) CALL fmntri(2,jval,0) END IF kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN xval = max(abs(ival),abs(jval)) k = int((5.0*real(dlogtn)+2.0*log(xval))/alogmb+2.0) ndig = max(ndig+k,2) ELSE xval = max(abs(ival),abs(jval)) k = int(log(xval)/alogmb+1.0) ndig = ndig + k END IF 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) ncall = ncall - 1 RETURN END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 ma1 = ma(1) ma2 = ma(2) macca = ma(0) CALL fmeq2(ma,m02,ndsave,ndig,0) m02(0) = nint(ndig*alogm2) ! Use GCD-reduced positive exponents. ijsign = 1 ival2 = abs(ival) jval2 = abs(jval) IF (ival>0 .AND. jval<0) ijsign = -1 IF (ival<0 .AND. jval>0) ijsign = -1 IF (ival2>0 .AND. jval2>0) CALL fmgcdi(ival2,jval2) ! Check for special cases. 10 IF (ma1==munkno .OR. jval2==0 .OR. (ijsign<=0 .AND. ma2==0)) THEN CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -4 GO TO 30 END IF IF (ival2==0) THEN CALL fmim(1,mb) GO TO 30 END IF IF (jval2==1) THEN CALL fmipwr(m02,ijsign*ival2,mb) GO TO 30 END IF IF (ma2==0) THEN CALL fmeq(ma,mb) GO TO 30 END IF IF (ma2<0) THEN IF (mod(jval2,2)==0) THEN jval2 = 0 GO TO 10 END IF END IF IF (ma1==mexpov) THEN IF (ival20) THEN mb(1) = mexpov mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -5 ELSE IF (ijsign==-1 .AND. ma2>0) THEN mb(1) = mexpun mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -6 ELSE IF (ijsign==1 .AND. ma2<0) THEN IF (mod(ival2,2)==0) THEN mb(1) = mexpov mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -5 ELSE mb(1) = mexpov mb(2) = -1 mb(0) = nint(ndig*alogm2) kflag = -5 END IF ELSE IF (ijsign==-1 .AND. ma2<0) THEN IF (mod(ival2,2)==0) THEN mb(1) = mexpun mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -6 ELSE mb(1) = mexpun mb(2) = -1 mb(0) = nint(ndig*alogm2) kflag = -6 END IF END IF GO TO 30 END IF IF (ma1==mexpun) THEN IF (ival20) THEN mb(1) = mexpun mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -6 ELSE IF (ijsign==-1 .AND. ma2>0) THEN mb(1) = mexpov mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -5 ELSE IF (ijsign==1 .AND. ma2<0) THEN IF (mod(ival2,2)==0) THEN mb(1) = mexpun mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -6 ELSE mb(1) = mexpun mb(2) = -1 mb(0) = nint(ndig*alogm2) kflag = -6 END IF ELSE IF (ijsign==-1 .AND. ma2<0) THEN IF (mod(ival2,2)==0) THEN mb(1) = mexpov mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -5 ELSE mb(1) = mexpov mb(2) = -1 mb(0) = nint(ndig*alogm2) kflag = -5 END IF END IF GO TO 30 END IF ! Invert MA if MA > 1 and IVAL or JVAL is large. invert = 0 IF (ma(1)>0) THEN IF (ival>5 .OR. jval>5) THEN invert = 1 CALL fmi2m(1,m01) CALL fmdiv(m01,m02,m02) END IF END IF ! Generate the first approximation to ABS(MA)**(1/JVAL2). ma1 = m02(1) m02(1) = 0 m02(2) = abs(m02(2)) CALL fmm2dp(m02,x) l = int(ma1/jval2) f = ma1/dble(jval2) - l x = x**(1.0D0/jval2)*dble(mbase)**f CALL fmdpm(x,mb) mb(1) = mb(1) + l m02(1) = ma1 ! Initialize. CALL fmdig(nstack,kst) ! Newton iteration. DO 20 j = 1, kst ndig = nstack(j) IF (j15) THEN CALL fmim(0,mc) mc(1) = munkno mc(2) = 1 mc(0) = maccab kflag = kfsave RETURN END IF RETURN END SUBROUTINE fmrslt 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwrnsv ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmim, fmntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 ncall = ncall + 1 namest(ncall) = 'FMSIGN' IF (ntrace/=0) CALL fmntr(2,ma,mb,2) kwrnsv = kwarn kwarn = 0 IF (ma(1)==munkno .OR. mb(1)==munkno) THEN CALL fmim(0,mc) mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) kflag = -4 ELSE IF (mb(2)>=0) THEN CALL fmeq(ma,mc) mc(2) = abs(mc(2)) ELSE CALL fmeq(ma,mc) mc(2) = -abs(mc(2)) END IF kwarn = kwrnsv IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END SUBROUTINE fmsign SUBROUTINE fmsin(ma,mb) ! MB = SIN(MA) IMPLICIT NONE ! Scratch array usage during FMSIN: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, macmax, mxsave INTEGER :: jcos, jsin, jswap, k, kasave, kovun, kreslt, ndsave, ndsv ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmcos2, fmdivi, fmentr, fmeq2, fmexit, fmi2m, fmmpy, & fmntr, fmpi, fmrdc, fmrslt, fmsin2, fmsqr, fmsqrt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)==0) THEN CALL fmentr('FMSIN ',ma,ma,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) ma2 = ma(2) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) mb(2) = abs(mb(2)) ! Reduce the argument, convert to radians if the input is ! in degrees, and evaluate the function. CALL fmrdc(mb,mb,jsin,jcos,jswap) IF (mb(1)==munkno) GO TO 10 IF (krad==0) THEN IF (mbspi/=mbase .OR. ndigpindg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mb(j+1) = 0 10 CONTINUE ndig = ndsave kwarn = kwrnsv RETURN END IF ndsav1 = ndig ! Divide the argument by 3**K2. CALL fmeq2(ma,m02,ndsave,ndig,0) kthree = 1 maxval = mxbase/3 IF (k2>0) THEN DO 20 j = 1, k2 kthree = 3*kthree IF (kthree>maxval) THEN CALL fmdivi(m02,kthree,m02) kthree = 1 END IF 20 CONTINUE IF (kthree>1) CALL fmdivi(m02,kthree,m02) END IF ! 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 30 j = 1, j2 nbot = nterm*(nterm-1) IF (nbot>1) CALL fmdivi(m03,nbot,m03) nterm = nterm + 2 kpt = (j-1)*(ndig+2) CALL fmeq(m03,mjsums(kpt)) m03(2) = -m03(2) 30 CONTINUE CALL fmsqr(m02,m02) IF (m02(1)<-ndig) GO TO 60 CALL fmipwr(m02,j2,mb) 40 CALL fmmpy(m03,mb,m03) large = int(intmax/nterm) DO 50 j = 1, j2 nbot = nterm*(nterm-1) IF (nterm>large .OR. nbot>mxbase) THEN CALL fmdivi(m03,nterm,m03) nbot = nterm - 1 CALL fmdivi(m03,nbot,m03) ELSE CALL fmdivi(m03,nbot,m03) END IF kpt = (j-1)*(ndsav1+2) ndig = ndsav1 CALL fmadd(mjsums(kpt),m03,mjsums(kpt)) IF (kflag/=0) GO TO 60 ndig = ndsav1 - int(mjsums(kpt+1)-m03(1)) IF (ndig<2) ndig = 2 m03(2) = -m03(2) nterm = nterm + 2 50 CONTINUE GO TO 40 ! Next put the J2 separate sums back together. 60 kflag = 0 kpt = (j2-1)*(ndig+2) CALL fmeq(mjsums(kpt),mb) IF (j2>=2) THEN DO 70 j = 2, j2 CALL fmmpy(m02,mb,mb) kpt = (j2-j)*(ndig+2) CALL fmadd(mb,mjsums(kpt),mb) 70 CONTINUE END IF ! Reverse the effect of reducing the argument to ! compute SIN(MA). ndig = ndsav1 IF (k2>0) THEN CALL fmi2m(3,m02) DO 80 j = 1, k2 CALL fmsqr(mb,m03) CALL fmmpyi(m03,-4,m03) CALL fmadd(m02,m03,m03) CALL fmmpy(m03,mb,mb) 80 CONTINUE END IF CALL fmeq2(mb,mb,ndsav1,ndsave,1) ndig = ndsave kwarn = kwrnsv RETURN END SUBROUTINE fmsin2 SUBROUTINE fmsinh(ma,mb) ! MB = SINH(MA) IMPLICIT NONE ! Scratch array usage during FMSINH: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, macmax, mxsave INTEGER :: k, kasave, kovun, kreslt, ndsave, nmethd ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmcsh2, fmdiv, fmdivi, fmentr, fmeq, fmeq2, fmexit, & fmexp, fmi2m, fmntr, fmrslt, fmsnh2, fmsqr, fmsqrt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab) THEN CALL fmentr('FMSINH',ma,ma,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) ma2 = ma(2) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) mb(2) = abs(mb(2)) IF (ma2==0) THEN CALL fmeq(ma,mb) GO TO 20 END IF ! Use a series for small arguments, FMEXP for large ones. IF (mb(1)==munkno) GO TO 20 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 END IF ELSE IF (mb(1)<=0) THEN nmethd = 1 ELSE nmethd = 2 END IF END IF IF (nmethd==2) GO TO 10 IF (mb(1)<0 .OR. ndig<=50) THEN CALL fmsnh2(mb,mb) ELSE CALL fmcsh2(mb,mb) CALL fmi2m(1,m03) CALL fmsqr(mb,mb) CALL fmsub(mb,m03,mb) CALL fmsqrt(mb,mb) END IF GO TO 20 10 CALL fmexp(mb,mb) IF (mb(1)==mexpov) THEN GO TO 20 ELSE IF (mb(1)==mexpun) THEN mb(1) = mexpov GO TO 20 END IF IF (int(mb(1))<=(ndig+1)/2) THEN CALL fmi2m(1,m01) CALL fmdiv(m01,mb,m01) CALL fmsub(mb,m01,mb) END IF CALL fmdivi(mb,2,mb) ! Round and return. 20 macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) IF (ma2<0 .AND. mb(1)/=munkno) mb(2) = -mb(2) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmsinh SUBROUTINE fmsnh2(ma,mb) ! Internal subroutine for MB = SINH(MA). IMPLICIT NONE ! Scratch array usage during FMSNH2: M01 - M03 ! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent ! sums. Increasing this value will begin to improve the ! speed of SINH when the base is large and precision exceeds ! about 1,500 decimal digits. ! .. Intrinsic Functions .. INTRINSIC int, log, max, min, nint, real, sqrt ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL :: alog3, alogt, b, t, tj REAL (KIND(0.0D0)) :: maxval INTEGER :: j, j2, k, k2, kpt, kthree, kwrnsv, l, l2, large, n2, nbot, & ndsav1, ndsave, nterm ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdivi, fmeq, fmeq2, fmi2m, fmipwr, fmmpy, & fmmpyi, fmsqr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mjsums(0:ljsums), & mlbsav(0:lunpck), mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), & mln4(0:lunpck), mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmsums/mjsums COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (ma(2)==0) THEN CALL fmeq(ma,mb) RETURN END IF 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) END IF IF (j2<=1) j2 = 1 n2 = int(t*alogmb/(alogt+real(l)*alog3)) l2 = int(log(real(n2)+3.0**k2)/alogmb) ndig = ndig + l2 IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mb(j+1) = 0 10 CONTINUE ndig = ndsave kwarn = kwrnsv RETURN END IF ndsav1 = ndig ! Divide the argument by 3**K2. CALL fmeq2(ma,m02,ndsave,ndig,0) kthree = 1 maxval = mxbase/3 IF (k2>0) THEN DO 20 j = 1, k2 kthree = 3*kthree IF (kthree>maxval) THEN CALL fmdivi(m02,kthree,m02) kthree = 1 END IF 20 CONTINUE IF (kthree>1) CALL fmdivi(m02,kthree,m02) END IF ! 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 30 j = 1, j2 nbot = nterm*(nterm-1) IF (nbot>1) CALL fmdivi(m03,nbot,m03) nterm = nterm + 2 kpt = (j-1)*(ndig+2) CALL fmeq(m03,mjsums(kpt)) 30 CONTINUE CALL fmsqr(m02,m02) IF (m02(1)<-ndig) GO TO 60 CALL fmipwr(m02,j2,mb) 40 CALL fmmpy(m03,mb,m03) large = int(intmax/nterm) DO 50 j = 1, j2 nbot = nterm*(nterm-1) IF (nterm>large .OR. nbot>mxbase) THEN CALL fmdivi(m03,nterm,m03) nbot = nterm - 1 CALL fmdivi(m03,nbot,m03) ELSE CALL fmdivi(m03,nbot,m03) END IF kpt = (j-1)*(ndsav1+2) ndig = ndsav1 CALL fmadd(mjsums(kpt),m03,mjsums(kpt)) IF (kflag/=0) GO TO 60 ndig = ndsav1 - int(mjsums(kpt+1)-m03(1)) IF (ndig<2) ndig = 2 nterm = nterm + 2 50 CONTINUE GO TO 40 ! Next put the J2 separate sums back together. 60 kflag = 0 kpt = (j2-1)*(ndig+2) CALL fmeq(mjsums(kpt),mb) IF (j2>=2) THEN DO 70 j = 2, j2 CALL fmmpy(m02,mb,mb) kpt = (j2-j)*(ndig+2) CALL fmadd(mb,mjsums(kpt),mb) 70 CONTINUE END IF ! Reverse the effect of reducing the argument to ! compute SINH(MA). ndig = ndsav1 IF (k2>0) THEN CALL fmi2m(3,m02) DO 80 j = 1, k2 CALL fmsqr(mb,m03) CALL fmmpyi(m03,4,m03) CALL fmadd(m02,m03,m03) CALL fmmpy(m03,mb,mb) 80 CONTINUE END IF CALL fmeq2(mb,mb,ndsav1,ndsave,1) ndig = ndsave kwarn = kwrnsv RETURN END SUBROUTINE fmsnh2 SUBROUTINE fmsp2m(x,ma) ! MA = X ! Convert a single precision number to FM format. ! In general the relative accuracy of the 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dble, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: xdp, y, yt INTEGER :: k ! .. ! .. External Subroutines .. EXTERNAL fmdivi, fmdm, fmim, fmntr, fmntrr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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)mexpab .OR. kdebug==1) 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 END IF GO TO 140 ELSE IF (ma(2)==0) THEN CALL fmeq(ma,mb) GO TO 140 END IF kflag = 0 maxmax = 0 macca = ma(0) ma2 = ma(2) n1 = ndig + 1 mwa(1) = ma(1) + ma(1) ! NGUARD is the number of guard digits used. IF (ncall>1) THEN nguard = ngrd22 IF (nguard>ndig) nguard = ndig ELSE nguard = ngrd52 IF (nguard>ndig) nguard = ndig END IF IF (ma(2)*ma(2)1) THEN mbj = ma(2) ! Count the trailing zeros in MA. IF (ma(n1)/=0) THEN knz = n1 ELSE DO 10 j = ndig, 2, -1 IF (ma(j)/=0) THEN knz = j GO TO 20 END IF 10 CONTINUE END IF 20 mwa(2) = 0 mwa(3) = 0 DO 30 k = ndig + 2, l mwa(k) = 0 30 CONTINUE ! (Inner Loop) DO 40 k = 3, n1 mwa(k+1) = ma(k)*mbj 40 CONTINUE maxmwa = mbj DO 70 j = 3, l/2 mbj = ma(j) IF (mbj/=0) THEN maxmwa = maxmwa + mbj jm1 = j - 1 kl = min(knz,l-jm1) ! Major (Inner Loop) DO 50 k = 2*j, jm1 + kl mwa(k) = mwa(k) + ma(k-jm1)*mbj 50 CONTINUE END IF IF (maxmwa>mmax) THEN maxmax = max(maxmax,maxmwa) maxmwa = 0 ! Normalization is only required for the ! range of digits currently changing in MWA. DO 60 kb = jm1 + kl, 2*j, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase 60 CONTINUE END IF 70 CONTINUE ! Double MWA, add the square terms, and perform ! the final normalization. (Inner Loop) IF (2*max(maxmax,maxmwa)+mbase>mmax) THEN DO 80 kb = l, 4, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase 80 CONTINUE END IF DO 90 j = 3, l - 1, 2 mka = ma((j+1)/2) mwa(j) = 2*mwa(j) + mka*mka mwa(j+1) = 2*mwa(j+1) 90 CONTINUE IF (mod(l,2)==1) THEN mka = ma((l+1)/2) mwa(l) = 2*mwa(l) + mka*mka END IF DO 100 kb = l, 3, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase 100 CONTINUE ELSE ! If normalization must be done for each digit, combine ! the two loops and normalize as the digits are multiplied. DO 110 j = 2, l mwa(j) = 0 110 CONTINUE kj = ndig + 2 DO 130 j = 2, n1 kj = kj - 1 mbkj = ma(kj) IF (mbkj==0) GO TO 130 kl = l - kj + 1 IF (kl>n1) kl = n1 ki = kl + 2 kwa = kl + kj + 1 mk = 0 DO 120 k = 2, kl mt = ma(ki-k)*mbkj + mwa(kwa-k) + mk mk = int(mt/mbase) mwa(kwa-k) = mt - mbase*mk 120 CONTINUE mwa(kwa-kl-1) = mk 130 CONTINUE END IF ! Set KSHIFT = 1 if a shift left is necessary. IF (mwa(2)==0) THEN kshift = 1 ELSE kshift = 0 END IF ! The multiplication is complete. ! Round the result and move it to MB. ma(2) = ma2 mr = 2*mwa(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwa(n1+kshift)1) THEN mwa(n1+kshift) = mwa(n1+kshift) + 1 mwa(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,kshift) END IF END IF CALL fmmove(mwa,mb) IF (kflag<0) THEN namest(ncall) = 'FMSQR ' CALL fmwarn END IF 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 END IF 140 RETURN END SUBROUTINE fmsqr2 SUBROUTINE fmsqrt(ma,mb) ! MB = SQRT(MA) IMPLICIT NONE ! Scratch array usage during FMSQRT: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, mod, nint, real, sqrt ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma1, macca, md2b, mke, mxsave REAL (KIND(0.0D0)) :: x, xb INTEGER :: j, k, kasave, kma1, kovun, kreslt, kst, ndsave ! .. ! .. Local Arrays .. INTEGER :: nstack(19) ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdig, fmdiv, fmdivi, fmdpm, fmentr, fmeq2, & fmexit, fmm2dp, fmntr, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)<=0) THEN CALL fmentr('FMSQRT',ma,ma,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) END IF 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF ma1 = ma(1) macca = ma(0) CALL fmeq2(ma,m02,ndsave,ndig,0) m02(0) = nint(ndig*alogm2) ! Generate the first approximation. m02(1) = 0 CALL fmm2dp(m02,x) x = sqrt(x) mke = ma1/2 kma1 = int(abs(ma1)) IF (mod(kma1,2)==1) THEN xb = mbase x = x*sqrt(xb) mke = (ma1-1)/2 END IF CALL fmdpm(x,mb) mb(1) = mb(1) + mke ! Initialize. m02(1) = ma1 CALL fmdig(nstack,kst) ! Newton iteration. DO 10 j = 1, kst ndig = nstack(j) CALL fmdiv(m02,mb,m01) CALL fmadd(mb,m01,mb) CALL fmdivi(mb,2,mb) 10 CONTINUE ! 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 END IF CALL fmexit(mb,mb,ndsave,mxsave,kasave,0) RETURN END SUBROUTINE fmsqrt 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC len ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, lb ! .. ! .. External Subroutines .. EXTERNAL fmcons, fminp ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons ncall = ncall + 1 namest(ncall) = 'FMST2M' lb = len(string) DO 10 j = 1, lb cmbuff(j) = string(j:j) 10 CONTINUE CALL fminp(cmbuff,ma,1,lb) ncall = ncall - 1 RETURN END SUBROUTINE fmst2m SUBROUTINE fmsub(ma,mb,mc) ! MC = MA - MB IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kflg1 ! .. ! .. External Subroutines .. EXTERNAL fmadd2, fmntr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMSUB ' IF (ntrace/=0) CALL fmntr(2,ma,mb,2) 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) 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 END IF ncall = ncall - 1 RETURN END SUBROUTINE fmsub SUBROUTINE fmtan(ma,mb) ! MB = TAN(MA) IMPLICIT NONE ! Scratch array usage during FMTAN: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, macmax, mxsave INTEGER :: jcos, jsin, jswap, k, kasave, kovun, kreslt, ndsave, ndsv ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmcos2, fmdiv, fmdivi, fmentr, fmeq2, fmexit, fmi2m, & fmim, fmmpy, fmntr, fmpi, fmrdc, fmrslt, fmsin2, fmsqr, fmsqrt, fmsub, & fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)==0) THEN CALL fmentr('FMTAN ',ma,ma,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) ma2 = ma(2) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) mb(2) = abs(mb(2)) ! Reduce the argument, convert to radians if the input is ! in degrees, and evaluate the function. CALL fmrdc(mb,mb,jsin,jcos,jswap) IF (mb(1)==munkno) GO TO 10 IF (mb(2)==0) THEN IF (jswap==1) THEN CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -4 CALL fmwarn END IF GO TO 10 END IF IF (krad==0) THEN IF (mbspi/=mbase .OR. ndigpimexpab) THEN CALL fmentr('FMTANH',ma,ma,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) 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) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF kwrnsv = kwarn kwarn = 0 ma2 = ma(2) macca = ma(0) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) mb(2) = abs(mb(2)) IF (ma(2)==0) THEN CALL fmeq(ma,mb) GO TO 10 END IF 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 10 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 10 END IF END IF END IF IF (mb(1)==0 .AND. ndig<50) THEN CALL fmexp2(mb,mb) CALL fmsqr(mb,mb) CALL fmi2m(1,m02) CALL fmsub(mb,m02,m03) CALL fmadd(mb,m02,m02) CALL fmdiv(m03,m02,mb) GO TO 10 END IF IF (mb(1)>=0 .AND. mb(2)/=0) THEN CALL fmcosh(mb,mb) IF (mb(1)>ndig) THEN IF (ma2>0) THEN CALL fmi2m(1,mb) GO TO 10 ELSE CALL fmi2m(-1,mb) GO TO 10 END IF END IF CALL fmsqr(mb,m03) CALL fmi2m(-1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,m03) CALL fmdiv(m03,mb,mb) ELSE CALL fmsinh(mb,mb) CALL fmsqr(mb,m03) CALL fmi2m(1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,m03) CALL fmdiv(mb,m03,mb) END IF ! Round and return. 10 kwarn = kwrnsv macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) IF (ma2<0 .AND. mb(1)/=munkno) mb(2) = -mb(2) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmtanh SUBROUTINE fmtrap(ma) ! If MA has overflowed or underflowed, replace it by the appropriate ! symbol. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (ncall<=0) RETURN IF (ma(1)>mxexp+1) THEN ma(1) = mexpov IF (ma(2)>0) THEN ma(2) = 1 ELSE ma(2) = -1 END IF ma(0) = nint(ndig*alogm2) kflag = -5 END IF IF (ma(1)<-mxexp) THEN ma(1) = mexpun IF (ma(2)>0) THEN ma(2) = 1 ELSE ma(2) = -1 END IF ma(0) = nint(ndig*alogm2) kflag = -6 END IF 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma1 INTEGER :: j, kwrnsv, n1 ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmim, fmmove, fmntr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons kflag = 0 ncall = ncall + 1 namest(ncall) = 'FMULP ' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) ma1 = ma(1) n1 = ndig + 1 DO 10 j = 3, n1 mwa(j) = 0 10 CONTINUE mwa(2) = 1 IF (ma(2)<0) mwa(2) = -1 mwa(1) = ma(1) - ndig + 1 IF (ma(2)==0 .OR. ma(1)>=mexpov) THEN CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -4 IF (ma1/=munkno) CALL fmwarn ELSE kwrnsv = kwarn IF (ma1==mexpun) kwarn = 0 CALL fmmove(mwa,mb) IF (kflag<0) THEN namest(ncall) = 'FMULP ' CALL fmwarn END IF kwarn = kwrnsv END IF mb(0) = nint(ndig*alogm2) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END SUBROUTINE fmulp SUBROUTINE fmunpk(mp,ma) ! MP is unpacked and the value returned in MA. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, mod ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mp(0:lpack) ! .. ! .. Local Scalars .. INTEGER :: j, kp ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kp = 2 ma(0) = mp(0) ma(1) = mp(1) ma(2) = dint(abs(mp(2))/mbase) ma(3) = abs(mp(2)) - ma(2)*mbase IF (mp(2)<0) ma(2) = -ma(2) IF (ndig>=4) THEN DO 10 j = 4, ndig, 2 kp = kp + 1 ma(j) = dint(mp(kp)/mbase) ma(j+1) = mp(kp) - ma(j)*mbase 10 CONTINUE END IF IF (mod(ndig,2)==1) ma(ndig+1) = dint(mp(kp+1)/mbase) RETURN END SUBROUTINE fmunpk SUBROUTINE fmwarn ! Called by one of the FM routines to print a warning message ! if any error condition arises in that routine. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Local Scalars .. INTEGER :: ncs CHARACTER (6) :: name ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (kflag>=0 .OR. ncall/=1 .OR. kwarn<=0) RETURN ncs = ncall name = namest(ncall) WRITE (kw,90000) kflag, name 10 ncall = ncall - 1 IF (ncall>0) THEN name = namest(ncall) WRITE (kw,90010) name GO TO 10 END IF IF (kflag==-1) THEN WRITE (kw,90020) ndigmx ELSE IF (kflag==-2) THEN WRITE (kw,90030) int(mxbase) ELSE IF (kflag==-3) THEN WRITE (kw,90040) WRITE (kw,90050) ELSE IF (kflag==-4 .OR. kflag==-7) THEN WRITE (kw,90060) WRITE (kw,90050) ELSE IF (kflag==-5) THEN WRITE (kw,90070) ELSE IF (kflag==-6) THEN WRITE (kw,90080) ELSE IF (kflag==-8 .AND. name=='FMOUT ') THEN WRITE (kw,90090) ELSE IF (kflag==-8 .AND. name=='FMREAD') THEN WRITE (kw,90100) ELSE IF (kflag==-9) THEN WRITE (kw,90110) WRITE (kw,90120) ndig, ndg2mx WRITE (kw,90050) ELSE IF (kflag==-10) THEN IF (namest(ncs)=='FMM2SP') THEN WRITE (kw,90130) ELSE WRITE (kw,90140) END IF WRITE (kw,90150) END IF ncall = ncs IF (kwarn>=2) THEN STOP END IF RETURN 90000 FORMAT (/' Error of type KFLAG =',I3,' in FM package in routine ',A6/) 90010 FORMAT (' called from ',A6) 90020 FORMAT (' NDIG must be between 2 and',I10/) 90030 FORMAT (' MBASE must be between 2 and',I10/) 90040 FORMAT (' An input argument is not a valid FM number.', & ' Its exponent is out of range.'/) 90050 FORMAT (' UNKNOWN has been returned.'/) 90060 FORMAT (' Invalid input argument for this routine.'/) 90070 FORMAT (' The result has overflowed.'/) 90080 FORMAT (' The result has underflowed.'/) 90090 FORMAT (' The result array is not big enough to hold the', & ' output character string'/' in the current format.'/ & ' The result ''***...***'' has been returned.'/) 90100 FORMAT (' The CMBUFF array is not big enough to hold the', & ' input character string'/' UNKNOWN has been returned.'/) 90110 FORMAT (' Precision could not be raised enough to provide all', & ' requested guard digits.'/) 90120 FORMAT (I23,' digits were requested (NDIG).'/ & ' Maximum number of digits currently available',' (NDG2MX) is',I7, & '.'/) 90130 FORMAT (' An FM number was too small in magnitude to ', & 'convert to single precision.'/) 90140 FORMAT (' An FM number was too small in magnitude to ', & 'convert to double precision.'/) 90150 FORMAT (' Zero has been returned.'/) 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. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int, log10, max, min, mod, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kwrite ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, jf1sav, jf2sav, k, ksave, l, last, lb, nd, ndsave, nexp ! .. ! .. External Subroutines .. EXTERNAL fmeq2, fmout ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMWRIT' ndsave = ndig ndig = min(ndg2mx,max(ndig+ngrd52,2)) CALL fmeq2(ma,m01,ndsave,ndig,0) ksave = kflag nd = int(real(ndig)*log10(real(mbase))) + 1 IF (nd<2) nd = 2 nexp = int(2.0*log10(real(mxbase))) + 6 lb = min(nd+nexp,lmbuff) jf1sav = jform1 jf2sav = jform2 jform1 = 1 jform2 = nd + 6 CALL fmout(m01,cmbuff,lb) kflag = ksave ndig = ndsave jform1 = jf1sav jform2 = jf2sav last = lb + 1 DO 10 j = 1, lb IF (cmbuff(last-j)/=' ' .OR. j==lb) THEN l = last - j IF (mod(l,73)/=0) THEN WRITE (kwrite,90000) (cmbuff(k),k=1,l) ELSE IF (l>73) WRITE (kwrite,90000) (cmbuff(k),k=1,l-73) WRITE (kwrite,90010) (cmbuff(k),k=l-72,l) END IF ncall = ncall - 1 RETURN END IF 10 CONTINUE ncall = ncall - 1 RETURN 90000 FORMAT (4X,73A1,' &') 90010 FORMAT (4X,73A1) END SUBROUTINE fmwrit ! Here are the routines that work with packed FM numbers. All names ! are the same as unpacked versions with 'FM' replaced by 'FP'. ! To convert a program using the FM package from unpacked calls to ! packed calls make these changes to the program: ! '(0:LUNPCK)' to '(0:LPACK)' in dimensions. ! 'CALL FM' to 'CALL FP' ! 'FMCOMP' to 'FPCOMP'. SUBROUTINE fpabs(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmabs, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmabs(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpabs SUBROUTINE fpacos(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmacos, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmacos(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpacos SUBROUTINE fpadd(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmadd(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpadd SUBROUTINE fpaddi(ma,l) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: l ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmaddi, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmaddi(mx,l) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpaddi SUBROUTINE fpasin(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmasin, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmasin(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpasin SUBROUTINE fpatan(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmatan, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmatan(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpatan SUBROUTINE fpatn2(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmatn2, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmatn2(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpatn2 SUBROUTINE fpbig(ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmbig, fmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmbig(mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpbig SUBROUTINE fpchsh(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmchsh, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmchsh(mx,my,mx) CALL fmpack(my,mb) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpchsh FUNCTION fpcomp(ma,lrel,mb) IMPLICIT NONE ! .. Function Return Value .. LOGICAL :: fpcomp ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (2) :: lrel ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) fpcomp = fmcomp(mx,lrel,my) RETURN END FUNCTION fpcomp SUBROUTINE fpcos(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmcos, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmcos(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpcos SUBROUTINE fpcosh(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmcosh, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmcosh(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpcosh SUBROUTINE fpcssn(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmcssn, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmcssn(mx,my,mx) CALL fmpack(my,mb) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpcssn SUBROUTINE fpdig(nstack,kst) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kst ! .. ! .. Array Arguments .. INTEGER :: nstack(19) ! .. ! .. External Subroutines .. EXTERNAL fmdig ! .. CALL fmdig(nstack,kst) RETURN END SUBROUTINE fpdig SUBROUTINE fpdim(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmdim, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmdim(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpdim SUBROUTINE fpdiv(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmdiv, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmdiv(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpdiv SUBROUTINE fpdivi(ma,ival,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmdivi, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmdivi(mx,ival,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpdivi SUBROUTINE fpdp2m(x,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmdp2m(x,mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpdp2m SUBROUTINE fpdpm(x,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmdpm, fmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmdpm(x,mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpdpm SUBROUTINE fpeq(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmeq(mx,my) CALL fmpack(my,mb) RETURN END SUBROUTINE fpeq SUBROUTINE fpequ(ma,mb,nda,ndb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: nda, ndb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. Local Scalars .. INTEGER :: ndasav, ndbsav, ndgsav ! .. ! .. External Subroutines .. EXTERNAL fmeq2, fmpack, fmunpk ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ndgsav = ndig ndasav = nda ndbsav = ndb ndig = ndasav CALL fmunpk(ma,mx) CALL fmeq2(mx,mx,ndasav,ndbsav,1) ndig = ndbsav CALL fmpack(mx,mb) nda = ndasav ndb = ndbsav ndig = ndgsav RETURN END SUBROUTINE fpequ SUBROUTINE fpexp(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmexp, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmexp(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpexp SUBROUTINE fpform(form,ma,string) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: form, string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmform, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmform(form,mx,string) RETURN END SUBROUTINE fpform SUBROUTINE fpfprt(form,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: form ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmfprt, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmfprt(form,mx) RETURN END SUBROUTINE fpfprt SUBROUTINE fpi2m(ival,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmi2m(ival,mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpi2m SUBROUTINE fpinp(line,ma,la,lb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: la, lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) CHARACTER (1) :: line(lb) ! .. ! .. External Subroutines .. EXTERNAL fminp, fmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fminp(line,mx,la,lb) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpinp SUBROUTINE fpint(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmint, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmint(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpint SUBROUTINE fpipwr(ma,ival,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmipwr, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmipwr(mx,ival,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpipwr SUBROUTINE fplg10(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmlg10, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmlg10(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fplg10 SUBROUTINE fpln(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmln, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmln(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpln SUBROUTINE fplni(ival,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmlni, fmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmlni(ival,mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fplni SUBROUTINE fpm2dp(ma,x) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmm2dp, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmm2dp(mx,x) RETURN END SUBROUTINE fpm2dp SUBROUTINE fpm2i(ma,ival) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmm2i, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmm2i(mx,ival) RETURN END SUBROUTINE fpm2i SUBROUTINE fpm2sp(ma,x) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmm2sp, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmm2sp(mx,x) RETURN END SUBROUTINE fpm2sp SUBROUTINE fpmax(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmmax, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmmax(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpmax SUBROUTINE fpmin(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmmin, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmmin(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpmin SUBROUTINE fpmod(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmmod, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmmod(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpmod SUBROUTINE fpmpy(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmmpy, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmmpy(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpmpy SUBROUTINE fpmpyi(ma,ival,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmmpyi, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmmpyi(mx,ival,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpmpyi SUBROUTINE fpnint(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmnint, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmnint(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpnint SUBROUTINE fpout(ma,line,lb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) CHARACTER (1) :: line(lb) ! .. ! .. External Subroutines .. EXTERNAL fmout, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmout(mx,line,lb) RETURN END SUBROUTINE fpout SUBROUTINE fppi(ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmpi ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmpi(mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fppi SUBROUTINE fpprnt(ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmprnt, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmprnt(mx) RETURN END SUBROUTINE fpprnt SUBROUTINE fppwr(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmpwr, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmpwr(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fppwr SUBROUTINE fpread(kread,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kread ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmread ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmread(kread,mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpread SUBROUTINE fprpwr(ma,kval,jval,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: jval, kval ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmrpwr, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmrpwr(mx,kval,jval,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fprpwr SUBROUTINE fpset(nprec) ! .. Scalar Arguments .. INTEGER :: nprec ! .. ! .. External Subroutines .. EXTERNAL fmset ! .. CALL fmset(nprec) RETURN END SUBROUTINE fpset SUBROUTINE fpsign(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmsign, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmsign(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpsign SUBROUTINE fpsin(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmsin, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmsin(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpsin SUBROUTINE fpsinh(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmsinh, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmsinh(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpsinh SUBROUTINE fpsp2m(x,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmsp2m ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmsp2m(x,mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpsp2m SUBROUTINE fpsqr(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmsqr, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmsqr(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpsqr SUBROUTINE fpsqrt(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmsqrt, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmsqrt(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpsqrt SUBROUTINE fpst2m(string,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmst2m ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmst2m(string,mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpst2m SUBROUTINE fpsub(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmsub, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmsub(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpsub SUBROUTINE fptan(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmtan, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmtan(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fptan SUBROUTINE fptanh(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmtanh, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmtanh(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fptanh SUBROUTINE fpulp(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmulp, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmulp(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpulp SUBROUTINE fpwrit(kwrite,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kwrite ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmunpk, fmwrit ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmwrit(kwrite,mx) RETURN END SUBROUTINE fpwrit ! The IM routines perform integer multiple-precision arithmetic. SUBROUTINE imabs(ma,mb) ! MB = ABS(MA) IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwrnsv, ndsave ! .. ! .. External Subroutines .. EXTERNAL imargs, imeq, imntr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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) END IF kflag = 0 kwrnsv = kwarn kwarn = 0 CALL imeq(ma,mb) mb(2) = abs(mb(2)) kwarn = kwrnsv IF (ntrace/=0) CALL imntr(1,mb,mb,1) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imabs SUBROUTINE imadd(ma,mb,mc) ! MC = MA + MB IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, min, nint, sign ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mda, mdab, mdb INTEGER :: j, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd2, fmwarn, imargs, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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) END IF kflag = 0 IF (ma(1)<=2) THEN IF (mb(1)>2 .OR. ma(1)<0 .OR. mb(1)<0) GO TO 10 IF (ma(1)<=1) THEN mda = ma(2) ELSE IF (ma(2)<0) THEN mda = ma(2)*mbase - ma(3) ELSE mda = ma(2)*mbase + ma(3) END IF IF (mb(1)<=1) THEN mdb = mb(2) ELSE IF (mb(2)<0) THEN mdb = mb(2)*mbase - mb(3) ELSE mdb = mb(2)*mbase + mb(3) END IF mdab = mda + mdb IF (abs(mdab)ndg2mx .OR. mb(1)>ndg2mx .OR. ma(1)<0 .OR. mb(1)<0) THEN IF (ma(1)==munkno .OR. mb(1)==munkno) THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 GO TO 50 END IF IF (ma(1)==mexpov) THEN mda = 1 IF ((sign(mda,ma(2))==sign(mda,mb(2))) .OR. (mb(2)==0)) THEN mc(0) = ma(0) mc(1) = ma(1) mc(2) = ma(2) mc(3) = ma(3) kflag = -5 GO TO 50 ELSE mc(0) = nint(ndg2mx*alogm2) mc(1) = munkno mc(2) = 1 mc(3) = 0 kflag = -4 namest(ncall) = 'IMADD ' CALL fmwarn GO TO 50 END IF END IF IF (mb(1)==mexpov) THEN mda = 1 IF ((sign(mda,mb(2))==sign(mda,ma(2))) .OR. (ma(2)==0)) THEN mc(0) = mb(0) mc(1) = mb(1) mc(2) = mb(2) mc(3) = mb(3) kflag = -5 GO TO 50 ELSE mc(0) = nint(ndg2mx*alogm2) mc(1) = munkno mc(2) = 1 mc(3) = 0 kflag = -4 namest(ncall) = 'IMADD ' CALL fmwarn GO TO 50 END IF END IF mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 namest(ncall) = 'IMADD ' CALL fmwarn GO TO 50 END IF IF (ma(1)>mb(1)) THEN ndig = int(ma(1)) + 1 IF (ndig<2 .OR. ndig>ndg2mx) ndig = 2 ma(ndig+1) = 0 DO 20 j = int(mb(1)) + 2, ndig + 1 mb(j) = 0 20 CONTINUE ELSE ndig = int(mb(1)) + 1 IF (ndig<2 .OR. ndig>ndg2mx) ndig = 2 mb(ndig+1) = 0 DO 30 j = int(ma(1)) + 2, ndig + 1 ma(j) = 0 30 CONTINUE END IF CALL fmadd2(ma,mb,mc) 40 IF (mc(1)>ndigmx) THEN IF (ncall==1 .OR. mc(1)>ndg2mx) THEN mc(0) = nint(ndg2mx*alogm2) mc(1) = mexpov IF (mc(2)>0) THEN mc(2) = 1 ELSE mc(2) = -1 END IF mc(3) = 0 kflag = -5 namest(ncall) = 'IMADD ' CALL fmwarn END IF END IF 50 IF (ntrace/=0) CALL imntr(1,mc,mc,1) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imadd SUBROUTINE imargs(kroutn,nargs,ma,mb) ! Check the input arguments to a routine for special cases. ! KROUTN - Name of the subroutine that was called ! NARGS - The number of input arguments (1 or 2) ! MA - First input argument ! MB - Second input argument (if NARGS is 2) IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: nargs CHARACTER (6) :: kroutn ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mbs INTEGER :: j, kwrnsv, last ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = -4 IF (ma(1)==munkno) RETURN IF (nargs==2) THEN IF (mb(1)==munkno) RETURN END IF 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,90000) int(mbs), int(mbase) CALL fmcons RETURN END IF ! 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 ma(0) = nint(ndg2mx*alogm2) ma(1) = munkno ma(2) = 1 ma(3) = 0 RETURN END IF END IF 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 mb(0) = nint(ndg2mx*alogm2) mb(1) = munkno mb(2) = 1 mb(3) = 0 RETURN END IF END IF END IF ! Check for properly normalized digits in the ! input arguments. IF (abs(ma(1)-int(ma(1)))/=0) kflag = 1 IF (ma(2)<=(-mbase) .OR. ma(2)>=mbase .OR. abs(ma(2)-int(ma(2)))/=0) & kflag = 2 IF (kdebug==0) GO TO 20 last = int(ma(1)) + 1 IF (ma(1)>lunpck) last = 3 DO 10 j = 3, last IF (ma(j)<0 .OR. ma(j)>=mbase .OR. abs(ma(j)-int(ma(j)))/=0) THEN kflag = j GO TO 20 END IF 10 CONTINUE 20 IF (kflag/=0) THEN j = kflag mbs = ma(j) 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, ') = ', mbs END IF ma(0) = nint(ndg2mx*alogm2) ma(1) = munkno ma(2) = 1 ma(3) = 0 IF (kwarn>=2) THEN STOP END IF RETURN END IF IF (nargs==2) THEN IF (abs(mb(1)-int(mb(1)))/=0) kflag = 1 IF (mb(2)<=(-mbase) .OR. mb(2)>=mbase .OR. abs(mb(2)-int(mb(2)))/=0) & kflag = 2 IF (kdebug==0) GO TO 40 last = int(mb(1)) + 1 IF (mb(1)>lunpck) last = 3 DO 30 j = 3, last IF (mb(j)<0 .OR. mb(j)>=mbase .OR. abs(mb(j)-int(mb(j)))/=0) THEN kflag = j GO TO 40 END IF 30 CONTINUE 40 IF (kflag/=0) THEN j = kflag mbs = mb(j) 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, ') = ', mbs END IF mb(0) = nint(ndg2mx*alogm2) mb(1) = munkno mb(2) = 1 mb(3) = 0 IF (kwarn>=2) THEN STOP END IF RETURN END IF END IF RETURN 90000 FORMAT (' MBASE was',I10,'. It has been changed to',I10,'.') END SUBROUTINE imargs SUBROUTINE imbig(ma) ! MA = The biggest representable IM integer. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j ! .. ! .. External Subroutines .. EXTERNAL fmcons, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'IMBIG ' IF (mblogs/=mbase) CALL fmcons kflag = 0 DO 10 j = 2, ndigmx + 1 ma(j) = mbase - 1 10 CONTINUE ma(1) = ndigmx ma(0) = nint(ndigmx*alogm2) IF (ntrace/=0) CALL imntr(1,ma,ma,1) ncall = ncall - 1 RETURN END SUBROUTINE imbig FUNCTION imcomp(ma,lrel,mb) ! Logical comparison of FM numbers MA and MB. ! LREL is a CHARACTER *2 description of the comparison to be done: ! LREL = 'EQ' returns IMCOMP = .TRUE. if MA.EQ.MB ! = 'NE', 'GE', 'GT', 'LE', 'LT' also work like a logical IF. ! Some compilers object to functions with side effects such as ! changing KFLAG or other common variables. Blocks of code that ! modify common 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. IMPLICIT NONE ! .. Function Return Value .. LOGICAL :: imcomp ! .. ! .. Intrinsic Functions .. INTRINSIC abs, int, max ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (2) :: lrel ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, jcomp, ndsave, nlast, ntrsav CHARACTER (2) :: jrel ! .. ! .. External Subroutines .. EXTERNAL imargs, imntrj, imprnt ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! 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,90000) ndsave = ndig IF (ntrace>0) THEN CALL imprnt(ma) WRITE (kw,90010) lrel CALL imprnt(mb) ELSE ndig = max(2,int(ma(1))) IF (ndig>ndg2mx) ndig = 2 IF (ma(1)<=1) ma(3) = 0 ntrsav = ntrace IF (ntrace<-2) ntrace = -2 CALL imntrj(ma,ndig) WRITE (kw,90010) lrel ndig = max(2,int(mb(1))) IF (ndig>ndg2mx) ndig = 2 IF (mb(1)<=1) mb(3) = 0 CALL imntrj(mb,ndig) ntrace = ntrsav END IF ndig = ndsave END IF ! DELETE STOP ! JCOMP will be 1 if MA.GT.MB ! 2 if MA.EQ.MB ! 3 if MA.LT.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') THEN jrel = 'EQ' ELSE IF (lrel=='ne') THEN jrel = 'NE' ELSE IF (lrel=='lt') THEN jrel = 'LT' ELSE IF (lrel=='gt') THEN jrel = 'GT' ELSE IF (lrel=='le') THEN jrel = 'LE' ELSE IF (lrel=='ge') THEN jrel = 'GE' ELSE imcomp = .FALSE. ! DELETE START kflag = -4 IF (ncall/=1 .OR. kwarn<=0) GO TO 30 ! DELETE STOP IF (kwarn<=0) GO TO 30 WRITE (kw,90020) lrel IF (kwarn>=2) THEN STOP END IF GO TO 30 END IF END IF IF (ma(1)==munkno .OR. mb(1)==munkno) THEN imcomp = .FALSE. ! DELETE START kflag = -4 ! DELETE STOP GO TO 30 END IF IF (abs(ma(1))==mexpov .AND. ma(1)==mb(1) .AND. ma(2)==mb(2)) THEN imcomp = .FALSE. ! DELETE START kflag = -4 IF (ncall/=1 .OR. kwarn<=0) GO TO 30 ! DELETE STOP IF (kwarn<=0) GO TO 30 WRITE (kw,90030) IF (kwarn>=2) THEN STOP END IF GO TO 30 END IF ! Check for zero. ! DELETE START kflag = 0 ! DELETE STOP IF (ma(2)==0) THEN jcomp = 2 IF (mb(2)<0) jcomp = 1 IF (mb(2)>0) jcomp = 3 GO TO 20 END IF IF (mb(2)==0) THEN jcomp = 1 IF (ma(2)<0) jcomp = 3 GO TO 20 END IF ! Check for opposite signs. IF (ma(2)>0 .AND. mb(2)<0) THEN jcomp = 1 GO TO 20 END IF IF (mb(2)>0 .AND. ma(2)<0) THEN jcomp = 3 GO TO 20 END IF ! See which one is larger in absolute value. IF (ma(1)>mb(1)) THEN jcomp = 1 GO TO 20 END IF IF (mb(1)>ma(1)) THEN jcomp = 3 GO TO 20 END IF nlast = int(ma(1)) + 1 IF (nlast>ndg2mx+1) nlast = 2 DO 10 j = 2, nlast IF (abs(ma(j))>abs(mb(j))) THEN jcomp = 1 GO TO 20 END IF IF (abs(mb(j))>abs(ma(j))) THEN jcomp = 3 GO TO 20 END IF 10 CONTINUE jcomp = 2 ! Now match the JCOMP value to the requested comparison. 20 IF (jcomp==1 .AND. ma(2)<0) THEN jcomp = 3 ELSE IF (jcomp==3 .AND. mb(2)<0) THEN jcomp = 1 END IF 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. 30 CONTINUE ! DELETE START IF (ntrace/=0) THEN IF (ncall<=lvltrc .AND. abs(ntrace)>=1) THEN IF (kflag==0) THEN WRITE (kw,90040) ncall, int(mbase) ELSE WRITE (kw,90050) ncall, int(mbase), kflag END IF IF (imcomp) THEN WRITE (kw,90060) ELSE WRITE (kw,90070) END IF END IF END IF ncall = ncall - 1 ! DELETE STOP RETURN 90000 FORMAT (' Input to IMCOMP') 90010 FORMAT (7X,'.',A2,'.') 90020 FORMAT (/' 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.'/) 90030 FORMAT (/' 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.'/) 90040 FORMAT (' IMCOMP',15X,'Call level =',I2,5X,'MBASE =',I10) 90050 FORMAT (' IMCOMP',6X,'Call level =',I2,4X,'MBASE =',I10,4X,'KFLAG =',I3) 90060 FORMAT (7X,'.TRUE.') 90070 FORMAT (7X,'.FALSE.') END FUNCTION imcomp SUBROUTINE imdim(ma,mb,mc) ! MC = DIM(MA,MB) ! Positive difference. MC = MA - MB if MA.GE.MB, ! = 0 otherwise. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kovfl ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL fmwarn, imargs, imntr, imsub ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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) END IF IF (ma(1)==munkno .OR. mb(1)==munkno) THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 GO TO 10 END IF IF (ma(1)<0 .OR. mb(1)<0) THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 namest(ncall) = 'IMDIM ' CALL fmwarn GO TO 10 END IF kovfl = 0 IF (ma(1)==mexpov .OR. mb(1)==mexpov) THEN kovfl = 1 IF (ma(1)==mexpov .AND. mb(1)==mexpov .AND. ma(2)==mb(2)) THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 namest(ncall) = 'IMDIM ' CALL fmwarn GO TO 10 END IF END IF IF (imcomp(ma,'GE',mb)) THEN CALL imsub(ma,mb,mc) IF (kflag==1) kflag = 0 ELSE mc(1) = 0 mc(2) = 0 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) END IF 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 mc(0) = nint(ndg2mx*alogm2) mc(1) = mexpov IF (mc(2)>0) THEN mc(2) = 1 ELSE mc(2) = -1 END IF mc(3) = 0 kflag = -5 namest(ncall) = 'IMDIM ' IF (kovfl/=1) CALL fmwarn END IF END IF 10 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. IMPLICIT NONE ! Scratch array usage during IMDIV: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: ndsave ! .. ! .. External Subroutines .. EXTERNAL fmwarn, imargs, imdivr, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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) END IF IF (ma(1)==munkno .OR. mb(1)==munkno) THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 GO TO 10 END IF CALL imdivr(ma,mb,mc,m03) IF (mc(1)==munkno) THEN kflag = -4 namest(ncall) = 'IMDIV ' CALL fmwarn END IF 10 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. IMPLICIT NONE ! Scratch array usage during IMDIVI: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: idiv ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: irem, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmwarn, imargs, imdvir, imntr, imntri ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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) END IF IF (ma(1)==munkno) THEN mb(1) = munkno mb(2) = 1 mb(3) = 0 mb(0) = nint(ndg2mx*alogm2) kflag = -4 GO TO 10 END IF CALL imdvir(ma,idiv,mb,irem) IF (mb(1)==munkno) THEN kflag = -4 namest(ncall) = 'IMDIVI' CALL fmwarn END IF 10 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. IMPLICIT NONE ! Scratch array usage during IMDIVR: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC abs, dble, dint, int, max, min, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, ma2p, macca, maccb, maxmwa, mb1, mb2, mb2p, mbm1, & mcarry, mda, mdab, mdb, mdr, mkt, mlmax, mqd REAL (KIND(0.0D0)) :: xb, xbase, xbr, xmwa INTEGER :: j, jb, jl, k, ka, kb, kl, kltflg, kptmwa, lcrrct, na1, nb1, & ndsave, nguard, nl, nmbwds, ntrsav ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmwarn, imadd, imargs, imeq, imi2m, imntr, imntrj, & imprnt, imsub ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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) END IF kflag = 0 ntrsav = ntrace ntrace = 0 IF (mblogs/=mbase) CALL fmcons ! Check for special cases. IF (mb(1)==1 .AND. ma(1)/=munkno) THEN IF (mb(2)==1) THEN CALL imeq(ma,mc) md(1) = 0 md(2) = 0 md(3) = 0 md(0) = nint(ndg2mx*alogm2) GO TO 260 ELSE IF (mb(2)==-1) THEN CALL imeq(ma,mc) IF (mc(1)/=munkno) mc(2) = -mc(2) md(1) = 0 md(2) = 0 md(3) = 0 md(0) = nint(ndg2mx*alogm2) GO TO 260 END IF END IF 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 END IF mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) md(1) = munkno md(2) = 1 md(3) = 0 md(0) = nint(ndg2mx*alogm2) GO TO 260 END IF IF (ma(1)<=2) THEN IF (mb(1)>2) GO TO 10 IF (mb(2)==0) GO TO 10 IF (ma(1)<=1) THEN mda = ma(2) ELSE IF (ma(2)<0) THEN mda = ma(2)*mbase - ma(3) ELSE mda = ma(2)*mbase + ma(3) END IF IF (mb(1)<=1) THEN mdb = mb(2) ELSE IF (mb(2)<0) THEN mdb = mb(2)*mbase - mb(3) ELSE mdb = mb(2)*mbase + mb(3) END IF mdab = dint(mda/mdb) mdr = mda - mdab*mdb IF (abs(mdab)ndg2mx) kl = 2 DO 20 j = 0, kl + 1 m01(j) = mb(j) 20 CONTINUE m01(2) = abs(m01(2)) IF (kl==1) m01(3) = 0 IF (ma(1)==m01(1) .AND. abs(ma(2))<=m01(2)) THEN ma(2) = abs(ma(2)) IF (imcomp(ma,'EQ',m01)) THEN kltflg = 2 ELSE IF (imcomp(ma,'LT',m01)) THEN kltflg = 1 END IF ma(2) = ma2 END IF IF (ma(1)=1) THEN IF (kltflg/=2) THEN CALL imeq(ma,md) md(2) = abs(md(2)) CALL imi2m(0,mc) ELSE CALL imi2m(1,mc) CALL imi2m(0,md) END IF GO TO 250 END IF ndig = int(ma(1)) IF (ndig<2) ndig = 2 macca = ma(0) maccb = mb(0) ! NGUARD is the number of guard digits used. nguard = 1 ma2p = abs(ma(2)) mb2p = abs(mb(2)) na1 = int(ma(1)) + 1 nb1 = int(mb(1)) + 1 ! Copy MA into the working array. DO 30 j = 3, na1 mwa(j+1) = ma(j) 30 CONTINUE mwa(1) = ma(1) - mb(1) + 1 mwa(2) = 0 nl = na1 + nguard + 3 DO 40 j = na1 + 2, nl mwa(j) = 0 40 CONTINUE ! Save the sign of MA and MB and then work only with ! positive numbers. ma2 = ma(2) mb1 = mb(1) mb2 = mb(2) ma(2) = ma2p mwa(3) = ma(2) mb(1) = 0 mb(2) = mb2p ! NMBWDS is the number of words of MB used to ! compute the estimated quotient digit MQD. nmbwds = 4 IF (mbase<100) nmbwds = 7 ! XB is an approximation of MB used in ! estimating the quotient digits. xbase = dble(mbase) xb = 0 jl = nmbwds IF (jl<=nb1) THEN DO 50 j = 2, jl xb = xb*xbase + dble(mb(j)) 50 CONTINUE ELSE DO 60 j = 2, jl IF (j<=nb1) THEN xb = xb*xbase + dble(mb(j)) ELSE xb = xb*xbase END IF 60 CONTINUE END IF 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. 70 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 80 j = kptmwa + 4, kl xmwa = xmwa*xbase + dble(mwa(j)) 80 CONTINUE ELSE xmwa = dble(mwa(kptmwa)) DO 90 j = kptmwa + 1, kl IF (j<=nl) THEN xmwa = xmwa*xbase + dble(mwa(j)) ELSE xmwa = xmwa*xbase END IF 90 CONTINUE END IF ! MQD is the estimated quotient digit. mqd = dint(xmwa*xbr) IF (mqd<0) mqd = mqd - 1 IF (mqd>0) THEN maxmwa = maxmwa + mqd ELSE maxmwa = maxmwa - mqd END IF ! See if MWA must be normalized. ka = kptmwa + 1 kb = ka + int(mb1) - 1 IF (maxmwa>=mlmax) THEN DO 100 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 END IF 100 CONTINUE xmwa = 0 IF (kl<=nl) THEN DO 110 j = kptmwa, kl xmwa = xmwa*xbase + dble(mwa(j)) 110 CONTINUE ELSE DO 120 j = kptmwa, kl IF (j<=nl) THEN xmwa = xmwa*xbase + dble(mwa(j)) ELSE xmwa = xmwa*xbase END IF 120 CONTINUE END IF mqd = dint(xmwa*xbr) IF (mqd<0) mqd = mqd - 1 IF (mqd>0) THEN maxmwa = mqd ELSE maxmwa = -mqd END IF END IF ! Subtract MQD*MB from MWA. jb = ka - 2 IF (mqd/=0) THEN ! Major (Inner Loop) DO 130 j = ka, kb mwa(j) = mwa(j) - mqd*mb(j-jb) 130 CONTINUE END IF mwa(ka) = mwa(ka) + mwa(ka-1)*mbase mwa(kptmwa) = mqd kptmwa = kptmwa + 1 IF (kptmwa-2=mbase) THEN mcarry = -int(mwa(j)/mbase) mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry END IF 140 CONTINUE lcrrct = 0 150 DO 160 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 END IF 160 CONTINUE ! 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 170 j = ka, kb mwa(j) = mwa(j) + mb(j-jb) 170 CONTINUE GO TO 150 ELSE IF (mwa(ka)>=mbase) THEN lcrrct = lcrrct + 1 DO 180 j = ka, kb mwa(j) = mwa(j) - mb(j-jb) 180 CONTINUE GO TO 150 END IF ma(2) = ma2 mb(1) = mb1 mb(2) = mb2 IF (mwa(2)/=0 .OR. kptmwa==2) THEN DO 190 j = 1, int(mwa(1)) + 1 mc(j) = mwa(j) 190 CONTINUE ELSE DO 200 j = 3, int(mwa(1)) + 1 mc(j-1) = mwa(j) 200 CONTINUE IF (mc(2)/=0) THEN mc(1) = mwa(1) - 1 ELSE mc(1) = 0 END IF END IF IF (mc(1)<=1) mc(3) = 0 mc(0) = min(macca,maccb) IF (mwa(kptmwa+1)/=0) THEN DO 210 j = 1, int(mb1) md(j+1) = mwa(kptmwa+j) 210 CONTINUE md(1) = mb1 ELSE DO 230 j = 1, int(mb1) IF (mwa(kptmwa+j)/=0) THEN DO 220 k = j, int(mb1) md(k-j+2) = mwa(kptmwa+k) 220 CONTINUE md(1) = mb1 + 1 - j GO TO 240 END IF 230 CONTINUE md(1) = 0 md(2) = 0 END IF 240 IF (md(1)<=1) md(3) = 0 md(0) = min(macca,maccb) ! If the remainder had to be corrected, make the ! corresponding adjustment in the quotient. IF (md(1)>m01(1) .OR. (md(1)==m01(1) .AND. abs(md(2))>=m01(2))) THEN IF (imcomp(md,'GE',m01)) THEN CALL imsub(md,m01,md) lcrrct = lcrrct + 1 END IF END IF IF (lcrrct/=0) THEN CALL imi2m(lcrrct,m02) CALL imadd(m02,mc,mc) END IF 250 IF (ma2<0 .AND. mb2>0) THEN IF (mc(1)/=munkno) mc(2) = -mc(2) IF (md(1)/=munkno) md(2) = -md(2) ELSE IF (ma2>0 .AND. mb2<0) THEN IF (mc(1)/=munkno) mc(2) = -mc(2) ELSE IF (ma2<0 .AND. mb2<0) THEN IF (md(1)/=munkno) md(2) = -md(2) END IF 260 ntrace = ntrsav IF (ntrace/=0) THEN CALL imntr(1,mc,mc,1) IF (abs(ntrace)>=1 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN ndig = max(2,int(md(1))) IF (ndig>ndg2mx) ndig = 2 IF (md(1)<=1) md(3) = 0 ntrsav = ntrace IF (ntrace<-2) ntrace = -2 CALL imntrj(md,ndig) ntrace = ntrsav ELSE CALL imprnt(md) END IF END IF END IF 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. IMPLICIT NONE ! Scratch array usage during IMDVIR: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: idiv, irem ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, mda, mdab, mdb, mdr, mkt, modint, mvalp INTEGER :: j, jdiv, ka, kl, kltflg, kpt, n1, ndsave, nmval, ntrsav, nv2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL fmwarn, imargs, imdivr, imeq, imi2m, imm2i, imntr, imntri ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. 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 (mktndg2mx .OR. idiv==0) THEN kflag = -4 IF (ma(1)/=munkno) THEN namest(ncall) = 'IMDVIR' CALL fmwarn END IF mb(1) = munkno mb(2) = 1 mb(3) = 0 mb(0) = nint(ndg2mx*alogm2) irem = iunkno GO TO 70 END IF IF (ma(1)<=2) THEN IF (ma(1)<=1) THEN mda = ma(2) ELSE IF (ma(2)<0) THEN mda = ma(2)*mbase - ma(3) ELSE mda = ma(2)*mbase + ma(3) END IF mdb = idiv mdab = dint(mda/mdb) mdr = mda - mdab*mdb IF (abs(mdab)=1) THEN IF (kltflg/=2) THEN CALL imm2i(ma,irem) irem = abs(irem) CALL imi2m(0,mb) ELSE CALL imi2m(1,mb) irem = 0 END IF GO TO 60 END IF END IF ndig = int(ma(1)) IF (ndig<2) ndig = 2 n1 = int(ma(1)) + 1 ! If ABS(IDIV).GE.MXBASE use IMDIVR. mvalp = abs(idiv) nmval = int(mvalp) nv2 = nmval - 1 IF (abs(idiv)>mxbase .OR. nmval/=abs(idiv) .OR. nv2/=abs(idiv)-1) THEN CALL imi2m(idiv,m03) CALL imdivr(ma,m03,mb,m03) CALL imm2i(m03,irem) GO TO 70 END IF ! Work with positive numbers. ma(2) = abs(ma(2)) ! Find the first significant digit of the quotient. mkt = ma(2) IF (mkt>=mvalp) THEN kpt = 2 GO TO 30 END IF DO 20 j = 3, n1 mkt = mkt*mbase + ma(j) IF (mkt>=mvalp) THEN kpt = j GO TO 30 END IF 20 CONTINUE CALL imm2i(ma,irem) CALL imi2m(0,mb) GO TO 70 ! Do the rest of the division. 30 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 40 j = ka, n1 mkt = modint*mbase + ma(j) mwa(kl+j) = int(mkt/mvalp) modint = mkt - mwa(kl+j)*mvalp 40 CONTINUE END IF mb(0) = ma(0) DO 50 j = 1, int(mwa(1)) + 1 mb(j) = mwa(j) 50 CONTINUE irem = int(modint) 60 IF (ma2<0 .AND. idiv>0) THEN IF (mb(1)/=munkno) mb(2) = -mb(2) irem = -irem ELSE IF (ma2>0 .AND. idiv<0) THEN IF (mb(1)/=munkno) mb(2) = -mb(2) ELSE IF (ma2<0 .AND. idiv<0) THEN irem = -irem END IF 70 IF (ntrace/=0 .AND. ncall<=lvltrc) THEN CALL imntr(1,mb,mb,1) CALL imntri(1,irem,0) END IF ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imdvir SUBROUTINE imeq(ma,mb) ! MB = MA IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int, max ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, kdg ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kdg = max(2,int(ma(1))) + 1 IF (kdg>lunpck) kdg = 3 DO 10 j = 0, kdg mb(j) = ma(j) 10 CONTINUE RETURN END SUBROUTINE imeq SUBROUTINE imfm2i(ma,mb) ! MB = INT(MA) ! Convert from real (FM) format to integer (IM) format. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: ntrsav ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmint, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 kflag = 0 ntrsav = ntrace ntrace = 0 CALL fmeq(ma,mb) CALL fmint(mb,mb) IF (mb(1)>ndigmx) THEN IF (mb(1)<=ndg2mx .OR. ncall<=1) THEN mb(0) = nint(ndg2mx*alogm2) mb(1) = munkno mb(2) = 1 mb(3) = 0 kflag = -4 namest(ncall) = 'IMFM2I' CALL fmwarn END IF END IF 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. IMPLICIT NONE ! Scratch array usage during IMFORM: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: form, string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: ndsave ! .. ! .. External Subroutines .. EXTERNAL fmform, imargs ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMFORM',1,ma,ma) kflag = 0 namest(ncall) = 'IMFORM' ndsave = ndig ndig = int(ma(1)) IF (ndig<2 .OR. ndig>ndg2mx) ndig = 2 IF (ma(1)<=1) ma(3) = 0 CALL fmform(form,ma,string) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imform SUBROUTINE imfprt(form,ma) ! Print an IM number (MA) on unit KW using character ! string FORM format. ! FORM can be one of these types: Iw, Fw.d, Ew.d, 1PEw.d ! for positive integers w,d. IMPLICIT NONE ! Scratch array usage during IMFPRT: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: form ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: ndsave ! .. ! .. External Subroutines .. EXTERNAL fmfprt, imargs ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMFPRT',1,ma,ma) kflag = 0 namest(ncall) = 'IMFPRT' ndsave = ndig ndig = int(ma(1)) IF (ndig<2 .OR. ndig>ndg2mx) ndig = 2 IF (ma(1)<=1) ma(3) = 0 CALL fmfprt(form,ma) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imfprt SUBROUTINE imgcd(ma,mb,mc) ! MC is returned as the greatest common divisor of MA and MB. IMPLICIT NONE ! Scratch array usage during IMGCD: M01 - M05 ! .. Intrinsic Functions .. INTRINSIC abs, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: ndsave ! .. ! .. External Subroutines .. EXTERNAL fmwarn, imabs, imargs, imdivr, imeq, imi2m, immax, immin, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug !