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