C ALGORITHM 786, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 24,NO. 4, December, 1998, P. 359--367. #! /bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #! /bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # Fortran90/ # Fortran90/Doc/ # Fortran90/Doc/Makefile # Fortran90/Doc/readme # Fortran90/Drivers/ # Fortran90/Drivers/Dp/ # Fortran90/Drivers/Dp/RES1 # Fortran90/Drivers/Dp/RES2 # Fortran90/Drivers/Dp/RES3 # Fortran90/Drivers/Dp/RES4 # Fortran90/Drivers/Dp/RES5 # Fortran90/Drivers/Dp/RES6 # Fortran90/Drivers/Dp/driver1.f90 # Fortran90/Drivers/Dp/driver2.f90 # Fortran90/Drivers/Dp/driver3.f90 # Fortran90/Drivers/Dp/driver4.f90 # Fortran90/Drivers/Dp/driver5.f90 # Fortran90/Drivers/Dp/driver6.f90 # Fortran90/Src/ # Fortran90/Src/Dp/ # Fortran90/Src/Dp/fmlib.f90 # Fortran90/Src/Dp/fmzm90.f90 # Fortran90/Src/Dp/fmzmcomm.f90 # Fortran90/Src/Dp/zmlib.f90 # This archive created: Thu Mar 25 10:55:09 1999 export PATH; PATH=/bin:$PATH if test ! -d 'Fortran90' then mkdir 'Fortran90' fi cd 'Fortran90' if test ! -d 'Doc' then mkdir 'Doc' fi cd 'Doc' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' # Define EPC F90 compiler and flags #FC = epcf90 #FFLAGS = -C -d1 -g -temp=/tmp -u #FFLAGS = -temp=/tmp -O # Define Nag f90 compiler and flags FC = f90 FFLAGS = -g # Define rule for .f to .o and .f90 to .o .SUFFIXES : .f .f90 .o .f.o: $(FC) $(FFLAGS) -c $< .f90.o: $(FC) $(FFLAGS) -c $< all: res1 res2 res3 res4 res5 res6 res1: zmlib.o fmlib.o driver1.o $(FC) $(FFLAGS) zmlib.o fmlib.o driver1.o -o driver1 driver1 > res1 res2: zmlib.o fmlib.o driver2.o $(FC) $(FFLAGS) zmlib.o fmlib.o driver2.o -o driver2 driver2 > res2 res3: fmlib.o driver3.o $(FC) $(FFLAGS) fmlib.o driver3.o -o driver3 driver3 > res3 res4: driver4.o fmlib.o $(FC) $(FFLAGS) driver4.o fmlib.o -o driver4 driver4 > res4 res5: fmzmcomm.o fmzm90.o fmlib.o zmlib.o driver5.o $(FC) $(FFLAGS) fmzmcomm.o fmzm90.o fmlib.o zmlib.o driver5.o -o driver5 driver5 > res5 res6: fmzmcomm.o fmzm90.o fmlib.o zmlib.o driver6.o $(FC) $(FFLAGS) fmzmcomm.o fmzm90.o fmlib.o zmlib.o driver6.o -o driver6 driver6 > res6 clean: rm -rf driver4 driver6 driver3 driver5 driver1 driver2 rm -rf *.o *.LOG res* SHAR_EOF fi # end of overwriting check if test -f 'readme' then echo shar: will not over-write existing file "'readme'" else cat << SHAR_EOF > 'readme' This is a list of the files for version 1.1 of FMLIB and ZMLIB. 1. zmlib.f90 Subroutine library for complex operations 2. fmlib.f90 Subroutine library for real operations 3. testzm.f90 Test program for most of the ZM routines 4. zmsample.f90 Small sample program using ZM 5. zmsample.chk Expected output file from zmsample.f90 6. testfm.f90 Test program for most of the FM routines 7. fmsample.f90 Small sample program using FM 8. fmsample.chk Expected output file from fmsample.f90 9. fmzm90.f90 Fortran-90 interface module 10. fmzmcomm.f90 Fortran-90 module for common blocks 11. Test90.f90 Test program for fmzm90 12. Sample90.f90 Small sample program using fmzm90 13. SAMPLE90.CHK Expected output file from sample90.f A makefile detailing the building of the ZM and FM libraries and the running of all the test examples is provided. My web site contains copies of other related papers and files. In 1998 it was located at "http://cse.eng.lmu.edu/~dsmith/FMLIB.html". If that location changes in the future, try searching for the keyword "dsmithfmlibrary" to find the site. =========================================================================== =========================================================================== USER'S GUIDE FOR THE FM PACKAGE The various lists of available multiple precision operations and routines have been collected here, along with some general advice on using the package. See the programs fmsample.f90, zmsample.f90, and sample90.f90 for some examples of initializing and using the package. This version of the package uses code with the names of routines, variables, and files in lower case, but in this file as well as in comment lines in the code such names are emphasized by writing them in upper case. INITIALIZATION: Before ANY part of the FM package can be used, the base and precision to be used must be defined, along with several other saved parameters. If any complex arithmetic is to be used, put CALL ZMSET(N) in the main program before any multiple precision operations are done, with N replaced by the number of decimal digits of accuracy to be used. This will initialize both FMLIB and ZMLIB packages. If only real arithmetic is to be used, put CALL FMSET(N) in the main program before any multiple precision operations are done, with N replaced by the number of decimal digits of accuracy to be used. This will initialize the FMLIB package. One of these calls must be present whether the FM/ZM routines are to be called directly by the user, or the Fortran-90 interface routines are to be used. For compatibility when the interface module is used, the derived type routine names FM_SET or ZM_SET may be used in place of FMSET or ZMSET. MODULE/COMMON: Some common blocks used for saved parameters must be declared in the main program. If the Fortran-90 interface is used, put USE FMZM at the beginning of the main program and also in each routine that uses type FM, IM, or ZM variables. If the Fortran-90 interface is not used, put the common blocks given in zmsample.f90 at the top of the main program if complex arithmetic is used, or put the common blocks given in fmsample.f90 at the top of the main program if only real arithmetic is used. ROUTINE NAMES: For each multiple precision operation there are several routines with related names that perform variations of that operation. For example, the addition operation has these forms: Using the Fortran-90 interface module, to perform real (floating-point) multiple precision addition, declare the variables with TYPE ( FM ) A,B,C and then add using C = A + B Normally, using the interface module avoids the need to know the name of the FM routine being called. For some operations, usually those that are not Fortran-90 functions (such as formatting a number), a direct call may be needed. The addition above can be done as CALL FM_ADD(A,B,C) If fmlib.f90 is used without the interface module, then the multiple precision numbers are declared as arrays DOUBLE PRECISION A(0:LUNPCK),B(0:LUNPCK),C(0:LUNPCK) where LUNPCK is defined in the PARAMETER statement included with the FM common blocks. The numbers are then added by calling the FMLIB routine where the arguments are assumed to be arrays, not TYPE (FM) derived types: CALL FMADD(A,B,C) For each of the routines listed below (like FMADD), there is a version that assumes the arguments have the appropriate derived type. These have the same names, except "_" has been inserted after the first two letters of the name (like FM_ADD). If direct calls are done instead of using the interface module, there is another form for these routine names that is used when the arrays have been declared in a packed format that takes roughly half as much space: DOUBLE PRECISION A(0:LPACK),B(0:LPACK),C(0:LPACK) The routines that work with packed arrays have names where the second letter has been changed from M to P: CALL FPADD(A,B,C) The packed versions are slower. For multiple precision integer or complex operations there are similar Fortran-90 derived types and the various routines: USE FMZM ... TYPE ( IM ) A,B,C TYPE ( ZM ) X,Y,Z ... C = A + B ... Z = X + Y with explicit calls of the form CALL IM_ADD(A,B,C) CALL ZM_ADD(X,Y,Z) Without using the interface module: DOUBLE PRECISION A(0:LUNPCK),B(0:LUNPCK),C(0:LUNPCK) DOUBLE PRECISION X(0:LUNPKZ),Y(0:LUNPKZ),Z(0:LUNPKZ) ... CALL IMADD(A,B,C) ... CALL ZMADD(X,Y,Z) Packed format without the interface module: DOUBLE PRECISION A(0:LPACK),B(0:LPACK),C(0:LPACK) DOUBLE PRECISION X(0:LPACKZ),Y(0:LPACKZ),Z(0:LPACKZ) ... CALL IPADD(A,B,C) ... CALL ZPADD(X,Y,Z) ------------------------------------------------------------------------ ------------------- Fortran-90 Interface Notes --------------------- There are three multiple precision data types: FM (multiple precision real) IM (multiple precision integer) ZM (multiple precision complex) Some the the interface routines assume that the precision chosen in the calling program (using FM_SET or ZM_SET) represents more significant digits than does the machine's double precision. All the functions defined in this module are standard Fortran-90 functions, except for several direct conversion functions: TO_FM is a function for converting other types of numbers to type FM. Note that TO_FM(3.12) converts the REAL constant to FM, but it is accurate only to single precision. TO_FM(3.12D0) agrees with 3.12 to double precision accuracy, and TO_FM('3.12') or TO_FM(312)/TO_FM(100) agrees to full FM accuracy. TO_IM converts to type IM, and TO_ZM converts to type ZM. Functions are also supplied for converting the three multiple precision types to the other numeric data types: TO_INT converts to machine precision integer TO_SP converts to single precision TO_DP converts to double precision TO_SPZ converts to single precision complex TO_DPZ converts to double precision complex WARNING: When multiple precision type declarations are inserted in an existing program, take care in converting functions like DBLE(X), where X has been declared as a multiple precision type. If X was single precision in the original program, then replacing the DBLE(X) by TO_DP(X) in the new version could lose accuracy. For this reason, the Fortran type-conversion functions defined in this module assume that results should be multiple precision whenever inputs are. Examples: DBLE(TO_FM('1.23E+123456')) is type FM REAL(TO_FM('1.23E+123456')) is type FM REAL(TO_ZM('3.12+4.56i')) is type FM = TO_FM('3.12') INT(TO_FM('1.23')) is type IM = TO_IM(1) INT(TO_IM('1E+23')) is type IM CMPLX(TO_FM('1.23'),TO_FM('4.56')) is type ZM Programs using this module may sometimes need to call FM, IM, or ZM routines directly. This is normally the case when routines are needed that are not Fortran-90 intrinsics, such as the formatting subroutine FMFORM. In a program using this module, suppose MAFM has been declared with TYPE ( FM ) MAFM. To use the routine FMFORM, which expects the second argument to be an array and not a derived type, the call would have to be CALL FMFORM('F65.60',MAFM%MFM,ST1) so that the array contained in MAFM is passed. As an alternative so the user can refer directly to the FM-, IM-, and ZM-type variables and avoid the cumbersome "%MFM" suffixes, this module contains a collection of interface routines to supply any needed argument conversions. For each FM, IM, and ZM routine that is designed to be called by the user, there is also a version that assumes any multiple-precision arguments are derived types instead of arrays. Each interface routine has the same name as the original with an underscore after the first two letters of the routine name. To convert the number to a character string with F65.60 format, use CALL FM_FORM('F65.60',MAFM,ST1) if MAFM is of TYPE ( FM ), or use CALL FMFORM('F65.60',MA,ST1) if MA is declared as an array. All the routines shown below may be used this way. For each of the operations =, +, -, *, /, **, .EQ., .NE., .GT., .GE., .LT., and .LE., the interface module defines all mixed mode variations involving one of the three multiple precision derived types and another argument having one of the types: { integer, real, double, complex, complex double, FM, IM, ZM }. So mixed mode expressions such as MAFM = 12 MAFM = MAFM + 1 IF (ABS(MAFM).LT.1.0D-23) THEN are handled correctly. Not all the named functions are defined for all three multiple precision derived types, so the list below shows which can be used. The labels "real", "integer", and "complex" refer to types FM, IM, and ZM respectively, "string" means the function accepts character strings (e.g., TO_FM('3.45')), and "other" means the function can accept any of the machine precision data types integer, real, double, complex, or complex double. For functions that accept two or more arguments, like ATAN2 or MAX, all the arguments must be of the same type. AVAILABLE OPERATIONS: = + - * / ** .EQ. .NE. .GT. .GE. .LT. .LE. ABS real integer complex ACOS real complex AIMAG complex AINT real complex ANINT real complex ASIN real complex ATAN real complex ATAN2 real BTEST integer CEILING real complex CMPLX real integer CONJ complex COS real complex COSH real complex DBLE real integer complex DIGITS real integer complex DIM real integer DINT real complex DOTPRODUCT real integer complex EPSILON real EXP real complex EXPONENT real FLOOR real integer complex FRACTION real complex HUGE real integer complex INT real integer complex LOG real complex LOG10 real complex MATMUL real integer complex MAX real integer MAXEXPONENT real MIN real integer MINEXPONENT real MOD real integer MODULO real integer NEAREST real NINT real integer complex PRECISION real complex RADIX real integer complex RANGE real integer complex REAL real integer complex RRSPACING real SCALE real complex SETEXPONENT real SIGN real integer SIN real complex SINH real complex SPACING real SQRT real complex TAN real complex TANH real complex TINY real integer complex TO_FM real integer complex string other TO_IM real integer complex string other TO_ZM real integer complex string other TO_INT real integer complex TO_SP real integer complex TO_DP real integer complex TO_SPZ real integer complex TO_DPZ real integer complex ------------------------------------------------------------------------ ----------- Routines for Real Floating-Point Operations ------------ These are the FM routines that are designed to be called by the user. All are subroutines except logical function FMCOMP. MA, MB, MC refer to FM format numbers. In each case it is permissible to use the same array more than once in the calling sequence. The statement MA = MA*MA can be written CALL FMMPY(MA,MA,MA). For each of these routines there is also a version available for which the argument list is the same but all FM numbers are in packed format. The routines using packed numbers have the same names except 'FM' is replaced by 'FP' at the start of each name. FMABS(MA,MB) MB = ABS(MA) FMACOS(MA,MB) MB = ACOS(MA) FMADD(MA,MB,MC) MC = MA + MB FMADDI(MA,IVAL) MA = MA + IVAL Increment an FM number by a one word integer. Note this call does not have an "MB" result like FMDIVI and FMMPYI. FMASIN(MA,MB) MB = ASIN(MA) FMATAN(MA,MB) MB = ATAN(MA) FMATN2(MA,MB,MC) MC = ATAN2(MA,MB) FMBIG(MA) MA = Biggest FM number less than overflow. FMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA). Faster than making two separate calls. FMCOMP(MA,LREL,MB) Logical comparison of MA and MB. LREL is a CHARACTER*2 value identifying which comparison is made. Example: IF (FMCOMP(MA,'GE',MB)) ... FMCONS Set several saved constants that depend on MBASE, the base being used. FMCONS should be called immediately after changing MBASE. FMCOS(MA,MB) MB = COS(MA) FMCOSH(MA,MB) MB = COSH(MA) FMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA). Faster than making two separate calls. FMDIG(NSTACK,KST) Find a set of precisions to use during Newton iteration for finding a simple root starting with about double precision accuracy. FMDIM(MA,MB,MC) MC = DIM(MA,MB) FMDIV(MA,MB,MC) MC = MA/MB FMDIVI(MA,IVAL,MB) MB = MA/IVAL IVAL is a one word integer. FMDP2M(X,MA) MA = X Convert from double precision to FM. FMDPM(X,MA) MA = X Convert from double precision to FM. Much faster than FMDP2M, but MA agrees with X only to D.P. accuracy. See the comments in the two routines. FMEQ(MA,MB) MB = MA Both have precision NDIG. This is the version to use for standard B = A statements. FMEQU(MA,MB,NA,NB) MB = MA Version for changing precision. MA has NA digits (i.e., MA was computed using NDIG = NA), and MB will be defined having NB digits. MB is zero-padded if NB.GT.NA MB is rounded if NB.LT.NA FMEXP(MA,MB) MB = EXP(MA) FMFORM(FORM,MA,STRING) MA is converted to a character string using format FORM and returned in STRING. FORM can represent I, F, E, or 1PE formats. Example: CALL FMFORM('F60.40',MA,STRING) FMFPRT(FORM,MA) Print MA on unit KW using FORM format. FMI2M(IVAL,MA) MA = IVAL Convert from one word integer to FM. FMINP(LINE,MA,LA,LB) MA = LINE Input conversion. Convert LINE(LA) through LINE(LB) from characters to FM. FMINT(MA,MB) MB = INT(MA) Integer part of MA. FMIPWR(MA,IVAL,MB) MB = MA**IVAL Raise an FM number to a one word integer power. FMLG10(MA,MB) MB = LOG10(MA) FMLN(MA,MB) MB = LOG(MA) FMLNI(IVAL,MA) MA = LOG(IVAL) Natural log of a one word integer. FMM2DP(MA,X) X = MA Convert from FM to double precision. FMM2I(MA,IVAL) IVAL = MA Convert from FM to integer. FMM2SP(MA,X) X = MA Convert from FM to single precision. FMMAX(MA,MB,MC) MC = MAX(MA,MB) FMMIN(MA,MB,MC) MC = MIN(MA,MB) FMMOD(MA,MB,MC) MC = MA mod MB FMMPY(MA,MB,MC) MC = MA*MB FMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer. FMNINT(MA,MB) MB = NINT(MA) Nearest FM integer. FMOUT(MA,LINE,LB) LINE = MA Convert from FM to character. LINE is a character array of length LB. FMPI(MA) MA = pi FMPRNT(MA) Print MA on unit KW using current format. FMPWR(MA,MB,MC) MC = MA**MB FMREAD(KREAD,MA) MA is returned after reading one (possibly multi-line) FM number on unit KREAD. This routine reads numbers written by FMWRIT. FMRPWR(MA,K,J,MB) MB = MA**(K/J) Rational power. Faster than FMPWR for functions like the cube root. FMSET(NPREC) Set default values and machine-dependent variables to give at least NPREC base 10 digits plus three base 10 guard digits. Must be called to initialize FM package. FMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer. FMSIN(MA,MB) MB = SIN(MA) FMSINH(MA,MB) MB = SINH(MA) FMSP2M(X,MA) MA = X Convert from single precision to FM. FMSQR(MA,MB) MB = MA*MA Faster than FMMPY. FMSQRT(MA,MB) MB = SQRT(MA) FMST2M(STRING,MA) MA = STRING Convert from character string to FM. Often more convenient than FMINP, which converts an array of CHARACTER*1 values. Example: CALL FMST2M('123.4',MA). FMSUB(MA,MB,MC) MC = MA - MB FMTAN(MA,MB) MB = TAN(MA) FMTANH(MA,MB) MB = TANH(MA) FMULP(MA,MB) MB = One Unit in the Last Place of MA. FMWRIT(KWRITE,MA) Write MA on unit KWRITE. Multi-line numbers will have '&' as the last nonblank character on all but the last line. These numbers can then be read easily using FMREAD. ------------------------------------------------------------------------ ----------------- Routines for Integer Operations ------------------ These are the integer routines that are designed to be called by the user. All are subroutines except logical function IMCOMP. MA, MB, MC refer to IM format numbers. In each case the version of the routine to handle packed IM numbers has the same name, with 'IM' replaced by 'IP'. IMABS(MA,MB) MB = ABS(MA) IMADD(MA,MB,MC) MC = MA + MB IMBIG(MA) MA = Biggest IM number less than overflow. IMCOMP(MA,LREL,MB) Logical comparison of MA and MB. LREL is a CHARACTER*2 value identifying which comparison is made. Example: IF (IMCOMP(MA,'GE',MB)) ... IMDIM(MA,MB,MC) MC = DIM(MA,MB) IMDIV(MA,MB,MC) MC = int(MA/MB) Use IMDIVR if the remainder is also needed. IMDIVI(MA,IVAL,MB) MB = int(MA/IVAL) IVAL is a one word integer. Use IMDVIR to get the remainder also. IMDIVR(MA,MB,MC,MD) MC = int(MA/MB), MD = MA mod MB When both the quotient and remainder are needed, this routine is twice as fast as calling both IMDIV and IMMOD. IMDVIR(MA,IVAL,MB,IREM) MB = int(MA/IVAL), IREM = MA mod IVAL IVAL and IREM are one word integers. IMEQ(MA,MB) MB = MA IMFM2I(MAFM,MB) MB = MAFM Convert from real (FM) format to integer (IM) format. IMFORM(FORM,MA,STRING) MA is converted to a character string using format FORM and returned in STRING. FORM can represent I, F, E, or 1PE formats. Example: CALL IMFORM('I70',MA,STRING) IMFPRT(FORM,MA) Print MA on unit KW using FORM format. IMGCD(MA,MB,MC) MC = greatest common divisor of MA and MB. IMI2FM(MA,MBFM) MBFM = MA Convert from integer (IM) format to real (FM) format. IMI2M(IVAL,MA) MA = IVAL Convert from one word integer to IM. IMINP(LINE,MA,LA,LB) MA = LINE Input conversion. Convert LINE(LA) through LINE(LB) from characters to IM. IMM2DP(MA,X) X = MA Convert from IM to double precision. IMM2I(MA,IVAL) IVAL = MA Convert from IM to one word integer. IMMAX(MA,MB,MC) MC = MAX(MA,MB) IMMIN(MA,MB,MC) MC = MIN(MA,MB) IMMOD(MA,MB,MC) MC = MA mod MB IMMPY(MA,MB,MC) MC = MA*MB IMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer. IMMPYM(MA,MB,MC,MD) MD = MA*MB mod MC Slightly faster than calling IMMPY and IMMOD separately, and it works for cases where IMMPY would return OVERFLOW. IMOUT(MA,LINE,LB) LINE = MA Convert from IM to character. LINE is a character array of length LB. IMPMOD(MA,MB,MC,MD) MD = MA**MB mod MC IMPRNT(MA) Print MA on unit KW. IMPWR(MA,MB,MC) MC = MA**MB IMREAD(KREAD,MA) MA is returned after reading one (possibly multi-line) IM number on unit KREAD. This routine reads numbers written by IMWRIT. IMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer. IMSQR(MA,MB) MB = MA*MA Faster than IMMPY. IMST2M(STRING,MA) MA = STRING Convert from character string to IM. Often more convenient than IMINP, which converts an array of CHARACTER*1 values. Example: CALL IMST2M('12345678901',MA). IMSUB(MA,MB,MC) MC = MA - MB IMWRIT(KWRITE,MA) Write MA on unit KWRITE. Multi-line numbers will have '&' as the last nonblank character on all but the last line. These numbers can then be read easily using IMREAD. Many of the IM routines call FM routines, but none of the FM routines call IM routines, so the IM routines can be omitted if none are called explicitly from a program. ------------------------------------------------------------------------ ---------- Routines for Complex Floating-Point Operations ---------- These are the routines in ZMLIB that are designed to be called by the user. All are subroutines, and in each case the version of the routine to handle packed ZM numbers has the same name, with 'ZM' replaced by 'ZP'. MA, MB, MC refer to ZM format complex numbers. MAFM, MBFM, MCFM refer to FM format real numbers. INTEG is a Fortran INTEGER variable. ZVAL is a Fortran COMPLEX variable. In each case it is permissible to use the same array more than once in the calling sequence. The statement MA = MA*MA may be written CALL ZMMPY(MA,MA,MA). ZMABS(MA,MBFM) MBFM = ABS(MA) Result is real. ZMACOS(MA,MB) MB = ACOS(MA) ZMADD(MA,MB,MC) MC = MA + MB ZMADDI(MA,INTEG) MA = MA + INTEG Increment an ZM number by a one word integer. Note this call does not have an "MB" result like ZMDIVI and ZMMPYI. ZMARG(MA,MBFM) MBFM = Argument(MA) Result is real. ZMASIN(MA,MB) MB = ASIN(MA) ZMATAN(MA,MB) MB = ATAN(MA) ZMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA). Faster than 2 calls. ZMCMPX(MAFM,MBFM,MC) MC = CMPLX(MAFM,MBFM) ZMCONJ(MA,MB) MB = CONJG(MA) ZMCOS(MA,MB) MB = COS(MA) ZMCOSH(MA,MB) MB = COSH(MA) ZMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA). Faster than 2 calls. ZMDIV(MA,MB,MC) MC = MA / MB ZMDIVI(MA,INTEG,MB) MB = MA / INTEG ZMEQ(MA,MB) MB = MA ZMEQU(MA,MB,NDA,NDB) MB = MA Version for changing precision. (NDA and NDB are as in FMEQU) ZMEXP(MA,MB) MB = EXP(MA) ZMFORM(FORM1,FORM2,MA,STRING) STRING = MA MA is converted to a character string using format FORM1 for the real part and FORM2 for the imaginary part. The result is returned in STRING. FORM1 and FORM2 can represent I, F, E, or 1PE formats. Example: CALL ZMFORM('F20.10','F15.10',MA,STRING) ZMFPRT(FORM1,FORM2,MA) Print MA on unit KW using formats FORM1 and FORM2. ZMI2M(INTEG,MA) MA = CMPLX(INTEG,0) ZM2I2M(INTEG1,INTEG2,MA) MA = CMPLX(INTEG1,INTEG2) ZMIMAG(MA,MBFM) MBFM = IMAG(MA) Imaginary part. ZMINP(LINE,MA,LA,LB) MA = LINE Input conversion. Convert LINE(LA) through LINE(LB) from characters to ZM. LINE is a character array of length at least LB. ZMINT(MA,MB) MB = INT(MA) Integer part of both Real and Imaginary parts of MA. ZMIPWR(MA,INTEG,MB) MB = MA ** INTEG Integer power function. ZMLG10(MA,MB) MB = LOG10(MA) ZMLN(MA,MB) MB = LOG(MA) ZMM2I(MA,INTEG) INTEG = INT(REAL(MA)) ZMM2Z(MA,ZVAL) ZVAL = MA ZMMPY(MA,MB,MC) MC = MA * MB ZMMPYI(MA,INTEG,MB) MB = MA * INTEG ZMNINT(MA,MB) MB = NINT(MA) Nearest integer of both Real and Imaginary. ZMOUT(MA,LINE,LB,LAST1,LAST2) LINE = MA Convert from FM to character. LINE is the returned character array. LB is the dimensioned size of LINE. LAST1 is returned as the position in LINE of the last character of REAL(MA). LAST2 is returned as the position in LINE of the last character of AIMAG(MA). ZMPRNT(MA) Print MA on unit KW using current format. ZMPWR(MA,MB,MC) MC = MA ** MB ZMREAD(KREAD,MA) MA is returned after reading one (possibly multi-line) ZM number on unit KREAD. This routine reads numbers written by ZMWRIT. ZMREAL(MA,MBFM) MBFM = REAL(MA) Real part. ZMRPWR(MA,IVAL,JVAL,MB) MB = MA ** (IVAL/JVAL) ZMSET(NPREC) Initialize ZM package. Set precision to the equivalent of at least NPREC base 10 digits. ZMSIN(MA,MB) MB = SIN(MA) ZMSINH(MA,MB) MB = SINH(MA) ZMSQR(MA,MB) MB = MA*MA Faster than ZMMPY. ZMSQRT(MA,MB) MB = SQRT(MA) ZMST2M(STRING,MA) MA = STRING Convert from character string to ZM. Often more convenient than ZMINP, which converts an array of CHARACTER*1 values. Example: CALL ZMST2M('123.4+5.67i',MA). ZMSUB(MA,MB,MC) MC = MA - MB ZMTAN(MA,MB) MB = TAN(MA) ZMTANH(MA,MB) MB = TANH(MA) ZMWRIT(KWRITE,MA) Write MA on unit KWRITE. Multi-line numbers are formatted for automatic reading with ZMREAD. ZMZ2M(ZVAL,MA) MA = ZVAL ------------------------------------------------------------------------ -------------------------- fmlib.f90 Notes --------------------------- The FM routines in this package perform floating-point multiple-precision arithmetic, and the IM routines perform integer multiple-precision arithmetic. 1. INITIALIZING THE PACKAGE Before calling any routine in the package, several variables in the common blocks /FMUSER/, /FM/, /FMBUFF/, and /FMSAVE/ must be initialized. These four common blocks contain information that is saved between calls, so they should be declared in the main program. Subroutine FMSET initializes these variables to default values and defines all machine-dependent values in the package. After calling FMSET once at the start of a program, the user may sometimes want to reset some of the variables in these common blocks. These variables are described below. 2. REPRESENTATION OF FM NUMBERS MBASE is the base in which the arithmetic is done. MBASE must be bigger than one, and less than or equal to the square root of the largest representable integer. For best efficiency MBASE should be large, but no more than about 1/4 of the square root of the largest representable integer. Input and output conversions are much faster when MBASE is a power of ten. NDIG is the number of base MBASE digits that are carried in the multiple precision numbers. NDIG must be at least two. The upper limit for NDIG is defined in the PARAMETER statement at the top of each routine and is restricted only by the amount of memory available. Sometimes it is useful to dynamically vary NDIG during the program. Use FMEQU to round numbers to lower precision or zero-pad them to higher precision when changing NDIG. It is rare to need to change MBASE during a program. Use FMCONS to reset some saved constants that depend on MBASE. FMCONS should be called immediately after changing MBASE. There are two representations for a floating multiple precision number. The unpacked representation used by the routines while doing the computations is base MBASE and is stored in NDIG+2 words. A packed representation is available to store the numbers in the user's program in compressed form. In this format, the NDIG (base MBASE) digits of the mantissa are packed two per word to conserve storage. Thus the external, packed form of a number requires (NDIG+1)/2+2 words. This version uses double precision arrays to hold the numbers. Version 1.0 of FM used integer arrays, which are faster on some machines. The package can easily be changed to use integer arrays -- see section 11 on EFFICIENCY below. The unpacked format of a floating multiple precision number is as follows. A number MA is kept in an array with MA(1) containing the exponent and MA(2) through MA(NDIG+1) containing one digit of the mantissa, expressed in base MBASE. The array is dimensioned to start at MA(0), with the approximate number of bits of precision stored in MA(0). This precision value is intended to be used by FM functions that need to monitor cancellation error in addition and subtraction. The cancellation monitor code is usually disabled for user calls, and FM functions only check for cancellation when they must. Tracking cancellation causes most routines to run slower, with addition and subtraction being affected the most. The exponent is a power of MBASE and the implied radix point is immediately before the first digit of the mantissa. Every nonzero number is normalized so that the second array element (the first digit of the mantissa) is nonzero. In both representations the sign of the number is carried on the second array element only. Elements 3,4,... are always nonnegative. The exponent is a signed integer and may be as large in magnitude as MXEXP (defined in FMSET). For MBASE = 10,000 and NDIG = 4, the number -pi would have these representations: Word 1 2 3 4 5 Unpacked: 1 -3 1415 9265 3590 Packed: 1 -31415 92653590 Word 0 would be 42 in both formats, indicating that the mantissa has about 42 bits of precision. Because of normalization in a large base, the equivalent number of base 10 significant digits for an FM number may be as small as LOG10(MBASE)*(NDIG-1) + 1. The integer routines use the FMLIB format to represent numbers, without the number of digits (NDIG) being fixed. Integers in IM format are essentially variable precision, using the minimum number of words to represent each value. For programs using both FM and IM numbers, FM routines should not be called with IM numbers, and IM routines should not be called with FM numbers, since the implied value of NDIG used for an IM number may not match the explicit NDIG expected by an FM routine. Use the conversion routines IMFM2I and IMI2FM to change between the FM and IM formats. 3. INPUT/OUTPUT ROUTINES All versions of the input routines perform free-format conversion from characters to FM numbers. a. Conversion to or from a character array FMINP converts from a character*1 array to an FM number. FMOUT converts an FM number to base 10 and formats it for output as an array of type character*1. The output is left justified in the array, and the format is defined by two variables in common, so that a separate format definition does not have to be provided for each output call. The user sets JFORM1 and JFORM2 to determine the output format. JFORM1 = 0 E format ( .314159M+6 ) = 1 1PE format ( 3.14159M+5 ) = 2 F format ( 314159.000 ) JFORM2 is the number of significant digits to display (if JFORM1 = 0 or 1). If JFORM2.EQ.0 then a default number of digits is chosen. The default is roughly the full precision of the number. JFORM2 is the number of digits after the decimal point (if JFORM1 = 2). See the FMOUT documentation for more details. b. Conversion to or from a character string FMST2M converts from a character string to an FM number. FMFORM converts an FM number to a character string according to a format provided in each call. The format description is more like that of a Fortran FORMAT statement, and integer or fixed-point output is right justified. c. Direct read or write FMPRNT uses FMOUT to print one FM number. FMFPRT uses FMFORM to print one FM number. FMWRIT writes FM numbers for later input using FMREAD. FMREAD reads FM numbers written by FMWRIT. The values given to JFORM1 and JFORM2 can be used to define a default output format when FMOUT or FMPRNT are called. The explicit format used in a call to FMFORM or FMFPRT overrides the settings of JFORM1 and JFORM2. KW is the unit number to be used for standard output from the package, including error and warning messages, and trace output. For multiple precision integers, the corresponding routines IMINP, IMOUT, IMST2M, IMFORM, IMPRNT, IMFPRT, IMWRIT, and IMREAD provide similar input and output conversions. For output of IM numbers, JFORM1 and JFORM2 are ignored and integer format (JFORM1=2, JFORM2=0) is used. For further description of these routines, see sections 9 and 10 below. 4. ARITHMETIC TRACING NTRACE and LVLTRC control trace printout from the package. NTRACE = 0 No printout except warnings and errors. = 1 The result of each call to one of the routines is printed in base 10, using FMOUT. = -1 The result of each call to one of the routines is printed in internal base MBASE format. = 2 The input arguments and result of each call to one of the routines is printed in base 10, using FMOUT. = -2 The input arguments and result of each call to one of the routines is printed in base MBASE format. LVLTRC defines the call level to which the trace is done. LVLTRC = 1 means only FM routines called directly by the user are traced, LVLTRC = 2 also prints traces for FM routines called by other FM routines called directly by the user, etc. In the above description, internal MBASE format means the number is printed as it appears in the array --- an exponent followed by NDIG base MBASE digits. 5. ERROR CONDITIONS KFLAG is a condition parameter returned by the package after each call to one of the routines. Negative values indicate conditions for which a warning message will be printed unless KWARN = 0. Positive values indicate conditions that may be of interest but are not errors. No warning message is printed if KFLAG is nonnegative. KFLAG = 0 Normal operation. = 1 One of the operands in FMADD or FMSUB was insignificant with respect to the other, so that the result was equal to the argument of larger magnitude. = 2 In converting an FM number to a one word integer in FMM2I, the FM number was not exactly an integer. The next integer toward zero was returned. = -1 NDIG was less than 2 or more than NDIGMX. = -2 MBASE was less than 2 or more than MXBASE. = -3 An exponent was out of range. = -4 Invalid input argument(s) to an FM routine. UNKNOWN was returned. = -5 + or - OVERFLOW was generated as a result from an FM routine. = -6 + or - UNDERFLOW was generated as a result from an FM routine. = -7 The input string (array) to FMINP was not legal. = -8 The character array was not large enough in an input or output routine. = -9 Precision could not be raised enough to provide all requested guard digits. Increasing NDIGMX in all the PARAMETER statements may fix this. UNKNOWN was returned. = -10 An FM input argument was too small in magnitude to convert to the machine's single or double precision in FMM2SP or FMM2DP. Check that the definitions of SPMAX and DPMAX in FMSET are correct for the current machine. Zero was returned. When a negative KFLAG condition is encountered, the value of KWARN determines the action to be taken. KWARN = 0 Execution continues and no message is printed. = 1 A warning message is printed and execution continues. = 2 A warning message is printed and execution stops. The default setting is KWARN = 1. When an overflow or underflow is generated for an operation in which an input argument was already an overflow or underflow, no additional message is printed. When an unknown result is generated and an input argument was already unknown, no additional message is printed. In these cases the negative KFLAG value is still returned. IM routines handle exceptions like OVERFLOW or UNKNOWN in the same way as FM routines. When using IMMPY, the product of two large positive integers will return +OVERFLOW. The routine IMMPYM can be used to obtain a modular result without overflow. The largest representable IM integer is MBASE**NDIGMX - 1. For example, if MBASE is 10**7 and NDIGMX is set to 256, integers less than 10**1792 can be used. 6. OTHER PARAMETERS KRAD = 0 All angles in the trigonometric functions and inverse functions are measured in degrees. = 1 All angles are measured in radians. (Default) KROUND = 0 All final results are chopped (rounded toward zero). Intermediate results are rounded. = 1 All results are rounded to the nearest FM number, or to the value with an even last digit if the result is halfway between two FM numbers. (Default) KSWIDE defines the maximum screen width to be used for all unit KW output. Default is 80. KESWCH controls the action taken in FMINP and other input routines for strings like 'E7' that have no digits before the exponent field. Default is for 'E7' to translate like '1.0E+7'. CMCHAR defines the exponent letter to be used for FM variable output. Default is 'M', as in 1.2345M+678. KDEBUG = 0 Error checking is not done for valid input arguments and parameters like NDIG and MBASE upon entry to each routine. (Default) = 1 Some error checking is done. (Slower speed) See FMSET for additional description of these and other variables defining various FM conditions. 7. ARRAY DIMENSIONS The dimensions of the arrays in the FM package are defined using a PARAMETER statement at the top of each routine. The size of these arrays depends on the values of parameters NDIGMX and NBITS. NDIGMX is the maximum value the user may set for NDIG. NBITS is the number of bits used to represent integers for a given machine. See the EFFICIENCY discussion below. The standard version of FMLIB sets NDIGMX = 256, so on a 32-bit machine using MBASE = 10**7 the maximum precision is about 7*255+1 = 1786 significant digits. To change dimensions so that 10,000 significant digit calculation can be done, NDIGMX needs to be at least 10**4/7 + 5 = 1434. This allows for a few user guard digits to be defined when the package is initialized using CALL FMSET(10000). Changing 'NDIGMX = 256' to 'NDIGMX = 1434' everywhere in the package and the user's calling program will define all the new array sizes. If NDIG much greater than 256 is to be used and elementary functions will be needed, they will be faster if array MJSUMS is larger. The parameter defining the size of MJSUMS is set in the standard version by LJSUMS = 8*(LUNPCK+2). The 8 means that up to eight concurrent sums can be used by the elementary functions. The approximate number needed for best speed is given by the formula 0.051*Log(MBASE)*NDIG**(1/3) + 1.85 For example, with MBASE=10**7 and NDIG=1434 this gives 11. Changing 'LJSUMS = 8*(LUNPCK+2)' to 'LJSUMS =11*(LUNPCK+2)' everywhere in the package and the user's calling program will give slightly better speed. FM numbers in packed format have dimension 0:LPACK, and those in unpacked format have dimension 0:LUNPCK. 8. PORTABILITY In FMSET there is some machine-dependent code that attempts to approximate the largest representable integer value. The current code works on all machines tested, but if an FM run fails, check the MAXINT and INTMAX loops in FMSET. Values for SPMAX and DPMAX are also defined in FMSET that should be set to values near overflow for single precision and double precision. Setting KDEBUG = 1 may also identify some errors if a run fails. Some compilers object to a function like FMCOMP with side effects such as changing KFLAG or other common variables. Blocks of code in FMCOMP and IMCOMP that modify common are identified so they may be removed or commented out to produce a function without side effects. This disables trace printing in FMCOMP and IMCOMP, and error codes are not returned in KFLAG. See FMCOMP and IMCOMP for further details. All variables are explicitly declared in each routine. There is a commented IMPLICIT NONE statement in each routine that can be enabled to get more compiler diagnostic information in some testing or debugging situations. 9. NEW FOR VERSION 1.1 Version 1.0 used integer arrays and integer arithmetic internally to perform the multiple precision operations. Version 1.1 uses double precision arithmetic and arrays internally. This is usually faster at higher precisions, and on many machines it is also faster at lower precisions. Version 1.1 is written so that the arithmetic used can easily be changed from double precision to integer, or any other available arithmetic type. This permits the user to make the best use of a given machine's arithmetic hardware. See the EFFICIENCY discussion below. Several routines have undergone minor modification, but only a few changes should affect programs that used FM 1.0. Many of the routines are faster in version 1.1, because code has been added to take advantage of special cases for individual functions instead of using general formulas that are more compact. For example, there are separate routines using series for SINH and COSH instead of just calling EXP. FMEQU was the only routine that required the user to give the value of the current precision. This was to allow automatic rounding or zero-padding when changing precision. Since few user calls change precision, a new routine has been added for this case. FMEQ now handles this case and has a simple argument list that does not include the value of NDIG. FMEQU is used for changing precision. See the list of FM routines above for details. All variable names beginning with M in the package are now declared as double precision, so FM common blocks in the user's program need D.P. declarations, and FM variables (arrays) used in the calling program need to be D.P. /FMUSER/ is a common block holding parameters that define the arithmetic to be used and other user options. Several new variables have been added, including screen width to be used for output. See above for further description. /FMSAVE/ is a common block for saving constants to avoid re-computing them. Several new variables have been added. /FMBUFF/ is a common block containing a character array used to format FM numbers for output. Two new items have been added. New routines: All the IM routines are new for version 1.1. FMADDI increments an FM number by a small integer. It runs in O(1) time, on the average. FMCHSH returns both SINH(MA) and COSH(MA). When both are needed, this is almost twice as fast as making separate calls to FMCOSH and FMSINH. FMCSSN returns both SIN(MA) and COS(MA). When both are needed, this is almost twice as fast as making separate calls to FMCOS and FMSIN. FMFORM uses a format string to convert an FM number to a character string. FMFPRT prints an FM number using a format string. FMREAD reads an FM number written using FMWRIT. FMRPWR computes an FM number raised to a rational power. For cube roots and similar rational powers it is usually much faster than FMPWR. FMSQR squares an FM number. It is faster than using FMMPY. FMST2M converts character strings to FM format. Since FMINP converts character arrays, this routine can be more convenient for easily defining an FM number. For example, CALL FMST2M('123.4',MA). FMWRIT writes an FM number using a format for multi-line numbers with '&' at the end of all but the last line of a multi-line number. This allows automatic reading of FM numbers without needing to know the base, precision or format under which they were written. One extra word has been added to the dimensions of all FM numbers. Word zero in each array contains a value used to monitor cancellation error arising from addition or subtraction. This value approximates the number of bits of precision for an FM value. It allows higher level FM functions to detect cases where too much cancellation has occurred. KACCSW is a switch variable in COMMON /FM/ used internally to enable cancellation error monitoring. 10. EFFICIENCY To take advantage of hardware architecture on different machines, the package has been designed so that the arithmetic used to perform the multiple precision operations can easily be changed. All variables that must be changed to get a different arithmetic have names beginning with 'M' and are declared using REAL (KIND(0.0D0)) :: m.... For example, to change the package to use integer arithmetic internally, make these two changes everywhere in the package: change 'REAL (KIND(0.0D0)) :: m' to 'INTEGER m', change 'DINT(' to 'INT('. On some systems, changing 'DINT(' to '(' may give better speed. When changing to a different type of arithmetic, all FM common blocks and arrays in the user's program must be changed to agree. In a few places in FM, where a DINT function is not supposed to be changed, it is spelled 'DINT (' so the global change will not find it. This version restricts the base used to be also representable in integer variables, so using precision above double usually does not save much time unless integers can also be declared at a higher precision. Using IEEE Extended would allow a base of around 10**9 to be chosen, but the delayed digit-normalization method used for multiplication and division means that a slightly smaller base like 10**8 would usually run faster. This would usually not be much faster than using 10**7 with double precision. The value of NBITS defined as a parameter in most FM routines refers to the number of bits used to represent integers in an M-variable word. Typical values for NBITS are: 24 for IEEE single precision, 32 for integer, 53 for IEEE double precision. NBITS controls only array size, so setting it too high is ok, but then the program will use more memory than necessary. For cases where special compiler directives or minor re-writing of the code may improve speed, several of the most important loops in FM are identified by comments containing the string '(Inner Loop)'. ------------------------------------------------------------------------ -------------------------- zmlib.f90 Notes --------------------------- The ZM routines perform complex floating-point multiple-precision arithmetic. These routines use a Fortran 90 version of the FMLIB package (version 1.1) for real floating-point multiple-precision arithmetic. FMLIB is Algorithm 693, ACM Transactions on Mathematical Software, Vol. 17, No. 2, June 1991, pages 273-283. This package and FMLIB 1.1 use double precision arithmetic and arrays internally. This is usually faster at higher precision, and on many machines it is also faster at lower precision. Both packages are written so that the arithmetic used can easily be changed from double precision to integer, or another available arithmetic type. See the EFFICIENCY discussion in the fmlib.f90 Notes for details. 1. INITIALIZING THE PACKAGE Before calling any routine in the package, several variables in the common blocks /FMUSER/, /FM/, /FMSAVE/, /FMBUFF/, and /ZMUSER/ must be initialized. These common blocks contain information that is saved between calls, so they should be declared in the main program. Subroutine ZMSET initializes these variables to default values and defines all machine-dependent values in the package. After calling ZMSET once at the start of a program, the user may sometimes want to reset some of the variables in common blocks /FMUSER/ or /ZMUSER/. 2. REPRESENTATION OF ZM NUMBERS The format for complex FM numbers (called ZM numbers below) is very similar to that for real FM numbers in FMLIB. Each ZM array holds two FM numbers to represent the real and imaginary parts of a complex number. Each ZM array is twice as long as a corresponding FM array, with the imaginary part starting at the midpoint of the array. As with FM, there are packed and unpacked formats for the numbers. 3. INPUT/OUTPUT ROUTINES All versions of the input routines perform free-format conversion from characters to ZM numbers. a. Conversion to or from a character array ZMINP converts from a character*1 array to an ZM number. ZMOUT converts an ZM number to base 10 and formats it for output as an array of type character*1. The output is left justified in the array, and the format is defined by variables in common, so that a separate format definition does not have to be provided for each output call. For the output format of ZM numbers, JFORM1 and JFORM2 determine the format for the individual parts of a complex number as described in the FMLIB documentation. JFORMZ (in /ZMUSER/) determines the combined output format of the real and imaginary parts. JFORMZ = 1 normal setting : 1.23 - 4.56 i = 2 use capital I : 1.23 - 4.56 I = 3 parenthesis format ( 1.23 , -4.56 ) JPRNTZ (in /ZMUSER/) controls whether to print real and imaginary parts on one line whenever possible. JPRNTZ = 1 print both parts as a single string : 1.23456789M+321 - 9.87654321M-123 i = 2 print on separate lines without the 'i' : 1.23456789M+321 -9.87654321M-123 b. Conversion to or from a character string ZMST2M converts from a character string to an ZM number. ZMFORM converts an ZM number to a character string according to a format provided in each call. The format descriptions are more like that of a Fortran FORMAT statement, and integer or fixed-point output is right justified. c. Direct read or write ZMPRNT uses ZMOUT to print one ZM number. ZMFPRT uses ZMFORM to print one ZM number. ZMWRIT writes ZM numbers for later input using ZMREAD. ZMREAD reads ZM numbers written by ZMWRIT. For further description of these routines, see the list of ZM routines above. 4. ARRAY DIMENSIONS The parameters LPACKZ and LUNPKZ define the size of the packed and unpacked ZM arrays. The real part starts at the beginning of the array, and the imaginary part starts at word KPTIMP for packed format or at word KPTIMU for unpacked format. =========================================================================== =========================================================================== SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'Drivers' then mkdir 'Drivers' fi cd 'Drivers' if test ! -d 'Dp' then mkdir 'Dp' fi cd 'Dp' if test -f 'RES1' then echo shar: will not over-write existing file "'RES1'" else cat << SHAR_EOF > 'RES1' 53 cases tested. No errors were found. SHAR_EOF fi # end of overwriting check if test -f 'RES2' then echo shar: will not over-write existing file "'RES2'" else cat << SHAR_EOF > 'RES2' Sample 1. Find a root of f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0. Iteration Newton Approximation 0 .560000000000000000000000000000 + 1.060000000000000000000000000000 i 1 .561964780980333719745880263787 + 1.061135231152741154895778904059 i 2 .561958308372772219534516409947 + 1.061134679566247415769456345141 i 3 .561958308335403235495113920123 + 1.061134679604332556981397796290 i 4 .561958308335403235498111195347 + 1.061134679604332556983391239059 i 5 .561958308335403235498111195347 + 1.061134679604332556983391239059 i Sample 2. 44 terms were added to get Exp(1.23-2.34i) Result= -2.379681796854777515745457977697 - 2.458032970832342652397461908326 i All results were ok. SHAR_EOF fi # end of overwriting check if test -f 'RES3' then echo shar: will not over-write existing file "'RES3'" else cat << SHAR_EOF > 'RES3' 108 cases tested. No errors were found. SHAR_EOF fi # end of overwriting check if test -f 'RES4' then echo shar: will not over-write existing file "'RES4'" else cat << SHAR_EOF > 'RES4' Sample 1. Find a root of f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0. Iteration Newton Approximation 0 3.120000000000000000000000000000000000000000000000000000000000 1 3.120656718532108533919391265947916793506741449899073468862023 2 3.120656215327022122238354686569835883519704471397219749798884 3 3.120656215326726500470956115551705969611230193197937042123082 4 3.120656215326726500470956013523797484654623935599078168006617 5 3.120656215326726500470956013523797484654623935599066014988828 6 3.120656215326726500470956013523797484654623935599066014988828 Sample 2. 109 terms were added Zeta(3) = 1.202056903159594285399738161511449990764986292340498881792272 Sample 3. 22 values were tested p = 1000000000000000000000000000000000000000000000000000000000000000659661 All results were ok. SHAR_EOF fi # end of overwriting check if test -f 'RES5' then echo shar: will not over-write existing file "'RES5'" else cat << SHAR_EOF > 'RES5' 603 cases tested. No errors were found. SHAR_EOF fi # end of overwriting check if test -f 'RES6' then echo shar: will not over-write existing file "'RES6'" else cat << SHAR_EOF > 'RES6' Sample 1. Real root of f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0. Iteration Newton Approximation 0 3.120000000000000000000000000000000000000000000000000000000000 1 3.120656718532108533919391265947916793506741449899073468862023 2 3.120656215327022122238354686569835883519704471397219749798884 3 3.120656215326726500470956115551705969611230193197937042123082 4 3.120656215326726500470956013523797484654623935599078168006617 5 3.120656215326726500470956013523797484654623935599066014988828 6 3.120656215326726500470956013523797484654623935599066014988828 Sample 2. 109 terms were added Zeta(3) = 1.202056903159594285399738161511449990764986292340498881792272 Sample 3. 22 values were tested p = 1000000000000000000000000000000000000000000000000000000000000000659661 Sample 4. Complex root of f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0. Iteration Newton Approximation 0 .560000000000000000000000000000 + 1.060000000000000000000000000000 i 1 .561964780980333719745880263787 + 1.061135231152741154895778904059 i 2 .561958308372772219534516409947 + 1.061134679566247415769456345141 i 3 .561958308335403235495113920123 + 1.061134679604332556981397796290 i 4 .561958308335403235498111195347 + 1.061134679604332556983391239059 i 5 .561958308335403235498111195347 + 1.061134679604332556983391239059 i Sample 5. 44 terms were added to get Exp(1.23-2.34i) Result= -2.379681796854777515745457977697 - 2.458032970832342652397461908326 i All results were ok. SHAR_EOF fi # end of overwriting check if test -f 'driver1.f90' then echo shar: will not over-write existing file "'driver1.f90'" else cat << SHAR_EOF > 'driver1.f90' PROGRAM test ! David M. Smith 6-14-96 ! This is a test program for ZMLIB 1.1, a multiple-precision complex ! arithmetic package. Most of the ZM routines are tested, and the ! results are checked to 50 significant digits. ! This program uses both ZMLIB.f90 and FMLIB.f90. ! These five common blocks contain information that must be saved ! between calls, so they should be declared in the main program. ! The parameter statement defines array sizes and pointers, and ! contains the FMLIB parameters, followed by ZMLIB parameters. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Local Scalars .. INTEGER :: klog, ncase, nerror ! Character strings used for input and output. CHARACTER (160) :: st1, st2 ! Declare arrays for ZM complex variables (MA, MB, MC, MD) ! and for FM real variables (MAFM, MBFM). All are in ! unpacked format. ! .. ! .. Local Arrays .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Subroutines .. EXTERNAL test1, test2, test3, test4, test5, test6, test7, test8, zmset ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, jformz, jprntz, kaccsw, & kdebug, keswch, kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, & ncall, ndg2mx, ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, & ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /zmuser/jformz, jprntz ! .. ! Set precision to give at least 50 significant digits ! and initialize the FMLIB package. CALL zmset(50) ! Write output to the standard FM output (unit KW, defined ! in subroutine FMSET), and also to the file TESTZM.LOG. klog = 18 OPEN (klog,file='TESTZM.LOG') ! NERROR is the number of errors found. ! NCASE is the number of cases tested. nerror = 0 ! Test input and output conversion. CALL test1(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test add and subtract. CALL test2(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test multiply, divide and square root. CALL test3(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test exponentials. CALL test4(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test logarithms. CALL test5(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test trigonometric functions. CALL test6(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test inverse trigonometric functions. CALL test7(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test hyperbolic functions. CALL test8(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! End of tests. IF (nerror==0) THEN WRITE (kw,90000) ncase WRITE (klog,90000) ncase ELSE ! Write some of the initialized values in common. WRITE (klog,*) ' NDIG,MBASE,JFORM1,JFORM2,KRAD = ' WRITE (klog,*) ndig, mbase, jform1, jform2, krad WRITE (klog,*) ' KW,NTRACE,LVLTRC,KFLAG,KWARN,KROUND = ' WRITE (klog,*) kw, ntrace, lvltrc, kflag, kwarn, kround WRITE (klog,*) ' NCALL,MXEXP,MXEXP2,KACCSW,MEXPUN,MEXPOV' WRITE (klog,*) ncall, mxexp, mxexp2, kaccsw, mexpun, mexpov WRITE (klog,*) ' MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX = ' WRITE (klog,*) munkno, iunkno, runkno, mxbase, ndg2mx WRITE (klog,*) ' MAXINT,INTMAX,SPMAX,DPMAX = ' WRITE (klog,*) maxint, intmax, spmax, dpmax WRITE (klog,*) ' ALOGMB,ALOGM2,ALOGMX,ALOGMT,DLOGMB,DLOGTN =' WRITE (klog,*) alogmb, alogm2, alogmx, alogmt, dlogmb, dlogtn WRITE (klog,*) ' DLOGTW,DLOGTP,DLOGPI,DPPI =' WRITE (klog,*) dlogtw, dlogtp, dlogpi, dppi WRITE (klog,*) ' DPEPS,DLOGEB =' WRITE (klog,*) dpeps, dlogeb WRITE (kw,90010) ncase, nerror WRITE (klog,90010) ncase, nerror END IF WRITE (kw,*) ' End of run.' STOP 90000 FORMAT (///1X,I5,' cases tested. No errors were found.'/) 90010 FORMAT (///1X,I5,' cases tested.',I4,' error(s) found.'/) END PROGRAM test SUBROUTINE test1(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Input and output testing. ! Logical function for comparing FM numbers. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zm2i2m, zmabs, zmdivi, zmform, zmmpyi, & zmst2m, zmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 1 CALL zmst2m('123 + 456 i',ma) CALL zm2i2m(123,456,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-48,mbfm) ! Use the .NOT. because FMCOMP returns FALSE for special ! cases like MD = UNKNOWN, and these should be treated ! as errors for these tests. IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMST2M',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 2 st1 = '0.3505154639175257731958762886597938144329896907216495 + ' // & '0.7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,ma) CALL zm2i2m(34,71,mc) CALL zmdivi(mc,97,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMST2M',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 3 st1 = '0.3505154639175257731958762886597938144329896907216495E-5 ' // & '+ 0.7319587628865979381443298969072164948453608247422680D-5 i' CALL zmst2m(st1,ma) CALL zm2i2m(34,71,mc) CALL zmdivi(mc,9700000,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-55,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMST2M',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 4 st1 = '7.699115044247787610619469026548672566371681415929204e 03 ' // & '- 5.221238938053097345132743362831858407079646017699115M 03 I' CALL zmst2m(st1,ma) CALL zm2i2m(87,-59,mc) CALL zmdivi(mc,113,mc) CALL zmmpyi(mc,10000,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-47,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMST2M',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 5 st1 = '7.699115044247787610619469026548672566371681415929204e+3 ' // & '- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL zmst2m(st1,ma) CALL zmform('F53.33','F50.30',ma,st2) CALL zmst2m(st2,ma) st1 = '7699.115044247787610619469026548673 ' // & '-5221.238938053097345132743362831858 i' CALL zmst2m(st1,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-30,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 6 st1 = '7.699115044247787610619469026548672566371681415929204e+3 ' // & '- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL zmst2m(st1,ma) CALL zmform('I9','I7',ma,st2) CALL zmst2m(st2,ma) st1 = '7699 -5221 i' CALL zmst2m(st1,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(0,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 7 st1 = '7.699115044247787610619469026548672566371681415929204e+3 ' // & '- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL zmst2m(st1,ma) CALL zmform('E59.50','E58.49',ma,st2) CALL zmst2m(st2,ma) st1 = '7.6991150442477876106194690265486725663716814159292E3' // & '- 5.221238938053097345132743362831858407079646017699E3 i' CALL zmst2m(st1,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-48,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 8 st1 = '7.699115044247787610619469026548672566371681415929204e+3 ' // & '- 5.221238938053097345132743362831858407079646017699115M+3 i' CALL zmst2m(st1,ma) CALL zmform('1PE59.50','1PE58.49',ma,st2) CALL zmst2m(st2,ma) CALL zmst2m(st1,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-44,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing input and output routines.') END SUBROUTINE test1 SUBROUTINE test2(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test add and subtract. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zm2i2m, zmabs, zmadd, zmst2m, zmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 9 CALL zmst2m('123 + 456 i',ma) CALL zmst2m('789 - 543 i',mb) CALL zmadd(ma,mb,ma) CALL zm2i2m(912,-87,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(0,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMADD ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 10 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) st1 = '.3505154639175257731958762886597938144329896907216495 ' // & '+ .7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,mb) CALL zmadd(ma,mb,ma) st2 = '1.1204269683423045342578231913146610710701578323145698 ' // & '+ 0.2098348690812882036310555606240306541373962229723565 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMADD ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 11 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) st1 = '.3505154639175257731958762886597938144329896907216495 ' // & '+ .7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,mb) CALL zmsub(ma,mb,ma) st2 = '0.4193960405072529878660706139950734422041784508712709 ' // & '- 1.2540826566919076726576042331904023355533254265121795 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSUB ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 12 st1 = '.7699115044247787610619469026548672566371681415929204E3 ' // & '- .5221238938053097345132743362831858407079646017699115E3 i' CALL zmst2m(st1,ma) st1 = '.3505154639175257731958762886597938144329896907216495 ' // & '+ .7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,mb) CALL zmsub(ma,mb,ma) st2 = '769.5609889608612352887510263662074628227351519021987045 ' // & '- 522.8558525681963324514186661800930572028099625946537725 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-47,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSUB ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing add and subtract routines.') END SUBROUTINE test2 SUBROUTINE test3(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test multiply, divide and square root. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zm2i2m, zmabs, zmdiv, zmdivi, zmmpy, & zmmpyi, zmsqr, zmsqrt, zmst2m, zmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 13 CALL zmst2m('123 + 456 i',ma) CALL zmst2m('789 - 543 i',mb) CALL zmmpy(ma,mb,ma) CALL zm2i2m(344655,292995,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(0,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMMPY ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 14 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) st1 = '.3505154639175257731958762886597938144329896907216495 ' // & '+ .7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,mb) CALL zmmpy(ma,mb,ma) st2 = '0.6520390475321594745005017790347596022260742632971444 ' // & '+ 0.3805309734513274336283185840707964601769911504424779 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMMPY ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 15 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) st1 = '.3505154639175257731958762886597938144329896907216495 ' // & '+ .7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,mb) CALL zmdiv(ma,mb,ma) st2 = '-.1705178497731560089737969128653459210208765017614861 ' // & '- 1.1335073636829696356072949942949842987114804337239972 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMDIV ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 16 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmmpyi(ma,36,ma) st2 = '27.7168141592920353982300884955752212389380530973451327 ' // & '- 18.7964601769911504424778761061946902654867256637168142 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-48,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMMPYI',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 17 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmdivi(ma,37,ma) st2 = '2.080841903850753408275532169337479071992346328629514E-2 ' // & '- 1.411145658933269552738579287251853623535039464243004E-2 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-52,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMDIVI',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 18 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmsqr(ma,ma) st2 = '0.3201503641632077688150990680554467851828647505677813 ' // & '- 0.8039783851515388832328295089670295246299631921058814 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSQR ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 19 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmsqrt(ma,ma) st2 = '0.9219999909012323458336720551458583330580388434229845 ' // & '- 0.2831474506279259570386845864488094697732718981999941 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSQRT',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing multiply, divide and square root routines.') END SUBROUTINE test3 SUBROUTINE test4(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test exponentials. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zmabs, zmexp, zmipwr, zmpwr, zmrpwr, & zmst2m, zmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 20 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmexp(ma,ma) st2 = '1.8718374504057787925867989348073888855260008469310002 ' // & '- 1.0770279996847678711699041910427261417963102075889234 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMEXP ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 21 st1 = '5.7699115044247787610619469026548672566371681415929204 ' // & '- 4.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmexp(ma,ma) st2 = '-60.6144766542152809520229386164396710991242264070603612 ' // & '+ 314.7254994809539691403004121118801578835669635535466592 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-47,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMEXP ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 22 st1 = '1.7699115044247787610619469026548672566371681415929204 ' // & '- 1.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmipwr(ma,45,ma) st2 = '31595668743300099.70429472191424818167262151605608585179 ' // & '- 19209634448276799.67717448173630165852744930837930753788 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-33,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMIPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 23 st1 = '1.7699115044247787610619469026548672566371681415929204 ' // & '- 1.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmipwr(ma,-122,ma) st2 = '3.1000215641022021714480000129414241564868699479432E-46 ' // & '- 1.1687846789859477815450163510927243367234863123667E-45 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-93,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMIPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 24 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) st1 = '.3505154639175257731958762886597938144329896907216495 ' // & '+ .7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,mb) CALL zmpwr(ma,mb,ma) st2 = '1.4567089343012352449621841355636496276866203747888724 ' // & '- 0.3903177712261966292764255714390622205129978923650749 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMPWR ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 25 st1 = '.3505154639175257731958762886597938144329896907216495 ' // & '+ .7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,ma) st1 = '2.7699115044247787610619469026548672566371681415929204 ' // & '- 0.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,mb) CALL zmpwr(ma,mb,ma) st2 = '-1.0053105716678380336247948739245187868180079734997482 ' // & '- 0.0819537653234704467729051473979237153087038930127116 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMPWR ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 26 st1 = '0.7699115044247787610619469026548672566371681415929204 ' // & '- 0.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmrpwr(ma,2,7,ma) st2 = '0.9653921326136512316639621651337975772631340364271270 ' // & '- 0.1659768285667051396562270035411852432430188906482848 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMRPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 27 st1 = '0.7699115044247787610619469026548672566371681415929204 ' // & '- 0.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmrpwr(ma,-19,7,ma) st2 = '-0.0567985880053556315170006800325686036902111276420647 ' // & '+ 1.2154793972711356706410882510363594270389067962568571 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMRPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing exponential routines.') END SUBROUTINE test4 SUBROUTINE test5(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test logarithms. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zmabs, zmlg10, zmln, zmst2m, zmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 28 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmln(ma,ma) st2 = '-0.0722949652393911311212450699415231782692434885813725 ' // & '- 0.5959180055163009910007765127008371205749515965219804 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMLN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 29 st1 = '.7699115044247787610619469026548672566371681415929204E28 ' // & '- .5221238938053097345132743362831858407079646017699115E28 i' CALL zmst2m(st1,ma) CALL zmln(ma,ma) st2 = '64.4000876385938880213825156612206746345615981930242708 ' // & '- 0.5959180055163009910007765127008371205749515965219804 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-48,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMLN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 30 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmlg10(ma,ma) st2 = '-0.0313973044728549715287589498363619677438302809470943 ' // & '- 0.2588039014625211035392823012785304771809982053965284 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMLG10',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 31 st1 = '.7699115044247787610619469026548672566371681415929204E82 ' // & '- .5221238938053097345132743362831858407079646017699115E82 i' CALL zmst2m(st1,ma) CALL zmlg10(ma,ma) st2 = '81.9686026955271450284712410501636380322561697190529057 ' // & '- 0.2588039014625211035392823012785304771809982053965284 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-48,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMLG10',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing logarithm routines.') END SUBROUTINE test5 SUBROUTINE test6(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test trigonometric functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zmabs, zmcos, zmcssn, zmsin, zmst2m, & zmsub, zmtan ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 32 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmcos(ma,ma) st2 = '0.8180802525254482451348613286211514555816444253416895 ' // & '+ 0.3801751200076938035500853542125525088505055292851393 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCOS ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 33 st1 = '34.7699115044247787610619469026548672566371681415929204 ' // & '- 42.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmcos(ma,ma) st2 = '-1432925478410268113.5816466154230974355002592549420099 ' // & '- 309002816679456015.00151246245263842483282458519462258 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-31,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCOS ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 34 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmsin(ma,ma) st2 = '0.7931260548991613428648822413402447097755865697557818 ' // & '- 0.3921366045897070762848927655743167937790944353110710 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSIN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 35 st1 = '34.7699115044247787610619469026548672566371681415929204 ' // & '- 42.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmsin(ma,ma) st2 = '-3.090028166794560150015124624526384249047272360765358E17 ' // & '+ 1.432925478410268113581646615423097435166828182950161E18 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-31,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSIN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 36 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmtan(ma,ma) st2 = '0.6141156219447569167198437040270236055089243090199979 ' // & '- 0.7647270337230070156308196055474639461102792169274526 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMTAN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 37 st1 = '35.7699115044247787610619469026548672566371681415929204 ' // & '- 43.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmtan(ma,ma) st2 = '2.068934241218867332441292427642153175237611151321340E-38 ' // & '- 1.000000000000000000000000000000000000023741659169354 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMTAN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 38 st1 = '0.3505154639175257731958762886597938144329896907216495 ' // & '+ 0.7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,ma) CALL zmcssn(ma,ma,mc) st2 = '1.2022247452809115256533054407001508718694617802593324 ' // & '- 0.2743936538120352873902095801531325075994392065668943 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCSSN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 39 st1 = '0.3505154639175257731958762886597938144329896907216495 ' // & '+ 0.7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,ma) CALL zmcssn(ma,mc,ma) st2 = '0.4395486978082638069281369170831952476351663772871008 ' // & '+ 0.7505035100906417134864779281080728222900154610025883 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCSSN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing trigonometric routines.') END SUBROUTINE test6 SUBROUTINE test7(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test inverse trigonometric functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zmabs, zmacos, zmasin, zmatan, zmst2m, & zmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 40 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmacos(ma,ma) st2 = '0.8797127900868121872960714368309657795959216549012347 ' // & '+ 0.6342141347945396859119941874681961111936156338608130 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMACOS',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 41 st1 = '.7699115044247787610619469026548672566371681415929204E12 ' // & '- .5221238938053097345132743362831858407079646017699115E12 i' CALL zmst2m(st1,ma) CALL zmacos(ma,ma) st2 = '0.5959180055163009910007767810953294528367807973983794 ' // & '+28.2518733312491023865118844008522768856672089946951468 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-48,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMACOS',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 42 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmasin(ma,ma) st2 = '0.6910835367080844319352502548087856625026630447863182 ' // & '- 0.6342141347945396859119941874681961111936156338608130 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMASIN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 43 st1 = '.7699115044247787610619469026548672566371681415929204E13 ' // & '- .5221238938053097345132743362831858407079646017699115E13 i' CALL zmst2m(st1,ma) CALL zmasin(ma,ma) st2 = '0.9748783212785956282305451762549693982010148111568094 ' // & '-30.5544584242431480705298759613446206186670533428066404 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-48,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMASIN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 44 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmatan(ma,ma) st2 = '0.7417952692265900376512911713942700568648670953521258 ' // & '- 0.3162747143126729004878357203292329539837025170484857 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMATAN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 45 st1 = '.7699115044247787610619469026548672566371681415929204E13 ' // & '- .5221238938053097345132743362831858407079646017699115E13 i' CALL zmst2m(st1,ma) CALL zmatan(ma,ma) st2 = ' 1.570796326794807650905529836436131532596233124329403 ' // & '-6.033484162895927601809954710695221401671437742867605E-14 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMATAN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing inverse trigonometric routines.') END SUBROUTINE test7 SUBROUTINE test8(ma,mb,mc,md,mafm,mbfm,st1,st2,ncase,nerror,klog) ! Test hyperbolic functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (160) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmi2m, fmipwr, zmabs, zmchsh, zmcosh, zmsinh, zmst2m, & zmsub, zmtanh ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 46 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmcosh(ma,ma) st2 = '1.1365975275870879962259716562608779977957563621412079 ' // & '- 0.4230463404769118342540441830446134405410543954181579 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-49,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCOSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 47 st1 = '34.7699115044247787610619469026548672566371681415929204 ' // & '- 42.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmcosh(ma,ma) st2 = '69552104658681.7558589320148420094288419217262200765435 ' // & '+ 626163773308016.884007302915197616300902876551542156676 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-35,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCOSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 48 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmsinh(ma,ma) st2 = '0.7352399228186907963608272785465108877302444847897922 ' // & '- 0.6539816592078560369158600079981127012552558121707655 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSINH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 49 st1 = '34.7699115044247787610619469026548672566371681415929204 ' // & '- 42.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmsinh(ma,ma) st2 = '6.955210465868175585893201484192181376093291191637290E 13 ' // & '+ 6.261637733080168840073029151984050820616907795167046E 14 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-35,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMSINH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 50 st1 = '.7699115044247787610619469026548672566371681415929204 ' // & '- .5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmtanh(ma,ma) st2 = '0.7562684782933185240709480231996041186654551038993505 ' // & '- 0.2938991498221693198532255749292372853685311106820169 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMTANH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 51 st1 = '35.7699115044247787610619469026548672566371681415929204 ' // & '- 43.5221238938053097345132743362831858407079646017699115 i' CALL zmst2m(st1,ma) CALL zmtanh(ma,ma) st2 = '9.999999999999999999999999999998967653135180689424497E-01 ' // & '+ 1.356718776492102400812550018433337461876455254467192E-31 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMTANH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 52 st1 = '0.3505154639175257731958762886597938144329896907216495 ' // & '+ 0.7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,ma) CALL zmchsh(ma,ma,mc) st2 = '0.7900326499280864816444807620997665088044412803737969 ' // & '+ 0.2390857359988804105051429301542214823277594407302781 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCHSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 53 st1 = '0.3505154639175257731958762886597938144329896907216495 ' // & '+ 0.7319587628865979381443298969072164948453608247422680 i' CALL zmst2m(st1,ma) CALL zmchsh(ma,mc,ma) st2 = '0.2661087555034471983220879532235334422670297141428191 ' // & '+ 0.7098057980612199357870532628105009808447460332437714 i' CALL zmst2m(st2,mc) CALL zmsub(ma,mc,md) CALL zmabs(md,mafm) CALL fmi2m(10,mbfm) CALL fmipwr(mbfm,-50,mbfm) IF ( .NOT. fmcomp(mafm,'LE',mbfm)) THEN CALL errprt('ZMCHSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing hyperbolic routines.') END SUBROUTINE test8 SUBROUTINE errprt(nrout,m1,name1,m2,name2,m3,name3,ncase,nerror,klog) ! Print error messages. ! M1 is the value to be tested, as computed by the routine named NROUT. ! M2 is the reference value, usually converted using ZMST2M. ! M3 is ABS(M1-M2), and ERRPRT is called if this is too big. ! NAME1,NAME2,NAME3 are strings identifying which variables in main ! correspond to M1,M2,M3. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (2) :: name1, name2, name3 CHARACTER (6) :: nrout ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: m1(0:lunpkz), m2(0:lunpkz), m3(0:lunpkz) ! .. ! .. Local Scalars .. INTEGER :: kwsave ! .. ! .. External Subroutines .. EXTERNAL zmprnt ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. nerror = nerror + 1 WRITE (kw,90000) ncase, nrout WRITE (klog,90000) ncase, nrout ! Temporarily change KW to KLOG so ZMPRNT ! will write to the log file. kwsave = kw kw = klog WRITE (klog,90010) name1 CALL zmprnt(m1) WRITE (klog,90010) name2 CALL zmprnt(m2) WRITE (klog,90010) name3 CALL zmprnt(m3) kw = kwsave RETURN 90000 FORMAT (//' Error in case',I3,'. The routine',' being tested was ',A6) 90010 FORMAT (1X,A2,' =') END SUBROUTINE errprt SHAR_EOF fi # end of overwriting check if test -f 'driver2.f90' then echo shar: will not over-write existing file "'driver2.f90'" else cat << SHAR_EOF > 'driver2.f90' PROGRAM sample ! David M. Smith 9-17-96 ! This is a test program for ZMLIB 1.1, a multiple-precision real ! arithmetic package. A few example ZM calculations are carried ! out using 30 significant digit precision. ! This program uses both ZMLIB.f90 and FMLIB.f90. ! The output is saved in file ZMSAMPLE.LOG. A comparison file, ! ZMSAMPLE.CHK, is provided showing the expected output from 32-bit ! (IEEE arithmetic) machines. When run on other computers, all the ! numerical results should still be the same, but the number of terms ! needed for some of the results might be slightly different. The ! program checks all the results and the last line of the log file ! should be "All results were ok." !----------------------------------------------------------------------- ! These five common blocks contain information that must be saved ! between calls, so they should be declared in the main program. ! The parameter statement defines array sizes and pointers, and ! contains the FMLIB parameters, followed by ZMLIB parameters. !----------------------------------------------------------------------- ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lpackz = 2*lpack + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: lunpkz = 2*lunpck + 1 INTEGER, PARAMETER :: kptimp = lpack + 1 INTEGER, PARAMETER :: kptimu = lunpck + 1 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmbufz = 2*lmbuff + 10 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Local Scalars .. INTEGER :: iter, k, klog, nerror ! Character string used for input and output. CHARACTER (80) :: st1 ! Declare arrays for ZM variables. All are in ! unpacked format. ! .. ! .. Local Arrays .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mafm(0:lunpck), mb(0:lunpkz), mbfm(0:lunpck), & mc(0:lunpkz), md(0:lunpkz) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmst2m, zmabs, zmadd, zmaddi, zmdiv, zmdivi, zmeq, zmform, & zmi2m, zmmpy, zmmpyi, zmset, zmst2m, zmsub ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, dlogtw, dpeps, & dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, jformz, jprntz, kaccsw, & kdebug, keswch, kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, & ncall, ndg2mx, ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, & ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /zmuser/jformz, jprntz ! .. ! Set precision to give at least 30 significant digits ! and initialize both the ZMLIB and FMLIB packages. ! Note that any program using the ZM package MUST call ! ZMSET before using the package. CALL zmset(30) nerror = 0 ! Write output to the standard FM output (unit KW, defined ! in subroutine FMSET), and also to the file ZMSAMPLE.LOG. klog = 18 OPEN (klog,file='ZMSAMPLE.LOG') ! 1. Find a complex root of the equation ! f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0. ! Newton's method with initial guess x = .56 + 1.06 i. ! This version is not tuned for speed. See the ZMSQRT ! routine for possible ways to increase speed. ! Horner's rule is used to evaluate the function: ! f(x) = ((((x-3)*x+1)*x-4)*x+1)*x-6. ! MA is the previous iterate. ! MB is the current iterate. CALL zmst2m('.56 + 1.06 i',ma) ! Print the first iteration. WRITE (kw,90000) WRITE (klog,90000) CALL zmform('F32.30','F32.30',ma,st1) WRITE (kw,90010) 0, st1(1:69) WRITE (klog,90010) 0, st1(1:69) DO 10 iter = 1, 10 ! MC is f(MA). CALL zmeq(ma,mc) CALL zmaddi(mc,-3) CALL zmmpy(mc,ma,mc) CALL zmaddi(mc,1) CALL zmmpy(mc,ma,mc) CALL zmaddi(mc,-4) CALL zmmpy(mc,ma,mc) CALL zmaddi(mc,1) CALL zmmpy(mc,ma,mc) CALL zmaddi(mc,-6) ! MD is f'(MA). CALL zmmpyi(ma,5,md) CALL zmaddi(md,-12) CALL zmmpy(md,ma,md) CALL zmaddi(md,3) CALL zmmpy(md,ma,md) CALL zmaddi(md,-8) CALL zmmpy(md,ma,md) CALL zmaddi(md,1) CALL zmdiv(mc,md,mb) CALL zmsub(ma,mb,mb) ! Print each iteration. CALL zmform('F32.30','F32.30',mb,st1) WRITE (kw,90010) iter, st1(1:69) WRITE (klog,90010) iter, st1(1:69) ! Stop iterating if MA and MB agree to over ! 30 places. CALL zmsub(ma,mb,md) CALL zmabs(md,mafm) ! The ABS result is real -- do a real (FM) compare. CALL fmst2m('1.0E-31',mbfm) IF (fmcomp(mafm,'LT',mbfm)) GO TO 20 ! Set MA = MB for the next iteration. CALL zmeq(mb,ma) 10 CONTINUE ! Check the answer. 20 st1 = '0.561958308335403235498111195347453 +' // & '1.061134679604332556983391239058885 i' CALL zmst2m(st1,mc) CALL zmsub(mc,mb,md) CALL zmabs(md,mafm) CALL fmst2m('1.0E-31',mbfm) IF (fmcomp(mafm,'GT',mbfm)) THEN nerror = nerror + 1 WRITE (kw,90020) WRITE (klog,90020) END IF ! 2. Compute Exp(1.23-2.34i). ! Use the direct Taylor series. See the ZMEXP routine ! for a faster way to get Exp(x). ! MA is x. ! MB is the current term, x**n/n!. ! MC is the current partial sum. CALL zmst2m('1.23-2.34i',ma) CALL zmi2m(1,mb) CALL zmeq(mb,mc) DO 30 k = 1, 100 CALL zmmpy(mb,ma,mb) CALL zmdivi(mb,k,mb) CALL zmadd(mc,mb,mc) ! Test for convergence. KFLAG will be 1 if the result ! of the last add or subtract is the same as one of the ! input arguments. IF (kflag==1) THEN WRITE (kw,90030) k WRITE (klog,90030) k GO TO 40 END IF 30 CONTINUE ! Print the result. 40 CALL zmform('F33.30','F32.30',mc,st1) WRITE (kw,90040) st1(1:70) WRITE (klog,90040) st1(1:70) ! Check the answer. st1 = '-2.379681796854777515745457977696745 -' // & '2.458032970832342652397461908326042 i' CALL zmst2m(st1,md) CALL zmsub(md,mc,md) CALL zmabs(md,mafm) CALL fmst2m('1.0E-31',mbfm) IF (fmcomp(mafm,'GT',mbfm)) THEN nerror = nerror + 1 WRITE (kw,90050) WRITE (klog,90050) END IF IF (nerror==0) THEN WRITE (kw,90060) ' All results were ok.' WRITE (klog,90060) ' All results were ok.' END IF STOP 90000 FORMAT (//' Sample 1. Find a root of f(x) = x**5 - 3x**4 + ', & 'x**3 - 4x**2 + x - 6 = 0.'///' Iteration Newton Approximation') 90010 FORMAT (/I6,4X,A) 90020 FORMAT (/' Error in sample case number 1.'/) 90030 FORMAT (///' Sample 2.',8X,I5,' terms were added to get ', & 'Exp(1.23-2.34i)'/) 90040 FORMAT (' Result= ',A) 90050 FORMAT (/' Error in sample case number 2.'/) 90060 FORMAT (//A/) END PROGRAM sample SHAR_EOF fi # end of overwriting check if test -f 'driver3.f90' then echo shar: will not over-write existing file "'driver3.f90'" else cat << SHAR_EOF > 'driver3.f90' PROGRAM test ! David M. Smith 6-14-96 ! This is a test program for FMLIB 1.1, a multiple-precision real ! arithmetic package. Most of the FM (floating-point) routines ! are tested, and the results are checked to 50 significant digits. ! Most of the IM (integer) routines are tested, with exact results ! required to pass the tests. ! This program uses FMLIB.f90. ! The four common blocks contain information that must be saved ! between calls, so they should be declared in the main program. ! The parameter statement defines various array sizes. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Local Scalars .. INTEGER :: klog, ncase, nerror ! Character strings used for input and output. CHARACTER (80) :: st1, st2 ! Declare arrays for FM variables. All are in ! unpacked format. ! .. ! .. Local Arrays .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmset, test1, test10, test11, test12, test13, test14, test15, & test2, test3, test4, test5, test6, test7, test8, test9 ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! Set precision to give at least 50 significant digits ! and initialize the FMLIB package. CALL fmset(50) ! Write output to the standard FM output (unit KW, defined ! in subroutine FMSET), and also to the file TESTFM.LOG. klog = 18 OPEN (klog,file='TESTFM.LOG') ! NERROR is the number of errors found. ! NCASE is the number of cases tested. nerror = 0 ! Test input and output conversion. CALL test1(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test add and subtract. CALL test2(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test multiply, divide and square root. CALL test3(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test stored constants. CALL test4(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test exponentials. CALL test5(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test logarithms. CALL test6(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test trigonometric functions. CALL test7(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test inverse trigonometric functions. CALL test8(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test hyperbolic functions. CALL test9(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer input and output conversion. CALL test10(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer add and subtract. CALL test11(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer multiply and divide. CALL test12(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test conversions between FM and IM format. CALL test13(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer power and GCD functions. CALL test14(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer modular functions. CALL test15(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! End of tests. IF (nerror==0) THEN WRITE (kw,90000) ncase WRITE (klog,90000) ncase ELSE ! Write some of the initialized values in common. WRITE (klog,*) ' NDIG,MBASE,JFORM1,JFORM2,KRAD = ' WRITE (klog,*) ndig, mbase, jform1, jform2, krad WRITE (klog,*) ' KW,NTRACE,LVLTRC,KFLAG,KWARN,KROUND = ' WRITE (klog,*) kw, ntrace, lvltrc, kflag, kwarn, kround WRITE (klog,*) ' NCALL,MXEXP,MXEXP2,KACCSW,MEXPUN,MEXPOV' WRITE (klog,*) ncall, mxexp, mxexp2, kaccsw, mexpun, mexpov WRITE (klog,*) ' MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX = ' WRITE (klog,*) munkno, iunkno, runkno, mxbase, ndg2mx WRITE (klog,*) ' MAXINT,INTMAX,SPMAX,DPMAX = ' WRITE (klog,*) maxint, intmax, spmax, dpmax WRITE (klog,*) ' ALOGMB,ALOGM2,ALOGMX,ALOGMT,DLOGMB,DLOGTN =' WRITE (klog,*) alogmb, alogm2, alogmx, alogmt, dlogmb, dlogtn WRITE (klog,*) ' DLOGTW,DLOGTP,DLOGPI,DPPI =' WRITE (klog,*) dlogtw, dlogtp, dlogpi, dppi WRITE (klog,*) ' DPEPS,DLOGEB =' WRITE (klog,*) dpeps, dlogeb WRITE (kw,90010) ncase, nerror WRITE (klog,90010) ncase, nerror END IF WRITE (kw,*) ' End of run.' STOP 90000 FORMAT (///1X,I5,' cases tested. No errors were found.'/) 90010 FORMAT (///1X,I5,' cases tested.',I4,' error(s) found.'/) END PROGRAM test SUBROUTINE test1(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Input and output testing. ! Logical function for comparing FM numbers. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmdiv, fmform, fmi2m, fmipwr, fmst2m, fmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 1 CALL fmst2m('123',ma) CALL fmi2m(123,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmi2m(10,mb) CALL fmipwr(mb,-48,mb) ! Use the .NOT. because FMCOMP returns FALSE for special ! cases like MD = UNKNOWN, and these should be treated ! as errors for these tests. IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMST2M',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 2 st1 = '1.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmi2m(131,mb) CALL fmi2m(97,mc) CALL fmdiv(mb,mc,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMST2M',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 3 st1 = '1.3505154639175257731958762886597938144329896907216495E-2' CALL fmst2m(st1,ma) CALL fmi2m(131,mb) CALL fmi2m(9700,mc) CALL fmdiv(mb,mc,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-52',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMST2M',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 4 st1 = '1.3505154639175257731958762886597938144329896907216495E-2' CALL fmst2m(st1,ma) CALL fmform('F40.30',ma,st2) CALL fmst2m(st2,ma) st1 = ' .013505154639175257731958762887' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('0',mb) IF (( .NOT. fmcomp(md,'LE',mb)) .OR. st1/=st2) THEN CALL errprt('FMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 5 st1 = '1.3505154639175257731958762886597938144329896907216495E+16' CALL fmst2m(st1,ma) CALL fmform('F53.33',ma,st2) CALL fmst2m(st2,ma) st1 = '13505154639175257.731958762886597938144329896907216' CALL fmst2m(st1,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 6 st1 = '1.3505154639175257731958762886597938144329896907216495E+16' CALL fmst2m(st1,ma) CALL fmform('I24',ma,st2) CALL fmst2m(st2,ma) st1 = '13505154639175258' CALL fmst2m(st1,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 7 st1 = '-1.3505154639175257731958762886597938144329896907216495E+16' CALL fmst2m(st1,ma) CALL fmform('E55.49',ma,st2) CALL fmst2m(st2,ma) st1 = '-1.350515463917525773195876288659793814432989690722D16' CALL fmst2m(st1,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 8 st1 = '-1.3505154639175257731958762886597938144329896907216495E+16' CALL fmst2m(st1,ma) CALL fmform('1PE54.46',ma,st2) CALL fmst2m(st2,ma) st1 = '-1.350515463917525773195876288659793814432989691M+16' CALL fmst2m(st1,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMFORM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing input and output routines.') END SUBROUTINE test1 SUBROUTINE test2(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test add and subtract. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmadd, fmaddi, fmi2m, fmst2m, fmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 9 CALL fmst2m('123',ma) CALL fmst2m('789',mb) CALL fmadd(ma,mb,ma) CALL fmi2m(912,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMADD ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 10 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,mb) CALL fmadd(ma,mb,ma) st2 = '1.0824742268041237113402061855670103092783505154639175' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMADD ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 11 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,mb) CALL fmsub(ma,mb,ma) st2 = '-.3814432989690721649484536082474226804123711340206185' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSUB ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 12 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) st1 = '0.3505154639175257731443298969072164948453608247422680' CALL fmst2m(st1,mb) CALL fmsub(ma,mb,ma) st2 = '5.15463917525773195876288659793815M-20' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSUB ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 13 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmaddi(ma,1) st2 = '1.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMADDI',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 14 st1 = '4.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmaddi(ma,5) st2 = '9.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMADDI',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing add and subtract routines.') END SUBROUTINE test2 SUBROUTINE test3(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test multiply, divide and square root. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmdiv, fmdivi, fmi2m, fmmpy, fmmpyi, fmsqr, & fmsqrt, fmst2m, fmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 15 CALL fmst2m('123',ma) CALL fmst2m('789',mb) CALL fmmpy(ma,mb,ma) CALL fmi2m(97047,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMMPY ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 16 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,mb) CALL fmmpy(ma,mb,ma) st2 = '0.2565628653416941226485280051014985652035285365075991' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMMPY ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 17 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,mb) CALL fmdiv(ma,mb,ma) st2 = '0.4788732394366197183098591549295774647887323943661972' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMDIV ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 18 st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,ma) CALL fmmpyi(ma,14,ma) st2 = '10.2474226804123711340206185567010309278350515463917526' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMMPYI',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 19 st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,ma) CALL fmdivi(ma,24,ma) st2 = '0.0304982817869415807560137457044673539518900343642612' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMDIVI',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 20 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmsqr(ma,ma) st2 = '0.1228610904453183122542246784993091720692953555106813' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSQR ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 21 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmsqrt(ma,ma) st2 = '0.5920434645509785316136003710368759268547372945659987' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSQRT',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing multiply, divide and square root routines.') END SUBROUTINE test3 SUBROUTINE test4(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test stored constants. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mbsave INTEGER :: j, jexp, ndgsav ! .. ! .. Local Arrays .. REAL (KIND(0.0D0)) :: mlnsv2(0:lunpck), mlnsv3(0:lunpck), mlnsv5(0:lunpck), & mlnsv7(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmcons, fmeq, fmexp, fmi2m, fmipwr, fmln, fmpi, & fmsub ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, dlogtw, & dpeps, dppi REAL (KIND(0.0D0)) :: mbase, mblogs, mbse, mbslb, mbsli, mbspi, mexpab INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, & ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ! Switch to base 10 and check the stored digits. mbsave = mbase ndgsav = ndig ncase = 22 mbase = 10 ndig = 200 CALL fmcons CALL fmi2m(1,mb) CALL fmexp(mb,mc) DO 10 j = 142, 144 ndig = j ndige = 0 CALL fmi2m(1,mb) CALL fmexp(mb,ma) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmi2m(10,mb) jexp = -j + 1 CALL fmipwr(mb,jexp,mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt(' e ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) GO TO 20 END IF 10 CONTINUE 20 ncase = 23 mbase = 10 ndig = 200 CALL fmi2m(2,mb) CALL fmln(mb,mc) CALL fmeq(mln1,mlnsv2) CALL fmeq(mln2,mlnsv3) CALL fmeq(mln3,mlnsv5) CALL fmeq(mln4,mlnsv7) WRITE (kw,90010) DO 30 j = 142, 144 ndig = j ndigli = 0 CALL fmi2m(2,mb) CALL fmln(mb,ma) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmi2m(10,mb) jexp = -j CALL fmipwr(mb,jexp,mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt(' ln(2)',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) GO TO 40 END IF 30 CONTINUE 40 ncase = 24 mbase = 10 ndig = 200 WRITE (kw,90020) CALL fmeq(mlnsv3,mc) DO 50 j = 142, 144 ndig = j ndigli = 0 CALL fmi2m(3,mb) CALL fmln(mb,ma) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmi2m(10,mb) jexp = -j + 1 CALL fmipwr(mb,jexp,mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt(' ln(3)',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) GO TO 60 END IF 50 CONTINUE 60 ncase = 25 mbase = 10 ndig = 200 WRITE (kw,90030) CALL fmeq(mlnsv5,mc) DO 70 j = 142, 144 ndig = j ndigli = 0 CALL fmi2m(5,mb) CALL fmln(mb,ma) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmi2m(10,mb) jexp = -j + 1 CALL fmipwr(mb,jexp,mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt(' ln(5)',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) GO TO 80 END IF 70 CONTINUE 80 ncase = 26 mbase = 10 ndig = 200 WRITE (kw,90040) CALL fmeq(mlnsv7,mc) DO 90 j = 142, 144 ndig = j ndigli = 0 CALL fmi2m(7,mb) CALL fmln(mb,ma) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmi2m(10,mb) jexp = -j + 1 CALL fmipwr(mb,jexp,mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt(' ln(7)',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) GO TO 100 END IF 90 CONTINUE 100 ncase = 27 mbase = 10 ndig = 200 WRITE (kw,90050) CALL fmpi(mc) DO 110 j = 142, 144 ndig = j ndigpi = 0 CALL fmpi(ma) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmi2m(10,mb) jexp = -j + 1 CALL fmipwr(mb,jexp,mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt(' pi ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) GO TO 120 END IF 110 CONTINUE ! Restore base and precision. 120 mbase = mbsave ndig = ndgsav CALL fmcons RETURN 90000 FORMAT (/' Testing stored constants.'//' Check e.'/) 90010 FORMAT (' Check ln(2).'/) 90020 FORMAT (' Check ln(3).'/) 90030 FORMAT (' Check ln(5).'/) 90040 FORMAT (' Check ln(7).'/) 90050 FORMAT (' Check pi.') END SUBROUTINE test4 SUBROUTINE test5(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test exponentials. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmexp, fmipwr, fmpwr, fmrpwr, fmst2m, fmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 28 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmexp(ma,ma) st2 = '0.7043249420381570899426746185150096342459216636010743' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMEXP ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 29 st1 = '5.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmexp(ma,ma) st2 = '210.7168868293979289717186453717687341395104929999527672' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-48',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMEXP ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 30 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmipwr(ma,13,ma) st2 = '1.205572620050170403854527299272882946980306577287581E-6' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-56',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMIPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 31 st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,ma) CALL fmipwr(ma,-1234,ma) st2 = '1.673084074011006302103793189789209370839697748745938E167' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E+120',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMIPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 32 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,mb) CALL fmpwr(ma,mb,ma) st2 = '0.4642420045002127676457665673753493595170650613692580' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMPWR ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 33 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) st1 = '-34.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,mb) CALL fmpwr(ma,mb,ma) st2 = '6.504461581246879800523526109766882955934341922848773E15' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-34',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMPWR ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 34 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmrpwr(ma,1,3,ma) st2 = '0.7050756680967220302067310420367584779561732592049823' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMRPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 35 st1 = '0.7319587628865979381443298969072164948453608247422680' CALL fmst2m(st1,ma) CALL fmrpwr(ma,-17,5,ma) st2 = '2.8889864895853344043562747681699203201333872009477318' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMRPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing exponential routines.') END SUBROUTINE test5 SUBROUTINE test6(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test logarithms. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmlg10, fmln, fmlni, fmst2m, fmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 36 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmln(ma,ma) st2 = '-1.0483504538872214324499548823726586101452117557127813' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-49',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMLN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 37 st1 = '0.3505154639175257731958762886597938144329896907216495E123' CALL fmst2m(st1,ma) CALL fmln(ma,ma) st2 = '282.1696159843803977017629940438041389247902713456262947' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-47',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMLN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 38 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmlg10(ma,ma) st2 = '-0.4552928172239897280304530226127473926500843247517120' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-49',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMLG10',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 39 CALL fmlni(210,ma) st2 = '5.3471075307174686805185894350500696418856767760333836' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-49',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMIPWR',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 40 CALL fmlni(211,ma) st2 = '5.3518581334760664957419562654542801180411581735816684' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-49',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMPWR ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing logarithm routines.') END SUBROUTINE test6 SUBROUTINE test7(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test trigonometric functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmcos, fmcssn, fmsin, fmst2m, fmsub, fmtan ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 41 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcos(ma,ma) st2 = '0.9391958366109693586000906984500978377093121163061328' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCOS ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 42 st1 = '-43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcos(ma,ma) st2 = '0.8069765551968063243992244125871029909816207609700968' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCOS ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 43 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmsin(ma,ma) st2 = '-0.3433819746180939949443652360333010581867042625893927' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSIN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 44 st1 = '43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmsin(ma,ma) st2 = '-0.5905834736620182429243173169772978155668602154136946' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSIN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 45 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmtan(ma,ma) st2 = '0.3656127521360899712035823015565426347554405301360773' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMTAN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 46 st1 = '43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmtan(ma,ma) st2 = '-0.7318471272291003544610122296764031536071117330470298' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMTAN ',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 47 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcssn(ma,ma,mc) st2 = '0.9391958366109693586000906984500978377093121163061328' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCSSN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 48 st1 = '-43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcssn(ma,ma,mc) st2 = '0.8069765551968063243992244125871029909816207609700968' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCSSN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 49 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcssn(ma,mc,ma) st2 = '-0.3433819746180939949443652360333010581867042625893927' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCSSN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 50 st1 = '43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcssn(ma,mc,ma) st2 = '-0.5905834736620182429243173169772978155668602154136946' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCSSN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing trigonometric routines.') END SUBROUTINE test7 SUBROUTINE test8(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test inverse trigonometric functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmacos, fmasin, fmatan, fmst2m, fmsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 51 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmacos(ma,ma) st2 = '1.2126748979730954046873545995574544481988102502510807' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMACOS',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 52 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmacos(ma,ma) st2 = '1.9289177556166978337752887837220484359983591491240252' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMACOS',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 53 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmasin(ma,ma) st2 = '0.3581214288218012145439670920822969938997744494364723' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMASIN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 54 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmasin(ma,ma) st2 = '-0.3581214288218012145439670920822969938997744494364723' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMASIN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 55 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmatan(ma,ma) st2 = '0.3371339561772373443347761845672381725353758541616570' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMATAN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 56 st1 = '43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmatan(ma,ma) st2 = '1.5477326406586162039457549832092678908202994134569781' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMATAN',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing inverse trigonometric routines.') END SUBROUTINE test8 SUBROUTINE test9(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test hyperbolic functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL errprt, fmabs, fmchsh, fmcosh, fmsinh, fmst2m, fmsub, fmtanh ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 57 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcosh(ma,ma) st2 = '1.0620620786534654254819884264931372964608741056397718' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-49',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCOSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 58 st1 = '-43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmcosh(ma,ma) st2 = '3.356291383454381441662669560464886179346554730604556E+18' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-31',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCOSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 59 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmsinh(ma,ma) st2 = '-0.3577371366153083355393138079781276622149524420386975' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSINH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 60 st1 = '43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmsinh(ma,ma) st2 = '3.356291383454381441662669560464886179197580776059111E+18' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-31',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMSINH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 61 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmtanh(ma,ma) st2 = '0.3368326049912874057089491946232983472275659538703038' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMTANH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 62 st1 = '43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmtanh(ma,ma) st2 = '0.9999999999999999999999999999999999999556135217341837' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMTANH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 63 st1 = '0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmchsh(ma,ma,mc) st2 = '1.0620620786534654254819884264931372964608741056397718' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-49',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCHSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 64 st1 = '-43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmchsh(ma,ma,mc) st2 = '3.356291383454381441662669560464886179346554730604556E+18' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-31',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCHSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 65 st1 = '-0.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmchsh(ma,mc,ma) st2 = '-0.3577371366153083355393138079781276622149524420386975' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-50',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCHSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 66 st1 = '43.3505154639175257731958762886597938144329896907216495' CALL fmst2m(st1,ma) CALL fmchsh(ma,mc,ma) st2 = '3.356291383454381441662669560464886179197580776059111E+18' CALL fmst2m(st2,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-31',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('FMCHSH',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing hyperbolic routines.') END SUBROUTINE test9 SUBROUTINE test10(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Input and output testing for IM routines. ! Logical function for comparing IM numbers. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL errpr2, imform, imi2m, impwr, imst2m ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 67 CALL imst2m('123',ma) CALL imi2m(123,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMST2M',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 68 st1 = '-350515' CALL imst2m(st1,ma) CALL imi2m(-350515,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMST2M',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 69 st1 = '19895113660064588580108197261066338165074766609' CALL imst2m(st1,ma) CALL imi2m(23,mb) CALL imi2m(34,mc) CALL impwr(mb,mc,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMST2M',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 70 st1 = '-20800708073664542533904165663516279809808659679033703' CALL imst2m(st1,ma) CALL imi2m(-567,mb) CALL imi2m(19,mc) CALL impwr(mb,mc,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMST2M',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 71 st1 = '19895113660064588580108197261066338165074766609' CALL imst2m(st1,ma) CALL imform('I53',ma,st2) CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMFORM',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 72 st1 = '-20800708073664542533904165663516279809808659679033703' CALL imst2m(st1,ma) CALL imform('I73',ma,st2) CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMFORM',ma,'MA',mc,'MC',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing integer input and output routines.') END SUBROUTINE test10 SUBROUTINE test11(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test add and subtract for IM routines. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL errpr2, imadd, imi2m, imst2m, imsub ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 73 CALL imst2m('123',ma) CALL imst2m('789',mb) CALL imadd(ma,mb,ma) CALL imi2m(912,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMADD ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 74 st1 = '3505154639175257731958762886597938144329896907216495' CALL imst2m(st1,ma) st1 = '7319587628865979381443298969072164948453608247422680' CALL imst2m(st1,mb) CALL imadd(ma,mb,ma) st2 = '10824742268041237113402061855670103092783505154639175' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMADD ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 75 st1 = '3505154639175257731958762886597938144329896907216495' CALL imst2m(st1,ma) st1 = '7319587628865979381443298969072164948453608247422680' CALL imst2m(st1,mb) CALL imsub(ma,mb,ma) st2 = '-3814432989690721649484536082474226804123711340206185' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMSUB ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 76 st1 = '3505154639175257731958762886597938144329896907216495' CALL imst2m(st1,ma) st1 = '3505154639175257731443298969072164948453608247422680' CALL imst2m(st1,mb) CALL imsub(ma,mb,ma) st2 = '515463917525773195876288659793815' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMSUB ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing integer add and subtract routines.') END SUBROUTINE test11 SUBROUTINE test12(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer multiply and divide. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: irem ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL errpr2, imdiv, imdivi, imdivr, imdvir, imi2m, immod, immpy, & immpyi, imsqr, imst2m ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 77 CALL imst2m('123',ma) CALL imst2m('789',mb) CALL immpy(ma,mb,ma) CALL imi2m(97047,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMMPY ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 78 st1 = '10430738374625018354698' CALL imst2m(st1,ma) st1 = '2879494424799214514791045985' CALL imst2m(st1,mb) CALL immpy(ma,mb,ma) st2 = '30035252996271960952238822892375588336807158787530' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMMPY ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 79 CALL imst2m('12347',ma) CALL imst2m('47',mb) CALL imdiv(ma,mb,ma) CALL imst2m('262',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDIV ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 80 st1 = '2701314697583086005158008013691015597308949443159762' CALL imst2m(st1,ma) st1 = '-978132616472842669976589722394' CALL imst2m(st1,mb) CALL imdiv(ma,mb,ma) CALL imst2m('-2761705981469115610382',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDIV ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 81 CALL imst2m('12368',ma) CALL imst2m('67',mb) CALL immod(ma,mb,mb) CALL imst2m('40',mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMMOD ',mb,'MB',mc,'MC',ncase,nerror,klog) END IF ncase = 82 st1 = '2701314697583086005158008013691015597308949443159762' CALL imst2m(st1,ma) st1 = '-978132616472842669976589722394' CALL imst2m(st1,mb) CALL immod(ma,mb,mb) CALL imst2m('450750319653685523300198865254',mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMMOD ',mb,'MB',mc,'MC',ncase,nerror,klog) END IF ncase = 83 CALL imst2m('1234',ma) CALL imst2m('17',mb) CALL imdivr(ma,mb,ma,mb) CALL imst2m('72',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDIVR',ma,'MA',mc,'MC',ncase,nerror,klog) END IF CALL imst2m('10',mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMDIVR',mb,'MB',mc,'MC',ncase,nerror,klog) END IF ncase = 84 st1 = '34274652243817531418235301715935108945364446765801943' CALL imst2m(st1,ma) st1 = '-54708769795848731641842224621693' CALL imst2m(st1,mb) CALL imdivr(ma,mb,ma,mb) CALL imst2m('-626492834178447772323',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDIVR',ma,'MA',mc,'MC',ncase,nerror,klog) END IF CALL imst2m('31059777254296217822749494999104',mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMDIVR',mb,'MB',mc,'MC',ncase,nerror,klog) END IF ncase = 85 CALL imst2m('4866',ma) CALL immpyi(ma,14,ma) CALL imst2m('68124',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMMPYI',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 86 CALL imst2m('270131469758308600515800801369101559730894',ma) CALL immpyi(ma,-2895,ma) CALL imst2m('-782030604950303398493243319963549015420938130',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMMPYI ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 87 CALL imst2m('-37179',ma) CALL imdivi(ma,129,ma) CALL imst2m('-288',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDIVI',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 88 st1 = '8267538919383255454483790743961990401918726073065738' CALL imst2m(st1,ma) CALL imdivi(ma,1729,ma) st2 = '4781688212483085861471249707323302719444028960708' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDIVI',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 89 CALL imst2m('-71792',ma) CALL imdvir(ma,65,ma,irem) CALL imst2m('-1104',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDVIR',ma,'MA',mc,'MC',ncase,nerror,klog) END IF CALL imi2m(irem,mb) CALL imi2m(-32,mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMDVIR',mb,'MB',mc,'MC',ncase,nerror,klog) END IF ncase = 90 st1 = '97813261647284266997658972239417958580120170263408655' CALL imst2m(st1,ma) CALL imdvir(ma,826,ma,irem) st2 = '118417992309060855929369215786220288837917881674828' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMDVIR',ma,'MA',mc,'MC',ncase,nerror,klog) END IF CALL imi2m(irem,mb) CALL imi2m(727,mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMDVIR',mb,'MB',mc,'MC',ncase,nerror,klog) END IF ncase = 91 CALL imst2m('538',ma) CALL imsqr(ma,ma) CALL imst2m('289444',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMSQR ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 92 CALL imst2m('-47818191879814587168242632',ma) CALL imsqr(ma,ma) st2 = '2286579474654765721668058416662636606051551222287424' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMSQR ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing integer multiply, divide and square routines.') END SUBROUTINE test12 SUBROUTINE test13(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test conversions between FM and IM format. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp, imcomp ! .. ! .. External Subroutines .. EXTERNAL errpr2, errprt, fmabs, fmi2m, fmst2m, fmsub, imfm2i, imi2fm, & imi2m, imst2m ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 93 CALL imst2m('123',ma) CALL imi2fm(ma,mb) CALL fmi2m(123,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('IMI2FM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 94 CALL imst2m('979282999076598337488362000995916',ma) CALL imi2fm(ma,mb) CALL fmst2m('979282999076598337488362000995916',mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('0',mb) IF ( .NOT. fmcomp(md,'LE',mb)) THEN CALL errprt('IMI2FM',ma,'MA',mc,'MC',md,'MD',ncase,nerror,klog) END IF ncase = 95 CALL fmst2m('123.4',ma) CALL imfm2i(ma,mb) CALL imi2m(123,mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMFM2I',mb,'MB',mc,'MC',ncase,nerror,klog) END IF ncase = 96 CALL fmst2m('979282999076598337488362000995916',ma) CALL imfm2i(ma,mb) CALL imst2m('979282999076598337488362000995916',mc) IF ( .NOT. imcomp(mb,'EQ',mc)) THEN CALL errpr2('IMFM2I',mb,'MB',mc,'MC',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing conversions between FM and IM format.') END SUBROUTINE test13 SUBROUTINE test14(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer power and GCD functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL errpr2, imgcd, imi2m, impwr, imst2m ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 97 CALL imst2m('123',ma) CALL imst2m('789',mb) CALL imgcd(ma,mb,ma) CALL imi2m(3,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMGCD ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 98 st1 = '431134020618556701030927835051546391752577319587628885' CALL imst2m(st1,ma) st1 = '900309278350515463917525773195876288659793814432989640' CALL imst2m(st1,mb) CALL imgcd(ma,mb,ma) CALL imst2m('615',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMGCD ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 99 st1 = '5877631675869176172956662762822298812326084745145447940' CALL imst2m(st1,ma) st1 = '10379997509886032090765062511740075746391432253007667' CALL imst2m(st1,mb) CALL imgcd(ma,mb,ma) CALL imst2m('1',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMGCD ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 100 CALL imst2m('47',ma) CALL imst2m('34',mb) CALL impwr(ma,mb,ma) st2 = '710112520079088427392020925014421733344154169313556279969' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMPWR ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 101 CALL imst2m('2',ma) CALL imst2m('187',mb) CALL impwr(ma,mb,ma) st2 = '196159429230833773869868419475239575503198607639501078528' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMPWR ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 102 CALL imst2m('-3',ma) CALL imst2m('101',mb) CALL impwr(ma,mb,ma) st2 = '-1546132562196033993109383389296863818106322566003' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMPWR ',ma,'MA',mc,'MC',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing integer GCD and power routines.') END SUBROUTINE test14 SUBROUTINE test15(ma,mb,mc,md,st1,st2,ncase,nerror,klog) ! Test integer modular functions. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (80) :: st1, st2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL errpr2, imi2m, immpym, impmod, imst2m ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. WRITE (kw,90000) ncase = 103 CALL imst2m('123',ma) CALL imst2m('789',mb) CALL imst2m('997',mc) CALL immpym(ma,mb,mc,ma) CALL imi2m(338,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMMPYM',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 104 st1 = '431134020618556701030927835051546391752577319587628885' CALL imst2m(st1,ma) st1 = '36346366019557973241042306587666640486264616086971724' CALL imst2m(st1,mb) st1 = '900309278350515463917525773195876288659793814432989640' CALL imst2m(st1,mc) CALL immpym(ma,mb,mc,ma) st2 = '458279704440780378752997531208983184411293504187816380' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMMPYM',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 105 st1 = '914726194238000125985765939883182' CALL imst2m(st1,ma) st1 = '-75505764717193044779376979508186553225192' CALL imst2m(st1,mb) st1 = '18678872625055834600521936' CALL imst2m(st1,mc) CALL immpym(ma,mb,mc,ma) st2 = '-7769745969769966093344960' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMMPYM',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 106 CALL imst2m('123',ma) CALL imst2m('789',mb) CALL imst2m('997',mc) CALL impmod(ma,mb,mc,ma) CALL imi2m(240,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMPMOD',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 107 st1 = '431134020618556701030927835051546391752577319587628885' CALL imst2m(st1,ma) st1 = '36346366019557973241042306587666640486264616086971724' CALL imst2m(st1,mb) st1 = '900309278350515463917525773195876288659793814432989640' CALL imst2m(st1,mc) CALL impmod(ma,mb,mc,ma) st2 = '755107893576299697276281907390144058060594744720442385' CALL imst2m(st2,mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMPMOD',ma,'MA',mc,'MC',ncase,nerror,klog) END IF ncase = 108 CALL imst2m('314159',ma) CALL imst2m('1411695892374393248272691827763664225585897550',mb) CALL imst2m('1411695892374393248272691827763664225585897551',mc) CALL impmod(ma,mb,mc,ma) CALL imst2m('1',mc) IF ( .NOT. imcomp(ma,'EQ',mc)) THEN CALL errpr2('IMPMOD',ma,'MA',mc,'MC',ncase,nerror,klog) END IF RETURN 90000 FORMAT (/' Testing integer modular routines.') END SUBROUTINE test15 SUBROUTINE errprt(nrout,m1,name1,m2,name2,m3,name3,ncase,nerror,klog) ! Print error messages. ! M1 is the value to be tested, as computed by the routine named NROUT. ! M2 is the reference value, usually converted using FMST2M. ! M3 is ABS(M1-M2), and ERRPRT is called if this is too big. ! NAME1,NAME2,NAME3 are strings identifying which variables in main ! correspond to M1,M2,M3. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (2) :: name1, name2, name3 CHARACTER (6) :: nrout ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: m1(0:lunpck), m2(0:lunpck), m3(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwsave ! .. ! .. External Subroutines .. EXTERNAL fmprnt ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. nerror = nerror + 1 WRITE (kw,90000) ncase, nrout WRITE (klog,90000) ncase, nrout ! Temporarily change KW to KLOG so FMPRNT ! will write to the log file. kwsave = kw kw = klog WRITE (klog,90010) name1 CALL fmprnt(m1) WRITE (klog,90010) name2 CALL fmprnt(m2) WRITE (klog,90010) name3 CALL fmprnt(m3) kw = kwsave RETURN 90000 FORMAT (//' Error in case',I3,'. The routine',' being tested was ',A6) 90010 FORMAT (1X,A2,' =') END SUBROUTINE errprt SUBROUTINE errpr2(nrout,m1,name1,m2,name2,ncase,nerror,klog) ! Print error messages for testing of integer (IM) routines. ! M1 is the value to be tested, as computed by the routine named NROUT. ! M2 is the reference value, usually converted using IMST2M. ! NAME1,NAME2 are strings identifying which variables in main ! correspond to M1,M2. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: klog, ncase, nerror CHARACTER (2) :: name1, name2 CHARACTER (6) :: nrout ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: m1(0:lunpck), m2(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwsave ! .. ! .. External Subroutines .. EXTERNAL imprnt ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. nerror = nerror + 1 WRITE (kw,90000) ncase, nrout WRITE (klog,90000) ncase, nrout ! Temporarily change KW to KLOG so IMPRNT ! will write to the log file. kwsave = kw kw = klog WRITE (klog,90010) name1 CALL imprnt(m1) WRITE (klog,90010) name2 CALL imprnt(m2) kw = kwsave RETURN 90000 FORMAT (//' Error in case',I3,'. The routine',' being tested was ',A6) 90010 FORMAT (1X,A2,' =') END SUBROUTINE errpr2 SHAR_EOF fi # end of overwriting check if test -f 'driver4.f90' then echo shar: will not over-write existing file "'driver4.f90'" else cat << SHAR_EOF > 'driver4.f90' PROGRAM sample ! David M. Smith 6-17-96 ! This is a test program for FMLIB 1.1, a multiple-precision real ! arithmetic package. A few example FM calculations are carried ! out using 60 significant digit precision. ! The output is saved in file FMSAMPLE.LOG. A comparison file, ! FMSAMPLE.CHK, is provided showing the expected output from 32-bit ! (IEEE arithmetic) machines. When run on other computers, all the ! numerical results should still be the same, but the number of terms ! needed for some of the results might be slightly different. The ! program checks all the results and the last line of the log file ! should be "All results were ok." !----------------------------------------------------------------------- ! These four common blocks contain information that must be saved ! between calls, so they should be declared in the main program. ! The parameter statement defines various array sizes. !----------------------------------------------------------------------- ! .. Intrinsic Functions .. INTRINSIC mod ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Local Scalars .. INTEGER :: iter, j, k, klog, nerror ! Character string used for input and output. CHARACTER (80) :: st1 ! Declare arrays for FM variables. All are in ! unpacked format. ! .. ! .. Local Arrays .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp, imcomp ! .. ! .. External Subroutines .. EXTERNAL fmabs, fmadd, fmaddi, fmdiv, fmdivi, fmeq, fmform, fmi2m, & fmmpy, fmmpyi, fmset, fmsqr, fmst2m, fmsub, imadd, imdivi, imform, & imi2m, immpyi, impmod, impwr, imst2m, imsub ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! Set precision to give at least 60 significant digits ! and initialize the FMLIB package. ! Note that any program using the FM package MUST call ! FMSET before using the package. CALL fmset(60) nerror = 0 ! Write output to the standard FM output (unit KW, defined ! in subroutine FMSET), and also to the file FMSAMPLE.LOG. klog = 18 OPEN (klog,file='FMSAMPLE.LOG') ! 1. Find a root of the equation ! f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0. ! Use Newton's method with initial guess x = 3.12. ! This version is not tuned for speed. See the FMSQRT ! routine for possible ways to increase speed. ! Horner's rule is used to evaluate the function: ! f(x) = ((((x-3)*x+1)*x-4)*x+1)*x-6. ! MA is the previous iterate. ! MB is the current iterate. CALL fmst2m('3.12',ma) ! Print the first iteration. WRITE (kw,90000) WRITE (klog,90000) CALL fmform('F65.60',ma,st1) WRITE (kw,90010) 0, st1(1:65) WRITE (klog,90010) 0, st1(1:65) DO 10 iter = 1, 10 ! MC is f(MA). CALL fmeq(ma,mc) CALL fmaddi(mc,-3) CALL fmmpy(mc,ma,mc) CALL fmaddi(mc,1) CALL fmmpy(mc,ma,mc) CALL fmaddi(mc,-4) CALL fmmpy(mc,ma,mc) CALL fmaddi(mc,1) CALL fmmpy(mc,ma,mc) CALL fmaddi(mc,-6) ! MD is f'(MA). CALL fmmpyi(ma,5,md) CALL fmaddi(md,-12) CALL fmmpy(md,ma,md) CALL fmaddi(md,3) CALL fmmpy(md,ma,md) CALL fmaddi(md,-8) CALL fmmpy(md,ma,md) CALL fmaddi(md,1) CALL fmdiv(mc,md,mb) CALL fmsub(ma,mb,mb) ! Print each iteration. CALL fmform('F65.60',mb,st1) WRITE (kw,90010) iter, st1(1:65) WRITE (klog,90010) iter, st1(1:65) ! Stop iterating if MA and MB agree to over ! 60 places. CALL fmsub(ma,mb,md) CALL fmabs(md,md) CALL fmst2m('1.0E-61',mc) IF (fmcomp(md,'LT',mc)) GO TO 20 ! Set MA = MB for the next iteration. CALL fmeq(mb,ma) 10 CONTINUE ! Check the answer. 20 st1 = '3.120656215326726500470956013523797484654623935599066014' // & '9888284358' CALL fmst2m(st1,mc) CALL fmsub(mc,mb,md) CALL fmabs(md,md) CALL fmst2m('1.0E-61',mc) IF (fmcomp(md,'GT',mc)) THEN nerror = nerror + 1 WRITE (kw,90020) WRITE (klog,90020) END IF ! 2. Compute the Riemann Zeta function for s=3. ! Use Gosper's formula Zeta(3) = ! (5/4)*Sum[ (-1)**k * (k!)**2 / ((k+1)**2 * (2k+1)!) ] ! while k = 0, 1, .... ! MA is the current partial sum. ! MB is the current term. ! MC is k! ! MD is (2k+1)! CALL fmi2m(1,ma) CALL fmeq(ma,mc) CALL fmeq(ma,md) DO 30 k = 1, 200 CALL fmmpyi(mc,k,mc) j = 2*k*(2*k+1) CALL fmmpyi(md,j,md) CALL fmsqr(mc,mb) j = (k+1)*(k+1) CALL fmdivi(mb,j,mb) CALL fmdiv(mb,md,mb) IF (mod(k,2)==0) THEN CALL fmadd(ma,mb,ma) ELSE CALL fmsub(ma,mb,ma) END IF ! Test for convergence. KFLAG will be 1 if the result ! of the last add or subtract is the same as one of the ! input arguments. IF (kflag==1) THEN WRITE (kw,90030) k WRITE (klog,90030) k GO TO 40 END IF 30 CONTINUE ! Print the result. 40 CALL fmmpyi(ma,5,ma) CALL fmdivi(ma,4,ma) CALL fmform('F65.60',ma,st1) WRITE (kw,90040) st1(1:65) WRITE (klog,90040) st1(1:65) ! Check the answer. st1 = '1.20205690315959428539973816151144999076498629234049888' // & '1792271555' CALL fmst2m(st1,mc) CALL fmsub(ma,mc,md) CALL fmabs(md,md) CALL fmst2m('1.0E-61',mc) IF (fmcomp(md,'GT',mc)) THEN nerror = nerror + 1 WRITE (kw,90050) WRITE (klog,90050) END IF ! 3. Integer multiple precision calculations. ! Fermat's theorem says x**(p-1) mod p = 1 ! when p is prime and x is not a multiple of p. ! If x**(p-1) mod p gives 1 for some p with ! several different x's, then it is very likely ! that p is prime (but it is not certain until ! further tests are done). ! Find a 70-digit number p that is "probably" prime. ! MA is the value p being tested. CALL imi2m(10,ma) CALL imi2m(69,mb) CALL impwr(ma,mb,ma) ! To speed up the search, test only values that are ! not multiples of 2, 3, 5, 7, 11, 13. k = 2*3*5*7*11*13 CALL imdivi(ma,k,ma) CALL immpyi(ma,k,ma) CALL imi2m(k,mb) CALL imadd(ma,mb,ma) CALL imi2m(1,md) CALL imadd(ma,md,ma) CALL imi2m(3,mc) DO 50 j = 1, 100 ! Compute 3**(p-1) mod p CALL imsub(ma,md,mb) CALL impmod(mc,mb,ma,mc) IF (imcomp(mc,'EQ',md)) THEN ! Check that 7**(p-1) mod p is also 1. CALL imi2m(7,mc) CALL impmod(mc,mb,ma,mc) IF (imcomp(mc,'EQ',md)) THEN WRITE (kw,90060) j WRITE (klog,90060) j GO TO 60 END IF END IF CALL imi2m(3,mc) CALL imi2m(k,mb) CALL imadd(ma,mb,ma) 50 CONTINUE ! Print the result. 60 CALL imform('I72',ma,st1) WRITE (kw,90070) st1(1:72) WRITE (klog,90070) st1(1:72) ! Check the answer. st1 = '1000000000000000000000000000000000000000000000000000' // & '000000000000659661' CALL imst2m(st1,mc) IF (imcomp(ma,'NE',mc)) THEN nerror = nerror + 1 WRITE (kw,90080) WRITE (klog,90080) END IF IF (nerror==0) THEN WRITE (kw,90090) ' All results were ok.' WRITE (klog,90090) ' All results were ok.' END IF STOP 90000 FORMAT (//' Sample 1. Find a root of f(x) = x**5 - 3x**4 + ', & 'x**3 - 4x**2 + x - 6 = 0.'///' Iteration Newton Approximation') 90010 FORMAT (/I10,4X,A) 90020 FORMAT (/' Error in sample case number 1.'/) 90030 FORMAT (///' Sample 2.',8X,I5,' terms were added'/) 90040 FORMAT (' Zeta(3) = ',A) 90050 FORMAT (/' Error in sample case number 2.'/) 90060 FORMAT (///' Sample 3.',8X,I5,' values were tested'/) 90070 FORMAT (' p = ',A) 90080 FORMAT (/' Error in sample case number 3.'/) 90090 FORMAT (//A/) END PROGRAM sample SHAR_EOF fi # end of overwriting check if test -f 'driver5.f90' then echo shar: will not over-write existing file "'driver5.f90'" else cat << SHAR_EOF > 'driver5.f90' PROGRAM testm ! David M. Smith 3-23-97 ! Test program using the FM Fortran-90 module for doing ! arithmetic using the FM, IM, and ZM derived types. ! Any errors will be noted in file Test90.LOG. ! After a successful run of this program, there should be ! one line in Test90.LOG: ! 603 cases tested. No errors were found. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Local Structures .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm2, mzm3, mzm4 ! .. ! .. Local Scalars .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. External Subroutines .. EXTERNAL test1, test10, test11, test12, test13, test14, test15, test16, & test17, test18, test19, test2, test3, test4, test5, test6, test7, & test8, test9, zmset ! .. CALL zmset(50) kdebug = 1 kwarn = 2 ! Write output to the standard FM output (unit KW, defined ! in subroutine FMSET), and also to the file Test90.LOG. klog = 11 OPEN (klog,file='Test90.LOG') ! NERROR is the number of errors found. ! NCASE is the number of cases tested. nerror = 0 ncase = 0 i1 = 131 r1 = 241.21 d1 = 391.61D0 z1 = (411.11D0,421.21D0) c1 = (431.11D0,441.21D0) CALL fm_st2m('581.21',mfm1) CALL fm_st2m('-572.42',mfm2) CALL im_st2m('661',mim1) CALL im_st2m('-602',mim2) CALL zm_st2m('731.51 + 711.41 i',mzm1) CALL zm_st2m('-762.12 - 792.42 i',mzm2) ! Test the '=' assignment operator. CALL test1(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3,mzm4, & nerror,ncase,klog) ! Test the '.EQ.' logical operator. CALL test2(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,mzm1,mzm2,nerror,ncase, & klog) ! Test the '.NE.' logical operator. CALL test3(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,mzm1,mzm2,nerror,ncase, & klog) ! Test the '.GT.' logical operator. CALL test4(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,nerror,ncase,klog) ! Test the '.GE.' logical operator. CALL test5(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,nerror,ncase,klog) ! Test the '.LT.' logical operator. CALL test6(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,nerror,ncase,klog) ! Test the '.LE.' logical operator. CALL test7(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,nerror,ncase,klog) ! Test the '+' arithmetic operator. CALL test8(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '-' arithmetic operator. CALL test9(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '*' arithmetic operator. CALL test10(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '/' arithmetic operator. CALL test11(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '**' arithmetic operator. CALL test12(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test functions ABS, ..., CEILING. CALL test13(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3, & mzm4,nerror,ncase,klog) ! Test functions CMPLX, ..., EXPONENT. CALL test14(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm3,mzm4,nerror,ncase,klog) ! Test functions FLOOR, ..., MIN. CALL test15(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm3,mzm4,nerror,ncase,klog) ! Test functions MINEXPONENT, ..., RRSPACING. CALL test16(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3,mzm4, & nerror,ncase,klog) ! Test functions SCALE, ..., TINY. CALL test17(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4,mzm1, & mzm3,mzm4,nerror,ncase,klog) ! Test functions TO_FM, ..., TO_ZM. CALL test18(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3,mzm4, & nerror,ncase,klog) ! Test derived-type interface routines. CALL test19(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3,mzm4, & nerror,ncase,klog) IF (nerror==0) THEN WRITE (kw,*) ncase, ' cases tested. No errors were found. ' WRITE (klog,*) ncase, ' cases tested. No errors were found. ' ELSE WRITE (kw,*) ncase, ' cases tested. ', nerror, ' error(s) found. ' WRITE (klog,*) ncase, ' cases tested. ', nerror, ' error(s) found. ' END IF END PROGRAM testm SUBROUTINE test1(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3, & mzm4,nerror,ncase,klog) ! Test the '=' assignment operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm3, mfm4 TYPE (im) :: mim1, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Structures .. TYPE (fm) :: msmall ! .. ! .. Local Scalars .. COMPLEX (kind(0.0D0)) :: c3 COMPLEX :: z3 REAL (KIND(0.0D0)) :: d3, dsmall REAL :: r3, rsmall INTEGER :: i3 ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. rsmall = epsilon(1.0)*100.0 dsmall = epsilon(1.0D0)*100.0 msmall = epsilon(to_fm(1))*10000.0 ncase = 1 i3 = mfm1 IF (i3/=581) CALL prterr(kw,klog,ncase,nerror) ncase = 2 i3 = mim1 IF (i3/=661) CALL prterr(kw,klog,ncase,nerror) ncase = 3 i3 = mzm1 IF (i3/=731) CALL prterr(kw,klog,ncase,nerror) ncase = 4 r3 = mfm1 IF (abs((r3-581.21)/581.21)>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 5 r3 = mim1 IF (abs((r3-661.0)/661.0)>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 6 r3 = mzm1 IF (abs((r3-731.51)/731.51)>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 7 d3 = mfm1 IF (abs((d3-581.21D0)/581.21D0)>dsmall) CALL prterr(kw,klog,ncase,nerror & ) ncase = 8 d3 = mim1 IF (abs((d3-661.0D0)/661.0D0)>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 9 d3 = mzm1 IF (abs((d3-731.51D0)/731.51D0)>dsmall) CALL prterr(kw,klog,ncase,nerror & ) ncase = 10 z3 = mfm1 IF (abs((z3-581.21)/581.21)>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 11 z3 = mim1 IF (abs((z3-661.0)/661.0)>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 12 z3 = mzm1 IF (abs((z3-(731.51,711.41))/(731.51,711.41))>rsmall) CALL prterr(kw, & klog,ncase,nerror) ncase = 13 c3 = mfm1 IF (abs((c3-581.21D0)/581.21D0)>dsmall) CALL prterr(kw,klog,ncase,nerror & ) ncase = 14 c3 = mim1 IF (abs((c3-661.0D0)/661.0D0)>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 15 c3 = mzm1 IF (abs((c3-(731.51D0,711.41D0))/(731.51D0,711.41D0))>dsmall) CALL & prterr(kw,klog,ncase,nerror) ncase = 16 mfm3 = i1 CALL fm_i2m(131,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_abs(mfm4,mfm4) CALL fm_st2m('0',mfm3) IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 17 mfm3 = r1 CALL fm_st2m('241.21',mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 18 mfm3 = d1 CALL fm_st2m('391.61',mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = dsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 19 mfm3 = z1 CALL fm_st2m('411.11',mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 20 mfm3 = c1 CALL fm_st2m('431.11',mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = dsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 21 mfm3 = mfm1 CALL fm_st2m('581.21',mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) CALL fm_eq(msmall,mfm3) IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 22 mfm3 = mim1 CALL fm_st2m('661',mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_abs(mfm4,mfm4) CALL fm_st2m('0',mfm3) IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 23 mfm3 = mzm1 CALL fm_st2m('731.51',mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = msmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 24 mim3 = i1 CALL im_i2m(131,mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 25 mim3 = r1 CALL im_st2m('241',mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 26 mim3 = d1 CALL im_st2m('391',mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 27 mim3 = z1 CALL im_st2m('411',mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 28 mim3 = c1 CALL im_st2m('431',mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 29 mim3 = mfm1 CALL im_st2m('581',mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 30 mim3 = mim1 CALL im_st2m('661',mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 31 mim3 = mzm1 CALL im_st2m('731',mim4) CALL im_sub(mim3,mim4,mim4) CALL im_st2m('0',mim3) IF (im_comp(mim4,'GT',mim3)) CALL prterr(kw,klog,ncase,nerror) ncase = 32 mzm3 = i1 CALL zm_i2m(131,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_abs(mzm4,mfm4) CALL fm_st2m('0',mfm3) IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 33 mzm3 = r1 CALL zm_st2m('241.21',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 34 mzm3 = d1 CALL zm_st2m('391.61',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = dsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 35 mzm3 = z1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 36 mzm3 = c1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = dsmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 37 mzm3 = mfm1 CALL zm_st2m('581.21',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = msmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 38 mzm3 = mim1 CALL zm_st2m('661',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_abs(mzm4,mfm4) CALL fm_st2m('0',mfm3) IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 39 mzm3 = mzm1 CALL zm_st2m('731.51 + 711.41 i',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = msmall IF (fm_comp(mfm4,'GT',mfm3)) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test1 SUBROUTINE test2(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,mzm1,mzm2,nerror, & ncase,klog) ! Test the '.EQ.' logical operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2 TYPE (im) :: mim1, mim2 TYPE (zm) :: mzm1, mzm2 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 40 IF (i1==mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 41 IF (i1==mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 42 IF (i1==mzm1) CALL prterr(kw,klog,ncase,nerror) ncase = 43 IF (r1==mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 44 IF (r1==mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 45 IF (r1==mzm1) CALL prterr(kw,klog,ncase,nerror) ncase = 46 IF (d1==mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 47 IF (d1==mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 48 IF (d1==mzm1) CALL prterr(kw,klog,ncase,nerror) ncase = 49 IF (z1==mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 50 IF (z1==mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 51 IF (z1==mzm1) CALL prterr(kw,klog,ncase,nerror) ncase = 52 IF (c1==mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 53 IF (c1==mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 54 IF (c1==mzm1) CALL prterr(kw,klog,ncase,nerror) ncase = 55 IF (mfm1==i1) CALL prterr(kw,klog,ncase,nerror) ncase = 56 IF (mfm1==r1) CALL prterr(kw,klog,ncase,nerror) ncase = 57 IF (mfm1==d1) CALL prterr(kw,klog,ncase,nerror) ncase = 58 IF (mfm1==z1) CALL prterr(kw,klog,ncase,nerror) ncase = 59 IF (mfm1==c1) CALL prterr(kw,klog,ncase,nerror) ncase = 60 IF (mfm1==mfm2) CALL prterr(kw,klog,ncase,nerror) ncase = 61 IF (mfm1==mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 62 IF (mfm1==mzm1) CALL prterr(kw,klog,ncase,nerror) ncase = 63 IF (mim1==i1) CALL prterr(kw,klog,ncase,nerror) ncase = 64 IF (mim1==r1) CALL prterr(kw,klog,ncase,nerror) ncase = 65 IF (mim1==d1) CALL prterr(kw,klog,ncase,nerror) ncase = 66 IF (mim1==z1) CALL prterr(kw,klog,ncase,nerror) ncase = 67 IF (mim1==c1) CALL prterr(kw,klog,ncase,nerror) ncase = 68 IF (mim1==mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 69 IF (mim1==mim2) CALL prterr(kw,klog,ncase,nerror) ncase = 70 IF (mim1==mzm1) CALL prterr(kw,klog,ncase,nerror) ncase = 71 IF (mzm1==i1) CALL prterr(kw,klog,ncase,nerror) ncase = 72 IF (mzm1==r1) CALL prterr(kw,klog,ncase,nerror) ncase = 73 IF (mzm1==d1) CALL prterr(kw,klog,ncase,nerror) ncase = 74 IF (mzm1==z1) CALL prterr(kw,klog,ncase,nerror) ncase = 75 IF (mzm1==c1) CALL prterr(kw,klog,ncase,nerror) ncase = 76 IF (mzm1==mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 77 IF (mzm1==mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 78 IF (mzm1==mzm2) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test2 SUBROUTINE test3(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,mzm1,mzm2,nerror, & ncase,klog) ! Test the '.NE.' logical operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2 TYPE (im) :: mim1, mim2 TYPE (zm) :: mzm1, mzm2 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 79 IF ( .NOT. (i1/=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 80 IF ( .NOT. (i1/=mim1)) CALL prterr(kw,klog,ncase,nerror) ncase = 81 IF ( .NOT. (i1/=mzm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 82 IF ( .NOT. (r1/=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 83 IF ( .NOT. (r1/=mim1)) CALL prterr(kw,klog,ncase,nerror) ncase = 84 IF ( .NOT. (r1/=mzm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 85 IF ( .NOT. (d1/=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 86 IF ( .NOT. (d1/=mim1)) CALL prterr(kw,klog,ncase,nerror) ncase = 87 IF ( .NOT. (d1/=mzm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 88 IF ( .NOT. (z1/=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 89 IF ( .NOT. (z1/=mim1)) CALL prterr(kw,klog,ncase,nerror) ncase = 90 IF ( .NOT. (z1/=mzm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 91 IF ( .NOT. (c1/=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 92 IF ( .NOT. (c1/=mim1)) CALL prterr(kw,klog,ncase,nerror) ncase = 93 IF ( .NOT. (c1/=mzm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 94 IF ( .NOT. (mfm1/=i1)) CALL prterr(kw,klog,ncase,nerror) ncase = 95 IF ( .NOT. (mfm1/=r1)) CALL prterr(kw,klog,ncase,nerror) ncase = 96 IF ( .NOT. (mfm1/=d1)) CALL prterr(kw,klog,ncase,nerror) ncase = 97 IF ( .NOT. (mfm1/=z1)) CALL prterr(kw,klog,ncase,nerror) ncase = 98 IF ( .NOT. (mfm1/=c1)) CALL prterr(kw,klog,ncase,nerror) ncase = 99 IF ( .NOT. (mfm1/=mfm2)) CALL prterr(kw,klog,ncase,nerror) ncase = 100 IF ( .NOT. (mfm1/=mim1)) CALL prterr(kw,klog,ncase,nerror) ncase = 101 IF ( .NOT. (mfm1/=mzm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 102 IF ( .NOT. (mim1/=i1)) CALL prterr(kw,klog,ncase,nerror) ncase = 103 IF ( .NOT. (mim1/=r1)) CALL prterr(kw,klog,ncase,nerror) ncase = 104 IF ( .NOT. (mim1/=d1)) CALL prterr(kw,klog,ncase,nerror) ncase = 105 IF ( .NOT. (mim1/=z1)) CALL prterr(kw,klog,ncase,nerror) ncase = 106 IF ( .NOT. (mim1/=c1)) CALL prterr(kw,klog,ncase,nerror) ncase = 107 IF ( .NOT. (mim1/=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 108 IF ( .NOT. (mim1/=mim2)) CALL prterr(kw,klog,ncase,nerror) ncase = 109 IF ( .NOT. (mim1/=mzm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 110 IF ( .NOT. (mzm1/=i1)) CALL prterr(kw,klog,ncase,nerror) ncase = 111 IF ( .NOT. (mzm1/=r1)) CALL prterr(kw,klog,ncase,nerror) ncase = 112 IF ( .NOT. (mzm1/=d1)) CALL prterr(kw,klog,ncase,nerror) ncase = 113 IF ( .NOT. (mzm1/=z1)) CALL prterr(kw,klog,ncase,nerror) ncase = 114 IF ( .NOT. (mzm1/=c1)) CALL prterr(kw,klog,ncase,nerror) ncase = 115 IF ( .NOT. (mzm1/=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 116 IF ( .NOT. (mzm1/=mim1)) CALL prterr(kw,klog,ncase,nerror) ncase = 117 IF ( .NOT. (mzm1/=mzm2)) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test3 SUBROUTINE test4(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,nerror,ncase,klog) ! Test the '.GT.' logical operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2 TYPE (im) :: mim1, mim2 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 118 IF (i1>mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 119 IF (i1>mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 120 IF (r1>mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 121 IF (r1>mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 122 IF (d1>mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 123 IF (d1>mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 124 IF ( .NOT. (mfm1>i1)) CALL prterr(kw,klog,ncase,nerror) ncase = 125 IF ( .NOT. (mfm1>r1)) CALL prterr(kw,klog,ncase,nerror) ncase = 126 IF ( .NOT. (mfm1>d1)) CALL prterr(kw,klog,ncase,nerror) ncase = 127 IF ( .NOT. (mfm1>mfm2)) CALL prterr(kw,klog,ncase,nerror) ncase = 128 IF (mfm1>mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 129 IF ( .NOT. (mim1>i1)) CALL prterr(kw,klog,ncase,nerror) ncase = 130 IF ( .NOT. (mim1>r1)) CALL prterr(kw,klog,ncase,nerror) ncase = 131 IF ( .NOT. (mim1>d1)) CALL prterr(kw,klog,ncase,nerror) ncase = 132 IF ( .NOT. (mim1>mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 133 IF ( .NOT. (mim1>mim2)) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test4 SUBROUTINE test5(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,nerror,ncase,klog) ! Test the '.GE.' logical operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2 TYPE (im) :: mim1, mim2 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 134 IF (i1>=mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 135 IF (i1>=mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 136 IF (r1>=mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 137 IF (r1>=mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 138 IF (d1>=mfm1) CALL prterr(kw,klog,ncase,nerror) ncase = 139 IF (d1>=mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 140 IF ( .NOT. (mfm1>=i1)) CALL prterr(kw,klog,ncase,nerror) ncase = 141 IF ( .NOT. (mfm1>=r1)) CALL prterr(kw,klog,ncase,nerror) ncase = 142 IF ( .NOT. (mfm1>=d1)) CALL prterr(kw,klog,ncase,nerror) ncase = 143 IF ( .NOT. (mfm1>=mfm2)) CALL prterr(kw,klog,ncase,nerror) ncase = 144 IF (mfm1>=mim1) CALL prterr(kw,klog,ncase,nerror) ncase = 145 IF ( .NOT. (mim1>=i1)) CALL prterr(kw,klog,ncase,nerror) ncase = 146 IF ( .NOT. (mim1>=r1)) CALL prterr(kw,klog,ncase,nerror) ncase = 147 IF ( .NOT. (mim1>=d1)) CALL prterr(kw,klog,ncase,nerror) ncase = 148 IF ( .NOT. (mim1>=mfm1)) CALL prterr(kw,klog,ncase,nerror) ncase = 149 IF ( .NOT. (mim1>=mim2)) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test5 SUBROUTINE test6(i1,r1,d1,z1,c1,mfm1,mfm2,mim1,mim2,nerror,ncase,klog) ! Test the '.LT.' logical operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2 TYPE (im) :: mim1, mim2 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 150 IF ( .NOT. (i1rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 186 CALL fm_st2m('241.21',mfm4) CALL fm_st2m('661',mfm3) CALL fm_add(mfm4,mfm3,mfm4) mfm3 = r1 + mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 187 mzm3 = r1 + mzm1 CALL zm_st2m('241.21',mzm4) CALL zm_add(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 188 mfm3 = d1 + mfm1 CALL fm_st2m('391.61',mfm4) CALL fm_add(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 189 CALL fm_st2m('391.61',mfm4) CALL fm_st2m('661',mfm3) CALL fm_add(mfm4,mfm3,mfm4) mfm3 = d1 + mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 190 mzm3 = d1 + mzm1 CALL zm_st2m('391.61',mzm4) CALL zm_add(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 191 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_add(mzm4,mzm3,mzm4) mzm3 = z1 + mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 192 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_add(mzm4,mzm3,mzm4) mzm3 = z1 + mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 193 mzm3 = z1 + mzm1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_add(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 194 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_add(mzm4,mzm3,mzm4) mzm3 = c1 + mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 195 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_add(mzm4,mzm3,mzm4) mzm3 = c1 + mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 196 mzm3 = c1 + mzm1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_add(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 197 mfm3 = mfm1 + i1 CALL fm_st2m('131',mfm4) CALL fm_add(mfm1,mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 198 mfm3 = mfm1 + r1 CALL fm_st2m('241.21',mfm4) CALL fm_add(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 199 mfm3 = mfm1 + d1 CALL fm_st2m('391.61',mfm4) CALL fm_add(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 200 CALL zm_st2m('581.21',mzm3) CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_add(mzm3,mzm4,mzm4) mzm3 = mfm1 + z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 201 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('581.21',mzm4) CALL zm_add(mzm4,mzm3,mzm4) mzm3 = mfm1 + c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 202 mfm3 = mfm1 + mfm2 CALL fm_add(mfm1,mfm2,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 203 mfm3 = mfm1 + mim1 CALL fm_st2m('661',mfm4) CALL fm_add(mfm1,mfm4,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 204 mzm3 = mfm1 + mzm1 CALL zm_st2m('581.21',mzm4) CALL zm_add(mzm4,mzm1,mzm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 205 mim3 = mim1 + i1 CALL im_st2m('131',mim4) CALL im_add(mim1,mim4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 206 CALL fm_st2m('241.21',mfm3) CALL fm_st2m('661',mfm4) CALL fm_add(mfm4,mfm3,mfm4) mfm3 = mim1 + r1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 207 CALL fm_st2m('391.61',mfm3) CALL fm_st2m('661',mfm4) CALL fm_add(mfm4,mfm3,mfm4) mfm3 = mim1 + d1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 208 CALL zm_st2m('411.11 + 421.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_add(mzm4,mzm3,mzm4) mzm3 = mim1 + z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 209 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_add(mzm4,mzm3,mzm4) mzm3 = mim1 + c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 210 mfm3 = mim1 + mfm1 CALL fm_st2m('661',mfm4) CALL fm_add(mfm4,mfm1,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 211 mim3 = mim1 + mim2 CALL im_add(mim1,mim2,mim4) IF (mim4/=mim3) CALL prterr(kw,klog,ncase,nerror) ncase = 212 mzm3 = mim1 + mzm1 CALL zm_st2m('661',mzm4) CALL zm_add(mzm4,mzm1,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 213 mzm3 = mzm1 + i1 CALL zm_st2m('131',mzm4) CALL zm_add(mzm1,mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 214 mzm3 = mzm1 + r1 CALL zm_st2m('241.21',mzm4) CALL zm_add(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 215 mzm3 = mzm1 + d1 CALL zm_st2m('391.61',mzm4) CALL zm_add(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 216 mzm3 = mzm1 + z1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_add(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 217 mzm3 = mzm1 + c1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_add(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 218 mzm3 = mzm1 + mfm1 CALL zm_st2m('581.21',mzm4) CALL zm_add(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 219 mzm3 = mzm1 + mim1 CALL zm_st2m('661',mzm4) CALL zm_add(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 220 mzm3 = mzm1 + mzm2 CALL zm_add(mzm1,mzm2,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 221 mfm3 = + mfm1 CALL fm_eq(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 222 mim3 = + mim1 CALL im_eq(mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 223 mzm3 = + mzm1 CALL zm_eq(mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test8 SUBROUTINE test9(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4, & mzm1,mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '-' arithmetic operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm2, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: dsmall REAL :: rsmall ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. rsmall = epsilon(1.0)*100.0 dsmall = epsilon(1.0D0)*100.0 ncase = 224 mfm3 = i1 - mfm1 CALL fm_st2m('131',mfm4) CALL fm_sub(mfm4,mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 225 mim3 = i1 - mim1 CALL im_st2m('131',mim4) CALL im_sub(mim4,mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 226 mzm3 = i1 - mzm1 CALL zm_st2m('131',mzm4) CALL zm_sub(mzm4,mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 227 mfm3 = r1 - mfm1 CALL fm_st2m('241.21',mfm4) CALL fm_sub(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 228 CALL fm_st2m('241.21',mfm4) CALL fm_st2m('661',mfm3) CALL fm_sub(mfm4,mfm3,mfm4) mfm3 = r1 - mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 229 mzm3 = r1 - mzm1 CALL zm_st2m('241.21',mzm4) CALL zm_sub(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 230 mfm3 = d1 - mfm1 CALL fm_st2m('391.61',mfm4) CALL fm_sub(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 231 CALL fm_st2m('391.61',mfm4) CALL fm_st2m('661',mfm3) CALL fm_sub(mfm4,mfm3,mfm4) mfm3 = d1 - mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 232 mzm3 = d1 - mzm1 CALL zm_st2m('391.61',mzm4) CALL zm_sub(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 233 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_sub(mzm4,mzm3,mzm4) mzm3 = z1 - mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 234 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_sub(mzm4,mzm3,mzm4) mzm3 = z1 - mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 235 mzm3 = z1 - mzm1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_sub(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 236 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_sub(mzm4,mzm3,mzm4) mzm3 = c1 - mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 237 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_sub(mzm4,mzm3,mzm4) mzm3 = c1 - mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 238 mzm3 = c1 - mzm1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_sub(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 239 mfm3 = mfm1 - i1 CALL fm_st2m('131',mfm4) CALL fm_sub(mfm1,mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 240 mfm3 = mfm1 - r1 CALL fm_st2m('241.21',mfm4) CALL fm_sub(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 241 mfm3 = mfm1 - d1 CALL fm_st2m('391.61',mfm4) CALL fm_sub(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 242 CALL zm_st2m('581.21',mzm3) CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_sub(mzm3,mzm4,mzm4) mzm3 = mfm1 - z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 243 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('581.21',mzm4) CALL zm_sub(mzm4,mzm3,mzm4) mzm3 = mfm1 - c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 244 mfm3 = mfm1 - mfm2 CALL fm_sub(mfm1,mfm2,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 245 mfm3 = mfm1 - mim1 CALL fm_st2m('661',mfm4) CALL fm_sub(mfm1,mfm4,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 246 mzm3 = mfm1 - mzm1 CALL zm_st2m('581.21',mzm4) CALL zm_sub(mzm4,mzm1,mzm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 247 mim3 = mim1 - i1 CALL im_st2m('131',mim4) CALL im_sub(mim1,mim4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 248 CALL fm_st2m('241.21',mfm3) CALL fm_st2m('661',mfm4) CALL fm_sub(mfm4,mfm3,mfm4) mfm3 = mim1 - r1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 249 CALL fm_st2m('391.61',mfm3) CALL fm_st2m('661',mfm4) CALL fm_sub(mfm4,mfm3,mfm4) mfm3 = mim1 - d1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 250 CALL zm_st2m('411.11 + 421.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_sub(mzm4,mzm3,mzm4) mzm3 = mim1 - z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 251 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_sub(mzm4,mzm3,mzm4) mzm3 = mim1 - c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 252 mfm3 = mim1 - mfm1 CALL fm_st2m('661',mfm4) CALL fm_sub(mfm4,mfm1,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 253 mim3 = mim1 - mim2 CALL im_sub(mim1,mim2,mim4) IF (mim4/=mim3) CALL prterr(kw,klog,ncase,nerror) ncase = 254 mzm3 = mim1 - mzm1 CALL zm_st2m('661',mzm4) CALL zm_sub(mzm4,mzm1,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 255 mzm3 = mzm1 - i1 CALL zm_st2m('131',mzm4) CALL zm_sub(mzm1,mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 256 mzm3 = mzm1 - r1 CALL zm_st2m('241.21',mzm4) CALL zm_sub(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 257 mzm3 = mzm1 - d1 CALL zm_st2m('391.61',mzm4) CALL zm_sub(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 258 mzm3 = mzm1 - z1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_sub(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 259 mzm3 = mzm1 - c1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_sub(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 260 mzm3 = mzm1 - mfm1 CALL zm_st2m('581.21',mzm4) CALL zm_sub(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 261 mzm3 = mzm1 - mim1 CALL zm_st2m('661',mzm4) CALL zm_sub(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 262 mzm3 = mzm1 - mzm2 CALL zm_sub(mzm1,mzm2,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 263 mfm3 = -mfm1 CALL fm_i2m(0,mfm4) CALL fm_sub(mfm4,mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 264 mim3 = -mim1 CALL im_i2m(0,mim4) CALL im_sub(mim4,mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 265 mzm3 = -mzm1 CALL zm_i2m(0,mzm4) CALL zm_sub(mzm4,mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test9 SUBROUTINE test10(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4, & mzm1,mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '*' arithmetic operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm2, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: dsmall REAL :: rsmall ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. rsmall = epsilon(1.0)*100.0 dsmall = epsilon(1.0D0)*100.0 ncase = 266 mfm3 = i1*mfm1 CALL fm_st2m('131',mfm4) CALL fm_mpy(mfm4,mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 267 mim3 = i1*mim1 CALL im_st2m('131',mim4) CALL im_mpy(mim4,mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 268 mzm3 = i1*mzm1 CALL zm_st2m('131',mzm4) CALL zm_mpy(mzm4,mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 269 mfm3 = r1*mfm1 CALL fm_st2m('241.21',mfm4) CALL fm_mpy(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 270 CALL fm_st2m('241.21',mfm4) CALL fm_st2m('661',mfm3) CALL fm_mpy(mfm4,mfm3,mfm4) mfm3 = r1*mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 271 mzm3 = r1*mzm1 CALL zm_st2m('241.21',mzm4) CALL zm_mpy(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 272 mfm3 = d1*mfm1 CALL fm_st2m('391.61',mfm4) CALL fm_mpy(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 273 CALL fm_st2m('391.61',mfm4) CALL fm_st2m('661',mfm3) CALL fm_mpy(mfm4,mfm3,mfm4) mfm3 = d1*mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 274 mzm3 = d1*mzm1 CALL zm_st2m('391.61',mzm4) CALL zm_mpy(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 275 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_mpy(mzm4,mzm3,mzm4) mzm3 = z1*mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 276 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_mpy(mzm4,mzm3,mzm4) mzm3 = z1*mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 277 mzm3 = z1*mzm1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_mpy(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 278 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_mpy(mzm4,mzm3,mzm4) mzm3 = c1*mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 279 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_mpy(mzm4,mzm3,mzm4) mzm3 = c1*mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 280 mzm3 = c1*mzm1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_mpy(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 281 mfm3 = mfm1*i1 CALL fm_st2m('131',mfm4) CALL fm_mpy(mfm1,mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 282 mfm3 = mfm1*r1 CALL fm_st2m('241.21',mfm4) CALL fm_mpy(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 283 mfm3 = mfm1*d1 CALL fm_st2m('391.61',mfm4) CALL fm_mpy(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 284 CALL zm_st2m('581.21',mzm3) CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_mpy(mzm3,mzm4,mzm4) mzm3 = mfm1*z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 285 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('581.21',mzm4) CALL zm_mpy(mzm4,mzm3,mzm4) mzm3 = mfm1*c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 286 mfm3 = mfm1*mfm2 CALL fm_mpy(mfm1,mfm2,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 287 mfm3 = mfm1*mim1 CALL fm_st2m('661',mfm4) CALL fm_mpy(mfm1,mfm4,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 288 mzm3 = mfm1*mzm1 CALL zm_st2m('581.21',mzm4) CALL zm_mpy(mzm4,mzm1,mzm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 289 mim3 = mim1*i1 CALL im_st2m('131',mim4) CALL im_mpy(mim1,mim4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 290 CALL fm_st2m('241.21',mfm3) CALL fm_st2m('661',mfm4) CALL fm_mpy(mfm4,mfm3,mfm4) mfm3 = mim1*r1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 291 CALL fm_st2m('391.61',mfm3) CALL fm_st2m('661',mfm4) CALL fm_mpy(mfm4,mfm3,mfm4) mfm3 = mim1*d1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 292 CALL zm_st2m('411.11 + 421.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_mpy(mzm4,mzm3,mzm4) mzm3 = mim1*z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 293 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_mpy(mzm4,mzm3,mzm4) mzm3 = mim1*c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 294 mfm3 = mim1*mfm1 CALL fm_st2m('661',mfm4) CALL fm_mpy(mfm4,mfm1,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 295 mim3 = mim1*mim2 CALL im_mpy(mim1,mim2,mim4) IF (mim4/=mim3) CALL prterr(kw,klog,ncase,nerror) ncase = 296 mzm3 = mim1*mzm1 CALL zm_st2m('661',mzm4) CALL zm_mpy(mzm4,mzm1,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 297 mzm3 = mzm1*i1 CALL zm_st2m('131',mzm4) CALL zm_mpy(mzm1,mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 298 mzm3 = mzm1*r1 CALL zm_st2m('241.21',mzm4) CALL zm_mpy(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 299 mzm3 = mzm1*d1 CALL zm_st2m('391.61',mzm4) CALL zm_mpy(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 300 mzm3 = mzm1*z1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_mpy(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 301 mzm3 = mzm1*c1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_mpy(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 302 mzm3 = mzm1*mfm1 CALL zm_st2m('581.21',mzm4) CALL zm_mpy(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 303 mzm3 = mzm1*mim1 CALL zm_st2m('661',mzm4) CALL zm_mpy(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 304 mzm3 = mzm1*mzm2 CALL zm_mpy(mzm1,mzm2,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test10 SUBROUTINE test11(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4, & mzm1,mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '/' arithmetic operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm2, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: dsmall REAL :: rsmall ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. rsmall = epsilon(1.0)*100.0 dsmall = epsilon(1.0D0)*100.0 ncase = 305 mfm3 = i1/mfm1 CALL fm_st2m('131',mfm4) CALL fm_div(mfm4,mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 306 mim3 = i1/mim1 CALL im_st2m('131',mim4) CALL im_div(mim4,mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 307 mzm3 = i1/mzm1 CALL zm_st2m('131',mzm4) CALL zm_div(mzm4,mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 308 mfm3 = r1/mfm1 CALL fm_st2m('241.21',mfm4) CALL fm_div(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 309 CALL fm_st2m('241.21',mfm4) CALL fm_st2m('661',mfm3) CALL fm_div(mfm4,mfm3,mfm4) mfm3 = r1/mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 310 mzm3 = r1/mzm1 CALL zm_st2m('241.21',mzm4) CALL zm_div(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 311 mfm3 = d1/mfm1 CALL fm_st2m('391.61',mfm4) CALL fm_div(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 312 CALL fm_st2m('391.61',mfm4) CALL fm_st2m('661',mfm3) CALL fm_div(mfm4,mfm3,mfm4) mfm3 = d1/mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 313 mzm3 = d1/mzm1 CALL zm_st2m('391.61',mzm4) CALL zm_div(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 314 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_div(mzm4,mzm3,mzm4) mzm3 = z1/mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 315 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_div(mzm4,mzm3,mzm4) mzm3 = z1/mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 316 mzm3 = z1/mzm1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_div(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 317 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_div(mzm4,mzm3,mzm4) mzm3 = c1/mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 318 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_div(mzm4,mzm3,mzm4) mzm3 = c1/mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 319 mzm3 = c1/mzm1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_div(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 320 mfm3 = mfm1/i1 CALL fm_st2m('131',mfm4) CALL fm_div(mfm1,mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 321 mfm3 = mfm1/r1 CALL fm_st2m('241.21',mfm4) CALL fm_div(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 322 mfm3 = mfm1/d1 CALL fm_st2m('391.61',mfm4) CALL fm_div(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 323 CALL zm_st2m('581.21',mzm3) CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_div(mzm3,mzm4,mzm4) mzm3 = mfm1/z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 324 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('581.21',mzm4) CALL zm_div(mzm4,mzm3,mzm4) mzm3 = mfm1/c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 325 mfm3 = mfm1/mfm2 CALL fm_div(mfm1,mfm2,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 326 mfm3 = mfm1/mim1 CALL fm_st2m('661',mfm4) CALL fm_div(mfm1,mfm4,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 327 mzm3 = mfm1/mzm1 CALL zm_st2m('581.21',mzm4) CALL zm_div(mzm4,mzm1,mzm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 328 mim3 = mim1/i1 CALL im_st2m('131',mim4) CALL im_div(mim1,mim4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 329 CALL fm_st2m('241.21',mfm3) CALL fm_st2m('661',mfm4) CALL fm_div(mfm4,mfm3,mfm4) mfm3 = mim1/r1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 330 CALL fm_st2m('391.61',mfm3) CALL fm_st2m('661',mfm4) CALL fm_div(mfm4,mfm3,mfm4) mfm3 = mim1/d1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 331 CALL zm_st2m('411.11 + 421.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_div(mzm4,mzm3,mzm4) mzm3 = mim1/z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 332 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_div(mzm4,mzm3,mzm4) mzm3 = mim1/c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 333 mfm3 = mim1/mfm1 CALL fm_st2m('661',mfm4) CALL fm_div(mfm4,mfm1,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 334 mim3 = mim1/mim2 CALL im_div(mim1,mim2,mim4) IF (mim4/=mim3) CALL prterr(kw,klog,ncase,nerror) ncase = 335 mzm3 = mim1/mzm1 CALL zm_st2m('661',mzm4) CALL zm_div(mzm4,mzm1,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 336 mzm3 = mzm1/i1 CALL zm_st2m('131',mzm4) CALL zm_div(mzm1,mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 337 mzm3 = mzm1/r1 CALL zm_st2m('241.21',mzm4) CALL zm_div(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 338 mzm3 = mzm1/d1 CALL zm_st2m('391.61',mzm4) CALL zm_div(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 339 mzm3 = mzm1/z1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_div(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 340 mzm3 = mzm1/c1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_div(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 341 mzm3 = mzm1/mfm1 CALL zm_st2m('581.21',mzm4) CALL zm_div(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 342 mzm3 = mzm1/mim1 CALL zm_st2m('661',mzm4) CALL zm_div(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 343 mzm3 = mzm1/mzm2 CALL zm_div(mzm1,mzm2,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test11 SUBROUTINE test12(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4, & mzm1,mzm2,mzm3,mzm4,nerror,ncase,klog) ! Test the '**' arithmetic operator. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm2, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: dsmall REAL :: rsmall INTEGER :: i3 ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ! Use a larger error tolerance for large exponents. rsmall = epsilon(1.0)*10000.0 dsmall = epsilon(1.0D0)*10000.0 ncase = 344 mfm3 = i1**mfm1 CALL fm_st2m('131',mfm4) CALL fm_pwr(mfm4,mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 345 i3 = 13 mim3 = i3**mim1 CALL im_st2m('13',mim4) CALL im_pwr(mim4,mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 346 mzm3 = i1**mzm1 CALL zm_st2m('131',mzm4) CALL zm_pwr(mzm4,mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 347 mfm3 = r1**mfm1 CALL fm_st2m('241.21',mfm4) CALL fm_pwr(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 348 CALL fm_st2m('241.21',mfm4) CALL fm_st2m('661',mfm3) CALL fm_pwr(mfm4,mfm3,mfm4) mfm3 = r1**mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 349 mzm3 = r1**mzm1 CALL zm_st2m('241.21',mzm4) CALL zm_pwr(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 350 mfm3 = d1**mfm1 CALL fm_st2m('391.61',mfm4) CALL fm_pwr(mfm4,mfm1,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 351 CALL fm_st2m('391.61',mfm4) CALL fm_st2m('661',mfm3) CALL fm_pwr(mfm4,mfm3,mfm4) mfm3 = d1**mim1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 352 mzm3 = d1**mzm1 CALL zm_st2m('391.61',mzm4) CALL zm_pwr(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 353 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_pwr(mzm4,mzm3,mzm4) mzm3 = z1**mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 354 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_pwr(mzm4,mzm3,mzm4) mzm3 = z1**mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 355 mzm3 = z1**mzm1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_pwr(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 356 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('581.21',mzm3) CALL zm_pwr(mzm4,mzm3,mzm4) mzm3 = c1**mfm1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 357 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_st2m('661',mzm3) CALL zm_pwr(mzm4,mzm3,mzm4) mzm3 = c1**mim1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 358 mzm3 = c1**mzm1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_pwr(mzm4,mzm1,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 359 mfm3 = mfm1**i1 CALL fm_st2m('131',mfm4) CALL fm_pwr(mfm1,mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 360 mfm3 = mfm1**r1 CALL fm_st2m('241.21',mfm4) CALL fm_pwr(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 361 mfm3 = mfm1**d1 CALL fm_st2m('391.61',mfm4) CALL fm_pwr(mfm1,mfm4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 362 CALL zm_st2m('581.21',mzm3) CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_pwr(mzm3,mzm4,mzm4) mzm3 = mfm1**z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 363 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('581.21',mzm4) CALL zm_pwr(mzm4,mzm3,mzm4) mzm3 = mfm1**c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 364 mfm3 = mfm1**mfm2 CALL fm_pwr(mfm1,mfm2,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 365 mfm3 = mfm1**mim1 CALL fm_st2m('661',mfm4) CALL fm_pwr(mfm1,mfm4,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 366 mzm3 = mfm1**mzm1 CALL zm_st2m('581.21',mzm4) CALL zm_pwr(mzm4,mzm1,mzm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 367 i3 = 17 mim3 = mim1**i3 CALL im_st2m('17',mim4) CALL im_pwr(mim1,mim4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 368 CALL fm_st2m('241.21',mfm3) CALL fm_st2m('661',mfm4) CALL fm_pwr(mfm4,mfm3,mfm4) mfm3 = mim1**r1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 369 CALL fm_st2m('391.61',mfm3) CALL fm_st2m('661',mfm4) CALL fm_pwr(mfm4,mfm3,mfm4) mfm3 = mim1**d1 CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 370 CALL zm_st2m('411.11 + 421.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_pwr(mzm4,mzm3,mzm4) mzm3 = mim1**z1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 371 CALL zm_st2m('431.11 + 441.21 i',mzm3) CALL zm_st2m('661',mzm4) CALL zm_pwr(mzm4,mzm3,mzm4) mzm3 = mim1**c1 CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 372 mfm3 = mim1**mfm1 CALL fm_st2m('661',mfm4) CALL fm_pwr(mfm4,mfm1,mfm4) IF (mfm4/=mfm3) CALL prterr(kw,klog,ncase,nerror) ncase = 373 mim4 = 19 mim3 = mim1**mim4 CALL im_pwr(mim1,mim4,mim4) IF (mim4/=mim3) CALL prterr(kw,klog,ncase,nerror) ncase = 374 mzm3 = mim1**mzm1 CALL zm_st2m('661',mzm4) CALL zm_pwr(mzm4,mzm1,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 375 mzm3 = mzm1**i1 CALL zm_st2m('131',mzm4) CALL zm_pwr(mzm1,mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 376 mzm3 = mzm1**r1 CALL zm_st2m('241.21',mzm4) CALL zm_pwr(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 377 mzm3 = mzm1**d1 CALL zm_st2m('391.61',mzm4) CALL zm_pwr(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 378 mzm3 = mzm1**z1 CALL zm_st2m('411.11 + 421.21 i',mzm4) CALL zm_pwr(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 379 mzm3 = mzm1**c1 CALL zm_st2m('431.11 + 441.21 i',mzm4) CALL zm_pwr(mzm1,mzm4,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) IF (mfm4>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 380 mzm3 = mzm1**mfm1 CALL zm_st2m('581.21',mzm4) CALL zm_pwr(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 381 mzm3 = mzm1**mim1 CALL zm_st2m('661',mzm4) CALL zm_pwr(mzm1,mzm4,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) ncase = 382 mzm3 = mzm1**mzm2 CALL zm_pwr(mzm1,mzm2,mzm4) IF (mzm4/=mzm3) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test12 SUBROUTINE test13(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim3,mim4,mzm1, & mzm3,mzm4,nerror,ncase,klog) ! Test functions ABS, ..., CEILING. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Scalars .. INTEGER :: j, jerr ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 383 mfm3 = abs(mfm1) CALL fm_abs(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 384 mim3 = abs(mim1) CALL im_abs(mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 385 mfm3 = abs(mzm1) CALL zm_abs(mzm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 386 CALL fm_st2m('0.7654',mfm4) mfm3 = acos(mfm4) CALL fm_acos(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 387 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = acos(mzm4) CALL zm_acos(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 388 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mfm3 = aimag(mzm4) CALL zm_imag(mzm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 389 mfm3 = aint(mfm1) CALL fm_int(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 390 mzm3 = aint(mzm1) CALL zm_int(mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 391 mfm3 = anint(mfm1) CALL fm_nint(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 392 mzm3 = anint(mzm1) CALL zm_nint(mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 393 CALL fm_st2m('0.7654',mfm4) mfm3 = asin(mfm4) CALL fm_asin(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 394 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = asin(mzm4) CALL zm_asin(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 395 CALL fm_st2m('0.7654',mfm4) mfm3 = atan(mfm4) CALL fm_atan(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 396 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = atan(mzm4) CALL zm_atan(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 397 mfm3 = atan2(mfm1,mfm2) CALL fm_atn2(mfm1,mfm2,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 398 jerr = -1 DO j = 0, 10 IF (btest(661,j)) THEN IF ( .NOT. btest(mim1,j)) jerr = j ELSE IF (btest(mim1,j)) jerr = j END IF END DO IF (jerr>=0) CALL prterr(kw,klog,ncase,nerror) ncase = 399 CALL fm_st2m('12.37654',mfm4) mfm3 = ceiling(mfm4) CALL fm_st2m('13',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 400 CALL fm_st2m('-12.7654',mfm4) mfm3 = ceiling(mfm4) CALL fm_st2m('-12',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 401 CALL zm_st2m('12.37654 - 22.54 i',mzm4) mzm3 = ceiling(mzm4) CALL zm_st2m('13 - 22 i',mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 402 CALL zm_st2m('-12.7654 + 22.31 i',mzm4) mzm3 = ceiling(mzm4) CALL zm_st2m('-12 + 23 i',mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test13 SUBROUTINE test14(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4, & mzm1,mzm3,mzm4,nerror,ncase,klog) ! Test functions CMPLX, ..., EXPONENT. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Structures .. TYPE (fm) :: mfmv1(3), mfmv2(3) TYPE (im) :: mimv1(3), mimv2(3) TYPE (zm) :: mzmv1(3), mzmv2(3) ! .. ! .. Local Scalars .. INTEGER :: j ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 403 mzm3 = cmplx(mfm1,mfm2) CALL zm_cmpx(mfm1,mfm2,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 404 mzm3 = cmplx(mim1,mim2) CALL im_i2fm(mim1,mfm3) CALL im_i2fm(mim2,mfm4) CALL zm_cmpx(mfm3,mfm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 405 mzm3 = cmplx(mfm1) CALL fm_i2m(0,mfm4) CALL zm_cmpx(mfm1,mfm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 406 mzm3 = cmplx(mim1) CALL im_i2fm(mim1,mfm3) CALL fm_i2m(0,mfm4) CALL zm_cmpx(mfm3,mfm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 407 mzm3 = conjg(mzm1) CALL zm_conj(mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 408 CALL fm_st2m('0.7654',mfm4) mfm3 = cos(mfm4) CALL fm_cos(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 409 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = cos(mzm4) CALL zm_cos(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 410 CALL fm_st2m('0.7654',mfm4) mfm3 = cosh(mfm4) CALL fm_cosh(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 411 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = cosh(mzm4) CALL zm_cosh(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 412 mfm3 = dble(mfm1) CALL fm_eq(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 413 mfm3 = dble(mim1) CALL im_i2fm(mim1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 414 mfm3 = dble(mzm1) CALL zm_real(mzm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 415 j = digits(mfm1) IF (j/=ndig) CALL prterr(kw,klog,ncase,nerror) ncase = 416 j = digits(mim1) IF (j/=ndigmx) CALL prterr(kw,klog,ncase,nerror) ncase = 417 j = digits(mzm1) IF (j/=ndig) CALL prterr(kw,klog,ncase,nerror) ncase = 418 mfm3 = dim(mfm1,mfm2) CALL fm_dim(mfm1,mfm2,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 419 mim3 = dim(mim1,mim2) CALL im_dim(mim1,mim2,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 420 mfm3 = dint (mfm1) CALL fm_int(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 421 mzm3 = dint (mzm1) CALL zm_int(mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 422 CALL fm_st2m('1.23',mfmv1(1)) CALL fm_st2m('2.23',mfmv1(2)) CALL fm_st2m('3.23',mfmv1(3)) CALL fm_st2m('4.23',mfmv2(1)) CALL fm_st2m('5.23',mfmv2(2)) CALL fm_st2m('6.23',mfmv2(3)) mfm3 = dotproduct(mfmv1,mfmv2) mfm4 = 0 DO j = 1, 3 mfm4 = mfm4 + mfmv1(j)*mfmv2(j) END DO IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 423 CALL im_st2m('12',mimv1(1)) CALL im_st2m('23',mimv1(2)) CALL im_st2m('34',mimv1(3)) CALL im_st2m('-14',mimv2(1)) CALL im_st2m('-5',mimv2(2)) CALL im_st2m('16',mimv2(3)) mim3 = dotproduct(mimv1,mimv2) mim4 = 0 DO j = 1, 3 mim4 = mim4 + mimv1(j)*mimv2(j) END DO IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 424 CALL zm_st2m('1.23 + 1.67 i',mzmv1(1)) CALL zm_st2m('2.23 - 2.56 i',mzmv1(2)) CALL zm_st2m('3.23 + 3.45 i',mzmv1(3)) CALL zm_st2m('4.23 - 4.34 i',mzmv2(1)) CALL zm_st2m('5.23 + 5.23 i',mzmv2(2)) CALL zm_st2m('6.23 - 6.12 i',mzmv2(3)) mzm3 = dotproduct(mzmv1,mzmv2) mzm4 = 0 DO j = 1, 3 mzm4 = mzm4 + mzmv1(j)*mzmv2(j) END DO IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 425 mfm3 = epsilon(mfm1) CALL fm_i2m(1,mfm4) CALL fm_ulp(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 426 CALL fm_st2m('0.7654',mfm4) mfm3 = exp(mfm4) CALL fm_exp(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 427 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = exp(mzm4) CALL zm_exp(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 428 j = exponent(mfm1) IF (j/=int(mfm1%mfm(1))) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test14 SUBROUTINE test15(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4, & mzm1,mzm3,mzm4,nerror,ncase,klog) ! Test functions FLOOR, ..., MIN. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Structures .. TYPE (fm) :: mfma(3,3), mfmb(3,3), mfmc(3,3) TYPE (im) :: mima(2,2), mimb(2,2), mimc(2,2) TYPE (zm) :: mzma(2,3), mzmb(3,4), mzmc(2,4) ! .. ! .. Local Scalars .. INTEGER :: i, j ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 429 CALL fm_st2m('12.37654',mfm4) mfm3 = floor(mfm4) CALL fm_st2m('12',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 430 CALL fm_st2m('-12.7654',mfm4) mfm3 = floor(mfm4) CALL fm_st2m('-13',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 431 CALL im_st2m('12',mim4) mim3 = floor(mim4) CALL im_st2m('12',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 432 CALL im_st2m('-123',mim4) mim3 = floor(mim4) CALL im_st2m('-123',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 433 CALL zm_st2m('12.37654 - 22.54 i',mzm4) mzm3 = floor(mzm4) CALL zm_st2m('12 - 23 i',mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 434 CALL zm_st2m('-12.7654 + 22.31 i',mzm4) mzm3 = floor(mzm4) CALL zm_st2m('-13 + 22 i',mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 435 CALL fm_st2m('12.37654',mfm4) mfm3 = fraction(mfm4) mfm4%mfm(1) = 0 IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 436 CALL zm_st2m('12.37654 - 22.54',mzm4) mzm3 = fraction(mzm4) mzm4%mzm(1) = 0 mzm4%mzm(kptimu+1) = 0 IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 437 mfm3 = huge(mfm1) CALL fm_big(mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 438 mim3 = huge(mim1) CALL im_big(mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 439 mzm3 = huge(mzm1) CALL fm_big(mfm4) CALL zm_cmpx(mfm4,mfm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 440 mim3 = int(mfm1) CALL fm_int(mfm1,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 441 mim3 = int(mim1) CALL im_eq(mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 442 mim3 = int(mzm1) CALL zm_int(mzm1,mzm4) CALL zm_real(mzm4,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 443 CALL fm_st2m('0.7654',mfm4) mfm3 = log(mfm4) CALL fm_ln(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 444 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = log(mzm4) CALL zm_ln(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 445 CALL fm_st2m('0.7654',mfm4) mfm3 = log10(mfm4) CALL fm_lg10(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 446 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = log10(mzm4) CALL zm_lg10(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 447 DO i = 1, 3 DO j = 1, 3 mfma(i,j) = 3*(j-1) + i mfmb(i,j) = 3*(i-1) + j + 10 END DO END DO mfmc = matmul(mfma,mfmb) mfm3 = abs(mfmc(1,1)-186) + abs(mfmc(1,2)-198) + abs(mfmc(1,3)-210) + & abs(mfmc(2,1)-228) + abs(mfmc(2,2)-243) + abs(mfmc(2,3)-258) + & abs(mfmc(3,1)-270) + abs(mfmc(3,2)-288) + abs(mfmc(3,3)-306) IF (mfm3/=0) CALL prterr(kw,klog,ncase,nerror) ncase = 448 DO i = 1, 2 DO j = 1, 2 mima(i,j) = 2*(j-1) + i + 20 mimb(i,j) = 2*(i-1) + j + 30 END DO END DO mimc = matmul(mima,mimb) mim3 = abs(mimc(1,1)-1410) + abs(mimc(1,2)-1454) + abs(mimc(2,1)-1474) + & abs(mimc(2,2)-1520) IF (mim3/=0) CALL prterr(kw,klog,ncase,nerror) ncase = 449 DO i = 1, 2 DO j = 1, 3 mzma(i,j) = cmplx(to_fm(2*(j-1)+i+10),to_fm(2*(j-1)+i+20)) END DO END DO DO i = 1, 3 DO j = 1, 4 mzmb(i,j) = cmplx(to_fm(4*(i-1)+j+50),to_fm(4*(i-1)+j+30)) END DO END DO mzmc = matmul(mzma,mzmb) mfm3 = abs(mzmc(1,1)-to_zm('-270 + 5192 i')) + & abs(mzmc(1,2)-to_zm('-300 + 5300 i')) + abs(mzmc(1,3)-to_zm( & '-330 + 5408 i')) + abs(mzmc(1,4)-to_zm('-360 + 5516 i')) + & abs(mzmc(2,1)-to_zm('-210 + 5462 i')) + abs(mzmc(2,2)-to_zm( & '-240 + 5576 i')) + abs(mzmc(2,3)-to_zm('-270 + 5690 i')) + & abs(mzmc(2,4)-to_zm('-300 + 5804 i')) IF (mfm3/=0) CALL prterr(kw,klog,ncase,nerror) ncase = 450 mfm3 = max(mfm1,mfm2) CALL fm_max(mfm1,mfm2,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 451 CALL fm_st2m('0.7654',mfm4) mfm3 = max(mfm2,mfm1,mfm4) CALL fm_max(mfm1,mfm4,mfm4) CALL fm_max(mfm2,mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 452 mim3 = max(mim1,mim2) CALL im_max(mim1,mim2,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 453 CALL im_st2m('7654',mim4) CALL im_st2m('-1654',mim3) mim3 = max(mim2,mim1,mim3,mim4) CALL im_st2m('7654',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 454 j = maxexponent(mfm1) IF (j/=int(mxexp)+1) CALL prterr(kw,klog,ncase,nerror) ncase = 455 mfm3 = min(mfm1,mfm2) CALL fm_min(mfm1,mfm2,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 456 CALL fm_st2m('0.7654',mfm4) mfm3 = min(mfm2,mfm1,mfm4) CALL fm_min(mfm1,mfm4,mfm4) CALL fm_min(mfm2,mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 457 mim3 = min(mim1,mim2) CALL im_min(mim1,mim2,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 458 CALL im_st2m('7654',mim4) CALL im_st2m('-1654',mim3) mim3 = min(mim2,mim1,mim3,mim4) CALL im_st2m('-1654',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test15 SUBROUTINE test16(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3, & mzm4,nerror,ncase,klog) ! Test functions MINEXPONENT, ..., RRSPACING. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm3, mfm4 TYPE (im) :: mim1, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Structures .. TYPE (fm) :: mfm5 ! .. ! .. Local Scalars .. INTEGER :: j ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 459 j = minexponent(mfm1) IF (j/=-int(mxexp)) CALL prterr(kw,klog,ncase,nerror) ncase = 460 CALL fm_st2m('8',mfm3) CALL fm_st2m('5',mfm4) mfm3 = mod(mfm3,mfm4) CALL fm_st2m('3',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 461 CALL fm_st2m('-8',mfm3) CALL fm_st2m('5',mfm4) mfm3 = mod(mfm3,mfm4) CALL fm_st2m('-3',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 462 CALL fm_st2m('8',mfm3) CALL fm_st2m('-5',mfm4) mfm3 = mod(mfm3,mfm4) CALL fm_st2m('3',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 463 CALL fm_st2m('-8',mfm3) CALL fm_st2m('-5',mfm4) mfm3 = mod(mfm3,mfm4) CALL fm_st2m('-3',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 464 CALL im_st2m('8',mim3) CALL im_st2m('5',mim4) mim3 = mod(mim3,mim4) CALL im_st2m('3',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 465 CALL im_st2m('-8',mim3) CALL im_st2m('5',mim4) mim3 = mod(mim3,mim4) CALL im_st2m('-3',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 466 CALL im_st2m('8',mim3) CALL im_st2m('-5',mim4) mim3 = mod(mim3,mim4) CALL im_st2m('3',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 467 CALL im_st2m('-8',mim3) CALL im_st2m('-5',mim4) mim3 = mod(mim3,mim4) CALL im_st2m('-3',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 468 CALL fm_st2m('8',mfm3) CALL fm_st2m('5',mfm4) mfm3 = modulo(mfm3,mfm4) CALL fm_st2m('3',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 469 CALL fm_st2m('-8',mfm3) CALL fm_st2m('5',mfm4) mfm3 = modulo(mfm3,mfm4) CALL fm_st2m('2',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 470 CALL fm_st2m('8',mfm3) CALL fm_st2m('-5',mfm4) mfm3 = modulo(mfm3,mfm4) CALL fm_st2m('-2',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 471 CALL fm_st2m('-8',mfm3) CALL fm_st2m('-5',mfm4) mfm3 = modulo(mfm3,mfm4) CALL fm_st2m('-3',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 472 CALL im_st2m('8',mim3) CALL im_st2m('5',mim4) mim3 = modulo(mim3,mim4) CALL im_st2m('3',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 473 CALL im_st2m('-8',mim3) CALL im_st2m('5',mim4) mim3 = modulo(mim3,mim4) CALL im_st2m('2',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 474 CALL im_st2m('8',mim3) CALL im_st2m('-5',mim4) mim3 = modulo(mim3,mim4) CALL im_st2m('-2',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 475 CALL im_st2m('-8',mim3) CALL im_st2m('-5',mim4) mim3 = modulo(mim3,mim4) CALL im_st2m('-3',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 476 CALL fm_st2m('0',mfm4) CALL fm_st2m('1',mfm3) CALL fm_big(mfm5) CALL fm_div(mfm3,mfm5,mfm5) mfm3 = nearest(mfm4,mfm3) IF (mfm3/=mfm5) CALL prterr(kw,klog,ncase,nerror) ncase = 477 CALL fm_st2m('0',mfm4) CALL fm_st2m('-1',mfm3) CALL fm_big(mfm5) CALL fm_div(mfm3,mfm5,mfm5) mfm3 = nearest(mfm4,mfm3) IF (mfm3/=mfm5) CALL prterr(kw,klog,ncase,nerror) ncase = 478 CALL fm_st2m('2.345',mfm4) CALL fm_st2m('1',mfm3) mfm3 = nearest(mfm4,mfm3) CALL fm_ulp(mfm4,mfm5) CALL fm_add(mfm4,mfm5,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 479 CALL fm_st2m('2.345',mfm4) CALL fm_st2m('-1',mfm3) mfm3 = nearest(mfm4,mfm3) CALL fm_ulp(mfm4,mfm5) CALL fm_sub(mfm4,mfm5,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 480 CALL fm_st2m('1',mfm4) CALL fm_st2m('-1',mfm3) mfm3 = nearest(mfm4,mfm3) CALL fm_st2m('0.99',mfm5) CALL fm_ulp(mfm5,mfm5) CALL fm_sub(mfm4,mfm5,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 481 CALL fm_st2m('-1',mfm4) CALL fm_st2m('12',mfm3) mfm3 = nearest(mfm4,mfm3) CALL fm_st2m('-0.99',mfm5) CALL fm_ulp(mfm5,mfm5) CALL fm_sub(mfm4,mfm5,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 482 mim3 = nint(mfm1) CALL fm_nint(mfm1,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 483 mim3 = nint(mim1) CALL im_eq(mim1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 484 mim3 = nint(mzm1) CALL zm_nint(mzm1,mzm4) CALL zm_real(mzm4,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 485 j = precision(mfm1) IF (j/=int(log10(real(mbase))*(ndig-1)+1)) CALL prterr(kw,klog,ncase, & nerror) ncase = 486 j = precision(mzm1) IF (j/=int(log10(real(mbase))*(ndig-1)+1)) CALL prterr(kw,klog,ncase, & nerror) ncase = 487 j = radix(mfm1) IF (j/=int(mbase)) CALL prterr(kw,klog,ncase,nerror) ncase = 488 j = radix(mim1) IF (j/=int(mbase)) CALL prterr(kw,klog,ncase,nerror) ncase = 489 j = radix(mzm1) IF (j/=int(mbase)) CALL prterr(kw,klog,ncase,nerror) ncase = 490 j = range(mfm1) IF (j/=int(mxexp*log10(real(mbase)))) CALL prterr(kw,klog,ncase,nerror) ncase = 491 j = range(mim1) IF (j/=int(ndigmx*log10(real(mbase)))) CALL prterr(kw,klog,ncase,nerror) ncase = 492 j = range(mzm1) IF (j/=int(mxexp*log10(real(mbase)))) CALL prterr(kw,klog,ncase,nerror) ncase = 493 mfm3 = real(mfm1) CALL fm_eq(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 494 mfm3 = real(mim1) CALL im_i2fm(mim1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 495 mfm3 = real(mzm1) CALL zm_real(mzm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 496 mfm3 = rrspacing(mfm1) CALL fm_abs(mfm1,mfm4) mfm4%mfm(1) = ndig IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test16 SUBROUTINE test17(i1,r1,d1,z1,c1,mfm1,mfm2,mfm3,mfm4,mim1,mim2,mim3,mim4, & mzm1,mzm3,mzm4,nerror,ncase,klog) ! Test functions SCALE, ..., TINY. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm2, mfm3, mfm4 TYPE (im) :: mim1, mim2, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. ncase = 497 CALL fm_st2m('0.7654',mfm4) mfm3 = scale(mfm4,1) CALL fm_mpyi(mfm4,int(mbase),mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 498 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = scale(mzm4,-2) CALL zm_divi(mzm4,int(mbase),mzm4) CALL zm_divi(mzm4,int(mbase),mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 499 CALL fm_st2m('0.7654',mfm4) mfm3 = setexponent(mfm4,1) CALL fm_mpyi(mfm4,int(mbase),mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 500 CALL fm_st2m('0.7654',mfm4) mfm3 = sign(mfm4,mfm2) CALL fm_sign(mfm4,mfm2,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 501 CALL im_st2m('231',mim4) mim3 = sign(mim4,mim2) CALL im_sign(mim4,mim2,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 502 CALL fm_st2m('0.7654',mfm4) mfm3 = sin(mfm4) CALL fm_sin(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 503 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = sin(mzm4) CALL zm_sin(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 504 CALL fm_st2m('0.7654',mfm4) mfm3 = sinh(mfm4) CALL fm_sinh(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 505 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = sinh(mzm4) CALL zm_sinh(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 506 CALL fm_st2m('-0.7654',mfm4) mfm3 = spacing(mfm4) CALL fm_ulp(mfm4,mfm4) CALL fm_abs(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 507 CALL fm_st2m('0.7654',mfm4) mfm3 = sqrt(mfm4) CALL fm_sqrt(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 508 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = sqrt(mzm4) CALL zm_sqrt(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 509 CALL fm_st2m('0.7654',mfm4) mfm3 = tan(mfm4) CALL fm_tan(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 510 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = tan(mzm4) CALL zm_tan(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 511 CALL fm_st2m('0.7654',mfm4) mfm3 = tanh(mfm4) CALL fm_tanh(mfm4,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 512 CALL zm_st2m('0.7654 - 0.3456 i',mzm4) mzm3 = tanh(mzm4) CALL zm_tanh(mzm4,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 513 CALL fm_big(mfm4) CALL fm_i2m(1,mfm3) CALL fm_div(mfm3,mfm4,mfm4) mfm3 = tiny(mfm1) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 514 mim3 = tiny(mim1) CALL im_i2m(1,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 515 CALL fm_big(mfm4) CALL fm_i2m(1,mfm3) CALL fm_div(mfm3,mfm4,mfm4) CALL zm_cmpx(mfm4,mfm4,mzm4) mzm3 = tiny(mzm1) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test17 SUBROUTINE test18(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3, & mzm4,nerror,ncase,klog) ! Test functions TO_FM, TO_IM, TO_ZM, ..., TO_DPZ. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm3, mfm4 TYPE (im) :: mim1, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Structures .. TYPE (fm) :: mfm5 ! .. ! .. Local Scalars .. COMPLEX (kind(0.0D0)) :: c2 COMPLEX :: z2 REAL (KIND(0.0D0)) :: d2, d3, dsmall REAL :: r2, rsmall INTEGER :: i2 ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. rsmall = epsilon(1.0)*100.0 dsmall = epsilon(1.0D0)*100.0 ncase = 516 mfm3 = to_fm(123) CALL fm_i2m(123,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 517 mfm3 = to_fm(123.4) CALL fm_sp2m(123.4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 518 mfm3 = to_fm(123.45D0) CALL fm_dp2m(123.45D0,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = dsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 519 mfm3 = to_fm(cmplx(123.4,567.8)) CALL fm_sp2m(123.4,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 520 mfm3 = to_fm(cmplx(123.4D0,567.8D0,kind(1.0D0))) CALL fm_dp2m(123.4D0,mfm4) CALL fm_sub(mfm3,mfm4,mfm4) CALL fm_div(mfm4,mfm3,mfm4) CALL fm_abs(mfm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 521 mfm3 = to_fm(mfm1) CALL fm_eq(mfm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 522 mfm3 = to_fm(mim1) CALL im_i2fm(mim1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 523 mfm3 = to_fm(mzm1) CALL zm_real(mzm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 524 mfm3 = to_fm('-123.654') CALL fm_st2m('-123.654',mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 525 mim3 = to_im(123) CALL im_i2m(123,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 526 mim3 = to_im(123.4) CALL fm_sp2m(123.4,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 527 mim3 = to_im(123.45D0) CALL fm_dp2m(123.45D0,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 528 mim3 = to_im(cmplx(123.4,567.8)) CALL fm_sp2m(123.4,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 529 mim3 = to_im(cmplx(123.4D0,567.8D0,kind(1.0D0))) CALL fm_dp2m(123.4D0,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 530 mim3 = to_im(mfm1) CALL fm_eq(mfm1,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 531 mim3 = to_im(mim1) CALL im_i2fm(mim1,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 532 mim3 = to_im(mzm1) CALL zm_real(mzm1,mfm4) CALL im_fm2i(mfm4,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 533 mim3 = to_im('-123654') CALL im_st2m('-123654',mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 534 mzm3 = to_zm(123) CALL zm_i2m(123,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 535 mzm3 = to_zm(123.4) CALL fm_sp2m(123.4,mfm4) CALL fm_i2m(0,mfm5) CALL zm_cmpx(mfm4,mfm5,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 536 mzm3 = to_zm(123.45D0) CALL fm_dp2m(123.45D0,mfm4) CALL fm_i2m(0,mfm5) CALL zm_cmpx(mfm4,mfm5,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = dsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 537 mzm3 = to_zm(cmplx(123.4,567.8)) CALL fm_sp2m(123.4,mfm4) CALL fm_sp2m(567.8,mfm5) CALL zm_cmpx(mfm4,mfm5,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = rsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 538 mzm3 = to_zm(cmplx(123.4D0,567.8D0,kind(1.0D0))) CALL fm_dp2m(123.4D0,mfm4) CALL fm_dp2m(567.8D0,mfm5) CALL zm_cmpx(mfm4,mfm5,mzm4) CALL zm_sub(mzm3,mzm4,mzm4) CALL zm_div(mzm4,mzm3,mzm4) CALL zm_abs(mzm4,mfm4) mfm3 = dsmall IF (fm_comp(mfm4,'gt',mfm3)) CALL prterr(kw,klog,ncase,nerror) ncase = 539 mzm3 = to_zm(mfm1) CALL fm_eq(mfm1,mfm4) CALL fm_i2m(0,mfm5) CALL zm_cmpx(mfm4,mfm5,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 540 mzm3 = to_zm(mim1) CALL im_i2fm(mim1,mfm4) CALL fm_i2m(0,mfm5) CALL zm_cmpx(mfm4,mfm5,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 541 mzm3 = to_zm(mzm1) CALL zm_eq(mzm1,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 542 mzm3 = to_zm('-123.654 + 98.7 i') CALL zm_st2m('-123.654 + 98.7 i',mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 543 CALL fm_m2i(mfm1,i2) IF (to_int(mfm1)/=i2) CALL prterr(kw,klog,ncase,nerror) ncase = 544 CALL im_m2i(mim1,i2) IF (to_int(mim1)/=i2) CALL prterr(kw,klog,ncase,nerror) ncase = 545 CALL zm_m2i(mzm1,i2) IF (to_int(mzm1)/=i2) CALL prterr(kw,klog,ncase,nerror) ncase = 546 CALL fm_m2sp(mfm1,r2) IF (abs((to_sp(mfm1)-r2)/r2)>rsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 547 CALL im_m2dp(mim1,d2) r2 = d2 IF (abs((to_sp(mim1)-r2)/r2)>rsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 548 CALL zm_real(mzm1,mfm4) CALL fm_m2sp(mfm4,r2) IF (abs((to_sp(mzm1)-r2)/r2)>rsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 549 CALL fm_m2dp(mfm1,d2) IF (abs((to_dp(mfm1)-d2)/d2)>dsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 550 CALL im_m2dp(mim1,d2) IF (abs((to_dp(mim1)-d2)/d2)>dsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 551 CALL zm_real(mzm1,mfm4) CALL fm_m2dp(mfm4,d2) IF (abs((to_dp(mzm1)-d2)/d2)>dsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 552 CALL fm_m2sp(mfm1,r2) z2 = r2 IF (abs((to_spz(mfm1)-z2)/z2)>rsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 553 CALL im_m2dp(mim1,d2) z2 = d2 IF (abs((to_spz(mim1)-z2)/z2)>rsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 554 CALL zm_m2z(mzm1,z2) IF (abs((to_spz(mzm1)-z2)/z2)>rsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 555 CALL fm_m2dp(mfm1,d2) c2 = d2 IF (abs((to_dpz(mfm1)-c2)/c2)>dsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 556 CALL im_m2dp(mim1,d2) c2 = d2 IF (abs((to_dpz(mim1)-c2)/c2)>dsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF ncase = 557 CALL zm_real(mzm1,mfm4) CALL fm_m2dp(mfm4,d2) CALL zm_imag(mzm1,mfm4) CALL fm_m2dp(mfm4,d3) c2 = cmplx(d2,d3,kind(0.0D0)) IF (abs((to_dpz(mzm1)-c2)/c2)>dsmall) THEN CALL prterr(kw,klog,ncase,nerror) ENDIF END SUBROUTINE test18 SUBROUTINE test19(i1,r1,d1,z1,c1,mfm1,mfm3,mfm4,mim1,mim3,mim4,mzm1,mzm3, & mzm4,nerror,ncase,klog) ! Test the derived-type interface routines that are not ! used elsewhere in this program. ! .. Use Statements .. USE fmzm ! .. ! .. Intrinsic Functions .. ! INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm) :: mfm1, mfm3, mfm4 TYPE (im) :: mim1, mim3, mim4 TYPE (zm) :: mzm1, mzm3, mzm4 ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)) :: c1 COMPLEX :: z1 REAL (KIND(0.0D0)) :: d1 REAL :: r1 INTEGER :: i1, klog, ncase, nerror ! .. ! .. Local Structures .. TYPE (im) :: mim2 TYPE (fm) :: msmall ! .. ! .. Local Scalars .. COMPLEX :: z3, z4 REAL (KIND(0.0D0)) :: d3, d4, dsmall REAL :: r3, r4, rsmall INTEGER :: i3, i4 CHARACTER (80) :: string ! .. ! .. External Subroutines .. EXTERNAL prterr ! .. rsmall = epsilon(1.0)*100.0 dsmall = epsilon(1.0D0)*100.0 msmall = epsilon(to_fm(1))*10000.0 ncase = 558 mfm3 = mfm1 + 123 mfm4 = mfm1 CALL fm_addi(mfm4,123) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 559 CALL fm_chsh(mfm1,mfm4,mfm3) mfm3 = cosh(mfm1) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 560 CALL fm_chsh(mfm1,mfm3,mfm4) mfm3 = sinh(mfm1) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 561 CALL fm_cssn(mfm1,mfm4,mfm3) mfm3 = cos(mfm1) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 562 CALL fm_cssn(mfm1,mfm3,mfm4) mfm3 = sin(mfm1) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 563 mfm3 = mfm1/123 CALL fm_divi(mfm1,123,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 564 mfm3 = 123.45D0 CALL fm_dpm(123.45D0,mfm4) IF (abs((mfm3-mfm4)/mfm4)>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 565 CALL fm_form('F70.56',mfm1,string) CALL fm_st2m(string(1:70),mfm4) IF (abs((mfm1-mfm4)/mfm4)>msmall) CALL prterr(kw,klog,ncase,nerror) ncase = 566 mfm3 = mfm1**123 CALL fm_ipwr(mfm1,123,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 567 mfm3 = log(to_fm(123)) CALL fm_lni(123,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 568 d3 = mfm1 CALL fm_m2dp(mfm1,d4) IF (abs((d3-d4)/d3)>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 569 i3 = mfm1 CALL fm_m2i(mfm1,i4) IF (i3/=i4) CALL prterr(kw,klog,ncase,nerror) ncase = 570 r3 = mfm1 CALL fm_m2sp(mfm1,r4) IF (abs((r3-r4)/r3)>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 571 mfm3 = 2.67 CALL fm_mod(mfm1,mfm3,mfm4) mfm3 = mod(mfm1,mfm3) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 572 CALL fm_pi(mfm4) mfm3 = 4*atan(to_fm(1)) IF (abs((mfm3-mfm4)/mfm4)>msmall) CALL prterr(kw,klog,ncase,nerror) ncase = 573 mfm3 = mfm1**(to_fm(1)/to_fm(3)) CALL fm_rpwr(mfm1,1,3,mfm4) IF (abs((mfm3-mfm4)/mfm4)>msmall) CALL prterr(kw,klog,ncase,nerror) ncase = 574 CALL fm_sqr(mfm1,mfm4) mfm3 = mfm1*mfm1 IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 575 mim3 = mim1/13 CALL im_divi(mim1,13,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 576 mim3 = 13 CALL im_divr(mim1,mim3,mim3,mim4) mim3 = mod(mim1,mim3) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 577 mim3 = 13 CALL im_divr(mim1,mim3,mim3,mim4) mim4 = mim1/13 IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 578 mim3 = mim1/13 CALL im_dvir(mim1,13,mim4,i4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 579 i3 = mod(mim1,to_im(13)) CALL im_dvir(mim1,13,mim4,i4) IF (i3/=i4) CALL prterr(kw,klog,ncase,nerror) ncase = 580 CALL im_form('I70',mim1,string) CALL im_st2m(string(1:70),mim4) IF (mim1/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 581 mim3 = 40833 mim4 = 16042 CALL im_gcd(mim3,mim4,mim4) IF (mim4/=13) CALL prterr(kw,klog,ncase,nerror) ncase = 582 d3 = mim1 CALL im_m2dp(mim1,d4) IF (abs((d3-d4)/d3)>dsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 583 i3 = mim1 CALL im_m2i(mim1,i4) IF (i3/=i4) CALL prterr(kw,klog,ncase,nerror) ncase = 584 mim3 = 6 CALL im_mod(mim1,mim3,mim4) mim3 = mod(mim1,mim3) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 585 mim3 = mim1*123 CALL im_mpyi(mim1,123,mim4) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 586 mim2 = 3141 mim3 = 133 CALL im_mpym(mim1,mim2,mim3,mim4) mim3 = mod(mim1*mim2,mim3) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 587 mim2 = 31 mim3 = 147 CALL im_pmod(mim1,mim2,mim3,mim4) mim3 = mod(mim1**mim2,mim3) IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 588 CALL im_sqr(mim1,mim4) mim3 = mim1*mim1 IF (mim3/=mim4) CALL prterr(kw,klog,ncase,nerror) ncase = 589 mzm3 = mzm1 + 123 mzm4 = mzm1 CALL zm_addi(mzm4,123) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 590 mfm3 = atan2(aimag(mzm1),real(mzm1)) CALL zm_arg(mzm1,mfm4) IF (mfm3/=mfm4) CALL prterr(kw,klog,ncase,nerror) ncase = 591 CALL zm_chsh(mzm1,mzm4,mzm3) mzm3 = cosh(mzm1) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 592 CALL zm_chsh(mzm1,mzm3,mzm4) mzm3 = sinh(mzm1) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 593 CALL zm_cssn(mzm1,mzm4,mzm3) mzm3 = cos(mzm1) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 594 CALL zm_cssn(mzm1,mzm3,mzm4) mzm3 = sin(mzm1) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 595 CALL zm_form('F35.26','F35.26',mzm1,string) CALL zm_st2m(string(1:75),mzm4) IF (abs((mzm1-mzm4)/mzm4)>msmall) CALL prterr(kw,klog,ncase,nerror) ncase = 596 mzm3 = to_zm('123-456i') CALL zm_2i2m(123,-456,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 597 mzm3 = mzm1**123 CALL zm_ipwr(mzm1,123,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 598 i3 = mzm1 CALL zm_m2i(mzm1,i4) IF (i3/=i4) CALL prterr(kw,klog,ncase,nerror) ncase = 599 z3 = mzm1 CALL zm_m2z(mzm1,z4) IF (abs((z3-z4)/z3)>rsmall) CALL prterr(kw,klog,ncase,nerror) ncase = 600 mzm3 = mzm1*123 CALL zm_mpyi(mzm1,123,mzm4) IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 601 mzm3 = mzm1**(to_zm(1)/to_zm(3)) CALL zm_rpwr(mzm1,1,3,mzm4) IF (abs((mzm3-mzm4)/mzm4)>msmall) CALL prterr(kw,klog,ncase,nerror) ncase = 602 CALL zm_sqr(mzm1,mzm4) mzm3 = mzm1*mzm1 IF (mzm3/=mzm4) CALL prterr(kw,klog,ncase,nerror) ncase = 603 mzm3 = z1 CALL zm_z2m(z1,mzm4) IF (abs((mzm3-mzm4)/mzm3)>rsmall) CALL prterr(kw,klog,ncase,nerror) END SUBROUTINE test19 SUBROUTINE prterr(kw,klog,ncase,nerror) ! .. Scalar Arguments .. INTEGER :: klog, kw, ncase, nerror ! .. WRITE (kw,*) ' Error in case ', ncase WRITE (klog,*) ' Error in case ', ncase nerror = nerror + 1 END SUBROUTINE prterr SHAR_EOF fi # end of overwriting check if test -f 'driver6.f90' then echo shar: will not over-write existing file "'driver6.f90'" else cat << SHAR_EOF > 'driver6.f90' PROGRAM test90 ! David M. Smith 9-17-96 ! Program using the FM Fortran-90 modules for doing ! arithmetic using the FM, IM, and ZM derived types. ! This program does the same calculations as FMSAMPLE and ZMSAMPLE. ! The output is saved in file SAMPLE90.LOG. A comparison file, ! SAMPLE90.CHK, is provided showing the expected output from 32-bit ! (IEEE arithmetic) machines. When run on other computers, all the ! numerical results should still be the same, but the number of terms ! needed for some of the results might be slightly different. The ! program checks all the results and the last line of the log file ! should be "All results were ok." ! In a few places, an explicit call is made to an FM or ZM routine. ! For a call like CALL FM_FORM('F65.60',MAFM,ST1), note that the ! "FM_" form is used since MAFM is a TYPE (FM) variable and not just ! an array. See the discussion in FMZM90.f90. ! .. Use Statements .. USE fmzm ! .. ! .. Local Structures .. TYPE (fm) :: mafm, mbfm, mcfm, mdfm TYPE (im) :: maim, mbim, mcim TYPE (zm) :: mazm, mbzm, mczm, mdzm ! .. ! .. Local Scalars .. INTEGER :: iter, j, k, klog, nerror ! Character string used to format multiple-precision output. CHARACTER (80) :: st1 ! .. ! Note that any program using the FM package MUST call ! FM_SET before using the package. ! Since the argument to FM_SET is not an FM number, ! calling FMSET would have the same effect. The "FM_" ! version is available so that all calls in a program ! using the derived types can have the "FM_" form. ! Later in this program complex arithmetic is be used, ! and ZM_SET is called there to initialize the ZM package. ! Set precision to give at least 60 significant digits ! and initialize the FMLIB package. CALL fm_set(60) nerror = 0 ! Write output to the standard FM output (unit KW, defined ! in subroutine FMSET), and also to the file SAMPLE90.LOG. klog = 18 OPEN (klog,file='SAMPLE90.LOG') ! 1. Find a root of the equation ! f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0. ! Use Newton's method with initial guess x = 3.12. ! This version is not tuned for speed. See the FMSQRT ! routine for possible ways to increase speed. ! Horner's rule is used to evaluate the function. ! MAFM is the previous iterate. ! MBFM is the current iterate. ! TO_FM is a function for converting other types of numbers ! to type FM. Note that TO_FM(3.12) converts the REAL ! constant to FM, but it is accurate only to single ! precision. TO_FM(3.12D0) agrees with 3.12 to double ! precision accuracy, and TO_FM('3.12') or ! TO_FM(312)/TO_FM(100) agrees to full FM accuracy. mafm = to_fm('3.12') ! Print the first iteration. WRITE (kw,90000) WRITE (klog,90000) CALL fm_form('F65.60',mafm,st1) WRITE (kw,90010) 0, st1(1:65) WRITE (klog,90010) 0, st1(1:65) DO iter = 1, 10 ! MCFM is f(MAFM). mcfm = ((((mafm-3)*mafm+1)*mafm-4)*mafm+1)*mafm - 6 ! MDFM is f'(MAFM). mdfm = (((5*mafm-12)*mafm+3)*mafm-8)*mafm + 1 mbfm = mafm - mcfm/mdfm ! Print each iteration. CALL fm_form('F65.60',mbfm,st1) WRITE (kw,90010) iter, st1(1:65) WRITE (klog,90010) iter, st1(1:65) ! Stop iterating if MAFM and MBFM agree to over ! 60 places. mdfm = abs(mafm-mbfm) IF (mdfm<1.0D-61) EXIT ! Set MAFM = MBFM for the next iteration. mafm = mbfm END DO ! Check the answer. mcfm = to_fm('3.120656215326726500470956013523797484654623'// & '9355990660149888284358') IF (abs(mcfm-mbfm)>1.0D-61) THEN nerror = nerror + 1 WRITE (kw,90020) WRITE (klog,90020) END IF ! 2. Compute the Riemann Zeta function for s=3. ! Use Gosper's formula: Zeta(3) = ! (5/4)*Sum[ (-1)**k * (k!)**2 / ((k+1)**2 * (2k+1)!) ] ! while k = 0, 1, .... ! MAFM is the current partial sum. ! MBFM is the current term. ! MCFM is k! ! MDFM is (2k+1)! mafm = 1 mcfm = 1 mdfm = 1 DO k = 1, 200 mcfm = k*mcfm j = 2*k*(2*k+1) mdfm = j*mdfm mbfm = mcfm**2 j = (k+1)*(k+1) mbfm = (mbfm/j)/mdfm IF (mod(k,2)==0) THEN mafm = mafm + mbfm ELSE mafm = mafm - mbfm END IF ! Test for convergence. IF (mafm-mbfm==mafm) THEN WRITE (kw,90030) k WRITE (klog,90030) k EXIT END IF END DO ! Print the result. mafm = (5*mafm)/4 CALL fm_form('F65.60',mafm,st1) WRITE (kw,90040) st1(1:65) WRITE (klog,90040) st1(1:65) ! Check the answer. mcfm = to_fm('1.20205690315959428539973816151144999076498'// & '6292340498881792271555') IF (abs(mafm-mcfm)>1.0D-61) THEN nerror = nerror + 1 WRITE (kw,90050) WRITE (klog,90050) END IF ! 3. Integer multiple precision calculations. ! Fermat's theorem says x**(p-1) mod p = 1 ! when p is prime and x is not a multiple of p. ! If x**(p-1) mod p gives 1 for some p with ! several different x's, then it is very likely ! that p is prime (but it is not certain until ! further tests are done). ! Find a 70-digit number p that is "probably" prime. ! MAIM is the value p being tested. maim = to_im(10)**69 ! To speed up the search, test only values that are ! not multiples of 2, 3, 5, 7, 11, 13. k = 2*3*5*7*11*13 maim = (maim/k)*k + k + 1 mcim = 3 DO j = 1, 100 ! Compute 3**(p-1) mod p mbim = maim - 1 CALL im_pmod(mcim,mbim,maim,mcim) IF (mcim==1) THEN ! Check that 7**(p-1) mod p is also 1. mcim = 7 CALL im_pmod(mcim,mbim,maim,mcim) IF (mcim==1) THEN WRITE (kw,90060) j WRITE (klog,90060) j EXIT END IF END IF mcim = 3 maim = maim + k END DO ! Print the result. CALL im_form('I72',maim,st1) WRITE (kw,90070) st1(1:72) WRITE (klog,90070) st1(1:72) ! Check the answer. mcim = to_im('1000000000000000000000000000000000000000000'// & '000000000000000000000659661') IF (maim/=mcim) THEN nerror = nerror + 1 WRITE (kw,90080) WRITE (klog,90080) END IF ! Complex arithmetic. ! Set precision to give at least 30 significant digits ! and initialize the ZMLIB package. Both FM and ZM ! operations will now have this precision. ! Note that any program using the ZM package MUST call ! ZM_SET before using the package. CALL zm_set(30) ! 4. Find a complex root of the equation ! f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0. ! Newton's method with initial guess x = .56 + 1.06 i. ! This version is not tuned for speed. See the ZMSQRT ! routine for possible ways to increase speed. ! Horner's rule is used to evaluate the function. ! MAZM is the previous iterate. ! MBZM is the current iterate. mazm = to_zm('.56 + 1.06 i') ! Print the first iteration. WRITE (kw,90090) WRITE (klog,90090) CALL zm_form('F32.30','F32.30',mazm,st1) WRITE (kw,90100) 0, st1(1:69) WRITE (klog,90100) 0, st1(1:69) DO iter = 1, 10 ! MCZM is f(MAZM). mczm = ((((mazm-3)*mazm+1)*mazm-4)*mazm+1)*mazm - 6 ! MDZM is f'(MAZM). mdzm = (((5*mazm-12)*mazm+3)*mazm-8)*mazm + 1 mbzm = mazm - mczm/mdzm ! Print each iteration. CALL zm_form('F32.30','F32.30',mbzm,st1) WRITE (kw,90100) iter, st1(1:69) WRITE (klog,90100) iter, st1(1:69) ! Stop iterating if MAZM and MBZM agree to over ! 30 places. IF (abs(mazm-mbzm)<1.0D-31) EXIT ! Set MAZM = MBZM for the next iteration. mazm = mbzm END DO ! Check the answer. mczm = to_zm('0.561958308335403235498111195347453 +'// & '1.061134679604332556983391239058885 i') IF (abs(mczm-mbzm)>1.0D-31) THEN nerror = nerror + 1 WRITE (kw,90110) WRITE (klog,90110) END IF ! 5. Compute Exp(1.23-2.34i). ! Use the direct Taylor series. See the ZMEXP routine ! for a faster way to get Exp(x). ! MAZM is x. ! MBZM is the current term, x**n/n!. ! MCZM is the current partial sum. mazm = to_zm('1.23-2.34i') mbzm = 1 mczm = 1 DO k = 1, 100 mbzm = mbzm*mazm/k mdzm = mczm + mbzm ! Test for convergence. IF (mdzm==mczm) THEN WRITE (kw,90120) k WRITE (klog,90120) k EXIT END IF mczm = mdzm END DO ! Print the result. CALL zm_form('F33.30','F32.30',mczm,st1) WRITE (kw,90130) st1(1:70) WRITE (klog,90130) st1(1:70) ! Check the answer. mdzm = to_zm('-2.379681796854777515745457977696745 -'// & ' 2.458032970832342652397461908326042 i') IF (abs(mdzm-mczm)>1.0D-31) THEN nerror = nerror + 1 WRITE (kw,90140) WRITE (klog,90140) END IF IF (nerror==0) THEN WRITE (kw,90150) ' All results were ok.' WRITE (klog,90150) ' All results were ok.' END IF 90000 FORMAT (//' Sample 1. Real root of f(x) = x**5 - 3x**4 + ', & 'x**3 - 4x**2 + x - 6 = 0.'///' Iteration Newton Approximation') 90010 FORMAT (/I10,4X,A) 90020 FORMAT (/' Error in sample case number 1.'/) 90030 FORMAT (///' Sample 2.',8X,I5,' terms were added'/) 90040 FORMAT (' Zeta(3) = ',A) 90050 FORMAT (/' Error in sample case number 2.'/) 90060 FORMAT (///' Sample 3.',8X,I5,' values were tested'/) 90070 FORMAT (' p = ',A) 90080 FORMAT (/' Error in sample case number 3.'/) 90090 FORMAT (//' Sample 4. Complex root of f(x) = x**5 - 3x**4 + ', & 'x**3 - 4x**2 + x - 6 = 0.'///' Iteration Newton Approximation') 90100 FORMAT (/I6,4X,A) 90110 FORMAT (/' Error in sample case number 4.'/) 90120 FORMAT (///' Sample 5.',8X,I5,' terms were added ', & 'to get Exp(1.23-2.34i)'/) 90130 FORMAT (' Result= ',A) 90140 FORMAT (/' Error in sample case number 5.'/) 90150 FORMAT (//A/) END PROGRAM test90 SHAR_EOF fi # end of overwriting check cd .. cd .. if test ! -d 'Src' then mkdir 'Src' fi cd 'Src' if test ! -d 'Dp' then mkdir 'Dp' fi cd 'Dp' if test -f 'fmlib.f90' then echo shar: will not over-write existing file "'fmlib.f90'" else cat << SHAR_EOF > 'fmlib.f90' ! FM 1.1 David M. Smith 5-19-97 ! The FM routines in this package perform floating-point ! multiple-precision arithmetic, and the IM routines perform ! integer multiple-precision arithmetic. ! 1. INITIALIZING THE PACKAGE ! Before calling any routine in the package, several variables in ! the common blocks /FMUSER/, /FM/, /FMBUFF/, and /FMSAVE/ must be ! initialized. These four common blocks contain information that ! is saved between calls, so they should be declared in the main ! program. ! Subroutine FMSET initializes these variables to default values and ! defines all machine-dependent values in the package. After calling ! FMSET once at the start of a program, the user may sometimes want ! to reset some of the variables in these common blocks. These ! variables are described below. ! 2. REPRESENTATION OF FM NUMBERS ! MBASE is the base in which the arithmetic is done. MBASE must be ! bigger than one, and less than or equal to the square root of ! the largest representable integer. For best efficiency MBASE ! should be large, but no more than about 1/4 of the square root ! of the largest representable integer. Input and output ! conversions are much faster when MBASE is a power of ten. ! NDIG is the number of base MBASE digits that are carried in the ! multiple precision numbers. NDIG must be at least two. The ! upper limit for NDIG is defined in the PARAMETER statement at ! the top of each routine and is restricted only by the amount ! of memory available. ! Sometimes it is useful to dynamically vary NDIG during the program. ! Use FMEQU to round numbers to lower precision or zero-pad them to ! higher precision when changing NDIG. ! It is rare to need to change MBASE during a program. Use FMCONS to ! reset some saved constants that depend on MBASE. FMCONS should be ! called immediately after changing MBASE. ! There are two representations for a floating multiple precision ! number. The unpacked representation used by the routines while ! doing the computations is base MBASE and is stored in NDIG+2 words. ! A packed representation is available to store the numbers in the ! user's program in compressed form. In this format, the NDIG ! (base MBASE) digits of the mantissa are packed two per word to ! conserve storage. Thus the external, packed form of a number ! requires (NDIG+1)/2+2 words. ! This version uses double precision arrays to hold the numbers. ! Version 1.0 of FM used integer arrays, which are faster on some ! machines. The package can easily be changed to use integer ! arrays -- see section 11 on EFFICIENCY below. ! The unpacked format of a floating multiple precision number is as ! follows. A number MA is kept in an array with MA(1) containing ! the exponent and MA(2) through MA(NDIG+1) containing one digit of ! the mantissa, expressed in base MBASE. The array is dimensioned ! to start at MA(0), with the approximate number of bits of precision ! stored in MA(0). This precision value is intended to be used by FM ! functions that need to monitor cancellation error in addition and ! subtraction. The cancellation monitor code is usually disabled for ! user calls, and FM functions only check for cancellation when they ! must. Tracking cancellation causes most routines to run slower, ! with addition and subtraction being affected the most. ! The exponent is a power of MBASE and the implied radix point is ! immediately before the first digit of the mantissa. Every nonzero ! number is normalized so that the second array element (the first ! digit of the mantissa) is nonzero. ! In both representations the sign of the number is carried on the ! second array element only. Elements 3,4,... are always nonnegative. ! The exponent is a signed integer and may be as large in magnitude as ! MXEXP (defined in FMSET). ! For MBASE = 10,000 and NDIG = 4, the number -pi would have these ! representations: ! Word 1 2 3 4 5 ! Unpacked: 1 -3 1415 9265 3590 ! Packed: 1 -31415 92653590 ! Word 0 would be 42 in both formats, indicating that the mantissa ! has about 42 bits of precision. ! Because of normalization in a large base, the equivalent number ! of base 10 significant digits for an FM number may be as small as ! LOG10(MBASE)*(NDIG-1) + 1. ! The integer routines use the FMLIB format to represent numbers, ! without the number of digits (NDIG) being fixed. Integers in IM ! format are essentially variable precision, using the minimum number ! of words to represent each value. ! For programs using both FM and IM numbers, FM routines should not ! be called with IM numbers, and IM routines should not be called ! with FM numbers, since the implied value of NDIG used for an IM ! number may not match the explicit NDIG expected by an FM routine. ! Use the conversion routines IMFM2I and IMI2FM to change between ! the FM and IM formats. ! 3. INPUT/OUTPUT ROUTINES ! All versions of the input routines perform free-format conversion ! from characters to FM numbers. ! a. Conversion to or from a character array ! FMINP converts from a character*1 array to an FM number. ! FMOUT converts an FM number to base 10 and formats it for output ! as an array of type character*1. The output is left ! justified in the array, and the format is defined by two ! variables in common, so that a separate format definition ! does not have to be provided for each output call. ! The user sets JFORM1 and JFORM2 to determine the output format. ! JFORM1 = 0 E format ( .314159M+6 ) ! = 1 1PE format ( 3.14159M+5 ) ! = 2 F format ( 314159.000 ) ! JFORM2 is the number of significant digits to display (if ! JFORM1 = 0 or 1). If JFORM2.EQ.0 then a default number ! of digits is chosen. The default is roughly the full ! precision of the number. ! JFORM2 is the number of digits after the decimal point (if ! JFORM1 = 2). See the FMOUT documentation for more details. ! b. Conversion to or from a character string ! FMST2M converts from a character string to an FM number. ! FMFORM converts an FM number to a character string according to ! a format provided in each call. The format description ! is more like that of a Fortran FORMAT statement, and ! integer or fixed-point output is right justified. ! c. Direct read or write ! FMPRNT uses FMOUT to print one FM number. ! FMFPRT uses FMFORM to print one FM number. ! FMWRIT writes FM numbers for later input using FMREAD. ! FMREAD reads FM numbers written by FMWRIT. ! The values given to JFORM1 and JFORM2 can be used to define a ! default output format when FMOUT or FMPRNT are called. The ! explicit format used in a call to FMFORM or FMFPRT overrides ! the settings of JFORM1 and JFORM2. ! KW is the unit number to be used for standard output from ! the package, including error and warning messages, and ! trace output. ! For multiple precision integers, the corresponding routines ! IMINP, IMOUT, IMST2M, IMFORM, IMPRNT, IMFPRT, IMWRIT, and ! IMREAD provide similar input and output conversions. For ! output of IM numbers, JFORM1 and JFORM2 are ignored and ! integer format (JFORM1=2, JFORM2=0) is used. ! For further description of these routines, see sections ! 9 and 10 below. ! 4. ARITHMETIC TRACING ! NTRACE and LVLTRC control trace printout from the package. ! NTRACE = 0 No printout except warnings and errors. ! = 1 The result of each call to one of the routines ! is printed in base 10, using FMOUT. ! = -1 The result of each call to one of the routines ! is printed in internal base MBASE format. ! = 2 The input arguments and result of each call to one ! of the routines is printed in base 10, using FMOUT. ! = -2 The input arguments and result of each call to one ! of the routines is printed in base MBASE format. ! LVLTRC defines the call level to which the trace is done. LVLTRC = 1 ! means only FM routines called directly by the user are traced, ! LVLTRC = 2 also prints traces for FM routines called by other ! FM routines called directly by the user, etc. ! In the above description, internal MBASE format means the number is ! printed as it appears in the array --- an exponent followed by NDIG ! base MBASE digits. ! 5. ERROR CONDITIONS ! KFLAG is a condition parameter returned by the package after each ! call to one of the routines. Negative values indicate ! conditions for which a warning message will be printed ! unless KWARN = 0. Positive values indicate conditions ! that may be of interest but are not errors. ! No warning message is printed if KFLAG is nonnegative. ! KFLAG = 0 Normal operation. ! = 1 One of the operands in FMADD or FMSUB was ! insignificant with respect to the other, so ! that the result was equal to the argument of ! larger magnitude. ! = 2 In converting an FM number to a one word integer ! in FMM2I, the FM number was not exactly an ! integer. The next integer toward zero was ! returned. ! = -1 NDIG was less than 2 or more than NDIGMX. ! = -2 MBASE was less than 2 or more than MXBASE. ! = -3 An exponent was out of range. ! = -4 Invalid input argument(s) to an FM routine. ! UNKNOWN was returned. ! = -5 + or - OVERFLOW was generated as a result from an ! FM routine. ! = -6 + or - UNDERFLOW was generated as a result from an ! FM routine. ! = -7 The input string (array) to FMINP was not legal. ! = -8 The character array was not large enough in an ! input or output routine. ! = -9 Precision could not be raised enough to provide all ! requested guard digits. Increasing NDIGMX in ! all the PARAMETER statements may fix this. ! UNKNOWN was returned. ! = -10 An FM input argument was too small in magnitude to ! convert to the machine's single or double ! precision in FMM2SP or FMM2DP. Check that the ! definitions of SPMAX and DPMAX in FMSET are ! correct for the current machine. ! Zero was returned. ! When a negative KFLAG condition is encountered, the value of KWARN ! determines the action to be taken. ! KWARN = 0 Execution continues and no message is printed. ! = 1 A warning message is printed and execution continues. ! = 2 A warning message is printed and execution stops. ! The default setting is KWARN = 1. ! When an overflow or underflow is generated for an operation in which ! an input argument was already an overflow or underflow, no additional ! message is printed. When an unknown result is generated and an input ! argument was already unknown, no additional message is printed. In ! these cases the negative KFLAG value is still returned. ! IM routines handle exceptions like OVERFLOW or UNKNOWN in the same ! way as FM routines. When using IMMPY, the product of two large ! positive integers will return +OVERFLOW. The routine IMMPYM can ! be used to obtain a modular result without overflow. The largest ! representable IM integer is MBASE**NDIGMX - 1. For example, if ! MBASE is 10**7 and NDIGMX is set to 256, integers less than 10**1792 ! can be used. ! 6. OTHER PARAMETERS ! KRAD = 0 All angles in the trigonometric functions and ! inverse functions are measured in degrees. ! = 1 All angles are measured in radians. (Default) ! KROUND = 0 All final results are chopped (rounded toward ! zero). Intermediate results are rounded. ! = 1 All results are rounded to the nearest FM ! number, or to the value with an even last ! digit if the result is halfway between two ! FM numbers. (Default) ! KSWIDE defines the maximum screen width to be used for ! all unit KW output. Default is 80. ! KESWCH controls the action taken in FMINP and other input routines ! for strings like 'E7' that have no digits before the exponent ! field. Default is for 'E7' to translate like '1.0E+7'. ! CMCHAR defines the exponent letter to be used for FM variable ! output. Default is 'M', as in 1.2345M+678. ! KDEBUG = 0 Error checking is not done for valid input arguments ! and parameters like NDIG and MBASE upon entry to ! each routine. (Default) ! = 1 Some error checking is done. (Slower speed) ! See FMSET for additional description of these and other variables ! defining various FM conditions. ! 7. ARRAY DIMENSIONS ! The dimensions of the arrays in the FM package are defined using ! a PARAMETER statement at the top of each routine. The size of ! these arrays depends on the values of parameters NDIGMX and NBITS. ! NDIGMX is the maximum value the user may set for NDIG. ! NBITS is the number of bits used to represent integers for a ! given machine. See the EFFICIENCY discussion below. ! The standard version of FMLIB sets NDIGMX = 256, so on a 32-bit ! machine using MBASE = 10**7 the maximum precision is about ! 7*255+1 = 1786 significant digits. To change dimensions so that ! 10,000 significant digit calculation can be done, NDIGMX needs to ! be at least 10**4/7 + 5 = 1434. This allows for a few user guard ! digits to be defined when the package is initialized using ! CALL FMSET(10000). Changing 'NDIGMX = 256' to 'NDIGMX = 1434' ! everywhere in the package and the user's calling program will ! define all the new array sizes. ! If NDIG much greater than 256 is to be used and elementary functions ! will be needed, they will be faster if array MJSUMS is larger. The ! parameter defining the size of MJSUMS is set in the standard version ! by LJSUMS = 8*(LUNPCK+2). The 8 means that up to eight concurrent ! sums can be used by the elementary functions. The approximate number ! needed for best speed is given by the formula ! 0.051*Log(MBASE)*NDIG**(1/3) + 1.85 ! For example, with MBASE=10**7 and NDIG=1434 this gives 11. Changing ! 'LJSUMS = 8*(LUNPCK+2)' to 'LJSUMS =11*(LUNPCK+2)' everywhere in the ! package and the user's calling program will give slightly better ! speed. ! FM numbers in packed format have dimension 0:LPACK, and those ! in unpacked format have dimension 0:LUNPCK. ! 8. PORTABILITY ! In FMSET there is some machine-dependent code that attempts to ! approximate the largest representable integer value. The current ! code works on all machines tested, but if an FM run fails, check ! the MAXINT and INTMAX loops in FMSET. Values for SPMAX and DPMAX ! are also defined in FMSET that should be set to values near overflow ! for single precision and double precision. Setting KDEBUG = 1 may ! also identify some errors if a run fails. ! Some compilers object to a function like FMCOMP with side effects ! such as changing KFLAG or other common variables. Blocks of code ! in FMCOMP and IMCOMP that modify common are identified so they may ! be removed or commented out to produce a function without side ! effects. This disables trace printing in FMCOMP and IMCOMP, and ! error codes are not returned in KFLAG. See FMCOMP and IMCOMP for ! further details. ! 9. LIST OF ROUTINES ! These are the FM routines that are designed to be called by ! the user. All are subroutines except logical function FMCOMP. ! MA, MB, MC refer to FM format numbers. ! In each case it is permissible to use the same array more than ! once in the calling sequence. The statement MA = MA*MA can ! be written CALL FMMPY(MA,MA,MA). ! For each of these routines there is also a version available for ! which the argument list is the same but all FM numbers are in packed ! format. The routines using packed numbers have the same names except ! 'FM' is replaced by 'FP' at the start of each name. ! FMABS(MA,MB) MB = ABS(MA) ! FMACOS(MA,MB) MB = ACOS(MA) ! FMADD(MA,MB,MC) MC = MA + MB ! FMADDI(MA,IVAL) MA = MA + IVAL Increment an FM number by a one ! word integer. Note this call ! does not have an "MB" result ! like FMDIVI and FMMPYI. ! FMASIN(MA,MB) MB = ASIN(MA) ! FMATAN(MA,MB) MB = ATAN(MA) ! FMATN2(MA,MB,MC) MC = ATAN2(MA,MB) ! FMBIG(MA) MA = Biggest FM number less than overflow. ! FMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA). Faster than ! making two separate calls. ! FMCOMP(MA,LREL,MB) Logical comparison of MA and MB. ! LREL is a CHARACTER*2 value identifying ! which comparison is made. ! Example: IF (FMCOMP(MA,'GE',MB)) ... ! FMCONS Set several saved constants that depend ! on MBASE, the base being used. FMCONS ! should be called immediately after ! changing MBASE. ! FMCOS(MA,MB) MB = COS(MA) ! FMCOSH(MA,MB) MB = COSH(MA) ! FMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA). Faster than ! making two separate calls. ! FMDIG(NSTACK,KST) Find a set of precisions to use during ! Newton iteration for finding a simple ! root starting with about double ! precision accuracy. ! FMDIM(MA,MB,MC) MC = DIM(MA,MB) ! FMDIV(MA,MB,MC) MC = MA/MB ! FMDIVI(MA,IVAL,MB) MB = MA/IVAL IVAL is a one word integer. ! FMDP2M(X,MA) MA = X Convert from double precision to FM. ! FMDPM(X,MA) MA = X Convert from double precision to FM. ! Much faster than FMDP2M, but MA agrees ! with X only to D.P. accuracy. See ! the comments in the two routines. ! FMEQ(MA,MB) MB = MA Both have precision NDIG. ! This is the version to use for ! standard B = A statements. ! FMEQU(MA,MB,NA,NB) MB = MA Version for changing precision. ! MA has NA digits (i.e., MA was ! computed using NDIG = NA), and MB ! will be defined having NB digits. ! MB is zero-padded if NB.GT.NA ! MB is rounded if NB.LT.NA ! FMEXP(MA,MB) MB = EXP(MA) ! FMFORM(FORM,MA,STRING) MA is converted to a character string ! using format FORM and returned in ! STRING. FORM can represent I, F, ! E, or 1PE formats. Example: ! CALL FMFORM('F60.40',MA,STRING) ! FMFPRT(FORM,MA) Print MA on unit KW using FORM format. ! FMI2M(IVAL,MA) MA = IVAL Convert from one word integer ! to FM. ! FMINP(LINE,MA,LA,LB) MA = LINE Input conversion. ! Convert LINE(LA) through LINE(LB) ! from characters to FM. ! FMINT(MA,MB) MB = INT(MA) Integer part of MA. ! FMIPWR(MA,IVAL,MB) MB = MA**IVAL Raise an FM number to a one ! word integer power. ! FMLG10(MA,MB) MB = LOG10(MA) ! FMLN(MA,MB) MB = LOG(MA) ! FMLNI(IVAL,MA) MA = LOG(IVAL) Natural log of a one word ! integer. ! FMM2DP(MA,X) X = MA Convert from FM to double precision. ! FMM2I(MA,IVAL) IVAL = MA Convert from FM to integer. ! FMM2SP(MA,X) X = MA Convert from FM to single precision. ! FMMAX(MA,MB,MC) MC = MAX(MA,MB) ! FMMIN(MA,MB,MC) MC = MIN(MA,MB) ! FMMOD(MA,MB,MC) MC = MA mod MB ! FMMPY(MA,MB,MC) MC = MA*MB ! FMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer. ! FMNINT(MA,MB) MB = NINT(MA) Nearest FM integer. ! FMOUT(MA,LINE,LB) LINE = MA Convert from FM to character. ! LINE is a character array of ! length LB. ! FMPI(MA) MA = pi ! FMPRNT(MA) Print MA on unit KW using current format. ! FMPWR(MA,MB,MC) MC = MA**MB ! FMREAD(KREAD,MA) MA is returned after reading one (possibly ! multi-line) FM number on unit KREAD. This ! routine reads numbers written by FMWRIT. ! FMRPWR(MA,K,J,MB) MB = MA**(K/J) Rational power. Faster than ! FMPWR for functions like the cube root. ! FMSET(NPREC) Set default values and machine-dependent ! variables to give at least NPREC base 10 ! digits plus three base 10 guard digits. ! Must be called to initialize FM package. ! FMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer. ! FMSIN(MA,MB) MB = SIN(MA) ! FMSINH(MA,MB) MB = SINH(MA) ! FMSP2M(X,MA) MA = X Convert from single precision to FM. ! FMSQR(MA,MB) MB = MA*MA Faster than FMMPY. ! FMSQRT(MA,MB) MB = SQRT(MA) ! FMST2M(STRING,MA) MA = STRING ! Convert from character string to FM. ! Often more convenient than FMINP, which ! converts an array of CHARACTER*1 values. ! Example: CALL FMST2M('123.4',MA). ! FMSUB(MA,MB,MC) MC = MA - MB ! FMTAN(MA,MB) MB = TAN(MA) ! FMTANH(MA,MB) MB = TANH(MA) ! FMULP(MA,MB) MB = One Unit in the Last Place of MA. ! FMWRIT(KWRITE,MA) Write MA on unit KWRITE. ! Multi-line numbers will have '&' as the ! last nonblank character on all but the last ! line. These numbers can then be read ! easily using FMREAD. ! These are the integer routines that are designed to be called by ! the user. All are subroutines except logical function IMCOMP. ! MA, MB, MC refer to IM format numbers. In each case the version ! of the routine to handle packed IM numbers has the same name, ! with 'IM' replaced by 'IP'. ! IMABS(MA,MB) MB = ABS(MA) ! IMADD(MA,MB,MC) MC = MA + MB ! IMBIG(MA) MA = Biggest IM number less than overflow. ! IMCOMP(MA,LREL,MB) Logical comparison of MA and MB. ! LREL is a CHARACTER*2 value identifying ! which comparison is made. ! Example: IF (IMCOMP(MA,'GE',MB)) ... ! IMDIM(MA,MB,MC) MC = DIM(MA,MB) ! IMDIV(MA,MB,MC) MC = int(MA/MB) ! Use IMDIVR if the remainder is also needed. ! IMDIVI(MA,IVAL,MB) MB = int(MA/IVAL) ! IVAL is a one word integer. Use IMDVIR ! to get the remainder also. ! IMDIVR(MA,MB,MC,MD) MC = int(MA/MB), MD = MA mod MB ! When both the quotient and remainder are ! needed, this routine is twice as fast as ! calling both IMDIV and IMMOD. ! IMDVIR(MA,IVAL,MB,IREM) MB = int(MA/IVAL), IREM = MA mod IVAL ! IVAL and IREM are one word integers. ! IMEQ(MA,MB) MB = MA ! IMFM2I(MAFM,MB) MB = MAFM Convert from real (FM) format ! to integer (IM) format. ! IMFORM(FORM,MA,STRING) MA is converted to a character string ! using format FORM and returned in ! STRING. FORM can represent I, F, ! E, or 1PE formats. Example: ! CALL IMFORM('I70',MA,STRING) ! IMFPRT(FORM,MA) Print MA on unit KW using FORM format. ! IMGCD(MA,MB,MC) MC = greatest common divisor of MA and MB. ! IMI2FM(MA,MBFM) MBFM = MA Convert from integer (IM) format ! to real (FM) format. ! IMI2M(IVAL,MA) MA = IVAL Convert from one word integer ! to IM. ! IMINP(LINE,MA,LA,LB) MA = LINE Input conversion. ! Convert LINE(LA) through LINE(LB) ! from characters to IM. ! IMM2DP(MA,X) X = MA Convert from IM to double precision. ! IMM2I(MA,IVAL) IVAL = MA Convert from IM to one word integer. ! IMMAX(MA,MB,MC) MC = MAX(MA,MB) ! IMMIN(MA,MB,MC) MC = MIN(MA,MB) ! IMMOD(MA,MB,MC) MC = MA mod MB ! IMMPY(MA,MB,MC) MC = MA*MB ! IMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer. ! IMMPYM(MA,MB,MC,MD) MD = MA*MB mod MC ! Slightly faster than calling IMMPY and ! IMMOD separately, and it works for cases ! where IMMPY would return OVERFLOW. ! IMOUT(MA,LINE,LB) LINE = MA Convert from IM to character. ! LINE is a character array of ! length LB. ! IMPMOD(MA,MB,MC,MD) MD = MA**MB mod MC ! IMPRNT(MA) Print MA on unit KW. ! IMPWR(MA,MB,MC) MC = MA**MB ! IMREAD(KREAD,MA) MA is returned after reading one (possibly ! multi-line) IM number on unit KREAD. This ! routine reads numbers written by IMWRIT. ! IMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer. ! IMSQR(MA,MB) MB = MA*MA Faster than IMMPY. ! IMST2M(STRING,MA) MA = STRING ! Convert from character string to IM. ! Often more convenient than IMINP, which ! converts an array of CHARACTER*1 values. ! Example: CALL IMST2M('12345678901',MA). ! IMSUB(MA,MB,MC) MC = MA - MB ! IMWRIT(KWRITE,MA) Write MA on unit KWRITE. ! Multi-line numbers will have '&' as the ! last nonblank character on all but the last ! line. These numbers can then be read ! easily using IMREAD. ! Many of the IM routines call FM routines, but none of the FM ! routines call IM routines, so the IM routines can be omitted ! if none are called explicitly from a program. ! 10. NEW FOR VERSION 1.1 ! Version 1.0 used integer arrays and integer arithmetic internally ! to perform the multiple precision operations. Version 1.1 uses ! double precision arithmetic and arrays internally. This is usually ! faster at higher precisions, and on many machines it is also faster ! at lower precisions. Version 1.1 is written so that the arithmetic ! used can easily be changed from double precision to integer, or any ! other available arithmetic type. This permits the user to make the ! best use of a given machine's arithmetic hardware. ! See the EFFICIENCY discussion below. ! Several routines have undergone minor modification, but only a few ! changes should affect programs that used FM 1.0. Many of the ! routines are faster in version 1.1, because code has been added to ! take advantage of special cases for individual functions instead of ! using general formulas that are more compact. For example, there ! are separate routines using series for SINH and COSH instead of ! just calling EXP. ! FMEQU was the only routine that required the user to give the value ! of the current precision. This was to allow automatic ! rounding or zero-padding when changing precision. Since few ! user calls change precision, a new routine has been added for ! this case. ! FMEQ now handles this case and has a simple argument list that ! does not include the value of NDIG. ! FMEQU is used for changing precision. ! See the list of FM routines above for details. ! All variable names beginning with M in the package are now declared ! as double precision, so FM common blocks in the user's program need ! D.P. declarations, and FM variables (arrays) used in the calling ! program need to be D.P. ! /FMUSER/ is a common block holding parameters that define the ! arithmetic to be used and other user options. Several ! new variables have been added, including screen width to ! be used for output. See above for further description. ! /FMSAVE/ is a common block for saving constants to avoid ! re-computing them. Several new variables have been added. ! /FMBUFF/ is a common block containing a character array used to ! format FM numbers for output. Two new items have been ! added. ! New routines: ! All the IM routines are new for version 1.1. ! FMADDI increments an FM number by a small integer. ! It runs in O(1) time, on the average. ! FMCHSH returns both SINH(MA) and COSH(MA). ! When both are needed, this is almost twice as fast ! as making separate calls to FMCOSH and FMSINH. ! FMCSSN returns both SIN(MA) and COS(MA). ! When both are needed, this is almost twice as fast ! as making separate calls to FMCOS and FMSIN. ! FMFORM uses a format string to convert an FM number to a ! character string. ! FMFPRT prints an FM number using a format string. ! FMREAD reads an FM number written using FMWRIT. ! FMRPWR computes an FM number raised to a rational power. For cube ! roots and similar rational powers it is usually much faster ! than FMPWR. ! FMSQR squares an FM number. It is faster than using FMMPY. ! FMST2M converts character strings to FM format. Since FMINP converts ! character arrays, this routine can be more convenient for ! easily defining an FM number. ! For example, CALL FMST2M('123.4',MA). ! FMWRIT writes an FM number using a format for multi-line numbers ! with '&' at the end of all but the last line of a multi-line ! number. This allows automatic reading of FM numbers without ! needing to know the base, precision or format under which they ! were written. ! One extra word has been added to the dimensions of all FM numbers. ! Word zero in each array contains a value used to monitor cancellation ! error arising from addition or subtraction. This value approximates ! the number of bits of precision for an FM value. It allows higher ! level FM functions to detect cases where too much cancellation has ! occurred. KACCSW is a switch variable in COMMON /FM/ used internally ! to enable cancellation error monitoring. ! 11. EFFICIENCY ! To take advantage of hardware architecture on different machines, the ! package has been designed so that the arithmetic used to perform the ! multiple precision operations can easily be changed. All variables ! that must be changed to get a different arithmetic have names ! beginning with 'M' and are declared using REAL (KIND(0.0D0)) :: m.... ! For example, to change the package to use integer arithmetic ! internally, make these two changes everywhere in the package: ! change 'REAL (KIND(0.0D0)) :: m' to 'INTEGER m', ! change 'DINT(' to 'INT('. ! On some systems, changing 'DINT(' to '(' may give better speed. ! When changing to a different type of arithmetic, all FM common blocks ! and arrays in the user's program must be changed to agree. In a few ! places in FM, where a DINT function is not supposed to be changed, it ! is spelled 'DINT (' so the global change will not find it. ! This version restricts the base used to be also representable in ! integer variables, so using precision above double usually does not ! save much time unless integers can also be declared at a higher ! precision. Using IEEE Extended would allow a base of around 10**9 ! to be chosen, but the delayed digit-normalization method used for ! multiplication and division means that a slightly smaller base like ! 10**8 would usually run faster. This would usually not be much ! faster than using 10**7 with double precision. ! The value of NBITS defined as a parameter in most FM routines ! refers to the number of bits used to represent integers in an ! M-variable word. Typical values for NBITS are: 24 for IEEE single ! precision, 32 for integer, 53 for IEEE double precision. NBITS ! controls only array size, so setting it too high is ok, but then ! the program will use more memory than necessary. ! For cases where special compiler directives or minor re-writing ! of the code may improve speed, several of the most important ! loops in FM are identified by comments containing the string ! '(Inner Loop)'. ! -------------------------------------------------------------------- ! -------------------------------------------------------------------- SUBROUTINE fmset(nprec) ! Initialize the values in common that must be set before calling ! other FM routines. ! Base and precision will be set to give at least NPREC+3 decimal ! digits of precision (giving the user three base ten guard digits). ! MBASE is set to a large power of ten. ! JFORM1 and JFORM2 are set to 1PE format displaying NPREC ! significant digits. ! The trace option is set off. ! The mode for angles in trig functions is set to radians. ! The rounding mode is set to symmetric rounding. ! Warning error message level is set to 1. ! Cancellation error monitor is set off. ! Screen width for output is set to 80 columns. ! The exponent character for FM output is set to 'M'. ! Debug error checking is set off. ! KW, the unit number for all FM output, is set to 6. ! The size of all arrays is controlled by defining two parameters: ! NDIGMX is the maximum value the user can set NDIG, ! NBITS is the number of bits used to represent integers in an ! M-variable word. IMPLICIT NONE ! Define the array sizes: ! Here are all the common blocks used in FM. ! /FMUSER/, /FM/, /FMBUFF/, and /FMSAVE/ should also be declared in the ! main program, because some compilers allocate and free space used for ! labelled common that is declared only in subprograms. This causes ! the saved information to be lost. ! FMUSER contains values that may need to be ! changed by the calling program. ! FM contains the work array used by the low-level ! arithmetic routines, definitions for overflow ! and underflow thresholds, and other ! machine-dependent values. ! FMSAVE contains information about saved constants. ! MJSUMS is an array that can contain several FM numbers ! being used to accumulate concurrent sums in exponential ! and trigonometric functions. When NDIGMX = 256, eight is ! about the maximum number of sums needed (but this depends ! on MBASE). For larger NDIGMX, dimensioning MJSUMS to hold ! more than eight FM numbers could increase the speed of the ! functions. ! FMWA contains two work arrays similar to MWA. They are ! used in routines FMDIVD, FMMPYD, and FMMPYE. ! CMBUFF is a character array used by FMPRNT for printing ! output from FMOUT. This array may also be used ! for calls to FMOUT from outside the FM package. ! CMCHAR is the letter used before the exponent field ! in FMOUT. It is defined in FMSET. ! NAMEST is a stack for names of the routines. It is ! used for trace printing and error messages. ! FM1 contains scratch arrays for temporary storage of FM ! numbers while computing various functions. ! FMPCK contains scratch arrays used to hold input arguments ! in unpacked format when the packed versions of functions ! are used. ! .. Intrinsic Functions .. INTRINSIC dble, ichar, int, log, log10, max, min, sqrt ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: nprec ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ml, mld2, mlm1 REAL (KIND(0.0D0)) :: one, temp, two, yt INTEGER :: j, k, kpt, l, npsave ! .. ! .. Local Arrays .. INTEGER :: ltypes(21), lvals(21) CHARACTER (1) :: lchars(21) ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmdbl, fmmset ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mjsums(0:ljsums), & mlbsav(0:lunpck), mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), & mln4(0:lunpck), mpa(0:lunpck), mpb(0:lunpck), mpc(0:lunpck), & mpisav(0:lunpck), mwa(lmwa), mwd(lmwa), mwe(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmpck/mpa, mpb, mpc COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmsums/mjsums COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /fmwa/mwd, mwe ! .. ! .. Data Statements .. DATA lchars/'+', '-', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', & '.', 'E', 'D', 'Q', 'M', 'e', 'd', 'q', 'm'/ DATA ltypes/1, 1, 10*2, 3, 8*4/ DATA lvals/1, -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 9*0/ ! .. ! KW is the unit number for standard output from the ! FM package. This includes trace output and error ! messages. kw = 6 ! MAXINT should be set to a very large integer, possibly ! the largest representable integer for the current ! machine. For most 32-bit machines, MAXINT is set ! to 2**53 - 1 = 9.007D+15 when double precision ! arithmetic is used for M-variables. Using integer ! M-variables usually gives MAXINT = 2**31 - 1 = ! 2 147 483 647. ! Setting MAXINT to a smaller number is ok, but this ! unnecessarily restricts the permissible range of ! MBASE and MXEXP. ! The following code should set MAXINT to the largest ! representable number of the form 2**J - 1. ! The FMMSET call keeps some compilers from doing the 110 ! loop at the highest precision available and then rounding ! to the declared precision. maxint = 3 10 CALL fmmset(maxint,ml,mld2,mlm1) IF (mld2==maxint .AND. mlm1/=ml) THEN maxint = ml GO TO 10 END IF ! INTMAX is a large value close to the overflow threshold ! for integer variables. It is usually 2**31 - 1 ! for machines with 32-bit integer arithmetic. ! WARNING: This loop causes integer overflow to occur, so it ! is a likely place for the program to fail when ! run on a different machine. The loop below has ! been used successfully with Fortran compilers ! for many different machines, but even different ! versions of the same compiler may give different ! results. Check the values of MAXINT and INTMAX ! if there are problems installing FM. intmax = 3 20 l = 2*intmax + 1 IF (int(l/2)==intmax) THEN intmax = l GO TO 20 END IF ! DPMAX should be set to a value near the machine's double ! precision overflow threshold, so that DPMAX and ! 1.0D0/DPMAX are both representable in double ! precision. dpmax = 1.0D+74 ! SPMAX should be set to a value near the machine's single ! precision overflow threshold, so that 1.01*SPMAX ! and 1.0/SPMAX are both representable in single ! precision. spmax = 1.0E+37 ! NDG2MX is the maximum value for NDIG that can be used ! internally. FM routines may raise NDIG above ! NDIGMX temporarily, to compute correctly ! rounded results. ! In the definition of LUNPCK, the '6/5' condition ! allows for converting from a large base to the ! (smaller) largest power of ten base for output ! conversion. ! The '+ 20' condition allows for the need to carry ! many guard digits when using a small base like 2. ndg2mx = lunpck - 1 ! MXBASE is the maximum value for MBASE. temp = maxint mxbase = int(min(dble(intmax),sqrt(temp))) ! MBASE is the currently used base for arithmetic. k = int(log10(dble(mxbase)/4)) mbase = 10**k ! NDIG is the number of digits currently being carried. npsave = nprec ndig = 2 + (nprec+2)/k IF (ndig<2 .OR. ndig>ndigmx) THEN ndig = max(2,min(ndigmx,ndig)) WRITE (kw,90000) nprec, ndig npsave = 0 END IF ! KFLAG is the flag for error conditions. kflag = 0 ! NTRACE is the trace switch. Default is no printing. ntrace = 0 ! LVLTRC is the trace level. Default is to trace only ! routines called directly by the user. lvltrc = 1 ! NCALL is the call stack pointer. ncall = 0 ! NAMEST is the call stack. DO 30 j = 0, 50 namest(j) = 'MAIN ' 30 CONTINUE ! Some constants that are often needed are stored with the ! maximum precision to which they have been computed in the ! currently used base. This speeds up the trig, log, power, ! and exponential functions. ! NDIGPI is the number of digits available in the currently ! stored value of pi (MPISAV). ndigpi = 0 ! MBSPI is the value of MBASE for the currently stored ! value of pi. mbspi = 0 ! NDIGE is the number of digits available in the currently ! stored value of e (MESAV). ndige = 0 ! MBSE is the value of MBASE for the currently stored ! value of e. mbse = 0 ! NDIGLB is the number of digits available in the currently ! stored value of LN(MBASE) (MLBSAV). ndiglb = 0 ! MBSLB is the value of MBASE for the currently stored ! value of LN(MBASE). mbslb = 0 ! NDIGLI is the number of digits available in the currently ! stored values of the four logarithms used by FMLNI ! MLN1 - MLN4. ndigli = 0 ! MBSLI is the value of MBASE for the currently stored ! values of MLN1 - MLN4. mbsli = 0 ! MXEXP is the current maximum exponent. ! MXEXP2 is the internal maximum exponent. This is used to ! define the overflow and underflow thresholds. ! These values are chosen so that FM routines can raise the ! overflow/underflow limit temporarily while computing ! intermediate results, and so that EXP(INTMAX) is greater ! than MXBASE**(MXEXP2+1). ! The overflow threshold is MBASE**(MXEXP+1), and the ! underflow threshold is MBASE**(-MXEXP-1). ! This means the valid exponents in the first word of an FM ! number can range from -MXEXP to MXEXP+1 (inclusive). mxexp = int((dble(intmax))/(2.0D0*log(dble(mxbase)))-1.0D0) mxexp2 = int(2*mxexp+mxexp/100) ! KACCSW is a switch used to enable cancellation error ! monitoring. Routines where cancellation is ! not a problem run faster by skipping the ! cancellation monitor calculations. ! KACCSW = 0 means no error monitoring, ! = 1 means error monitoring is done. kaccsw = 0 ! MEXPUN is the exponent used as a special symbol for ! underflowed results. mexpun = -mxexp2 - 5*ndigmx ! MEXPOV is the exponent used as a special symbol for ! overflowed results. mexpov = -mexpun ! MUNKNO is the exponent used as a special symbol for ! unknown FM results (1/0, SQRT(-3.0), ...). munkno = mexpov + 5*ndigmx ! RUNKNO is returned from FM to real or double conversion ! routines when no valid result can be expressed in ! real or double precision. On systems that provide ! a value for undefined results (e.g., Not A Number) ! setting RUNKNO to that value is reasonable. On ! other systems set it to a value that is likely to ! make any subsequent results obviously wrong that ! use it. In either case a KFLAG = -4 condition is ! also returned. runkno = -1.01*spmax ! IUNKNO is returned from FM to integer conversion routines ! when no valid result can be expressed as a one word ! integer. KFLAG = -4 is also set. iunkno = -int(mxexp2) ! JFORM1 indicates the format used by FMOUT. jform1 = 1 ! JFORM2 indicates the number of digits used in FMOUT. jform2 = npsave ! KRAD = 1 indicates that trig functions use radians, ! = 0 means use degrees. krad = 1 ! KWARN = 0 indicates that no warning message is printed ! and execution continues when UNKNOWN or another ! exception is produced. ! = 1 means print a warning message and continue. ! = 2 means print a warning message and stop. kwarn = 1 ! KROUND = 1 causes all results to be rounded to the ! nearest FM number, or to the value with ! an even last digit if the result is halfway ! between two FM numbers. ! = 0 causes all results to be chopped. kround = 1 ! KSWIDE defines the maximum screen width to be used for ! all unit KW output. kswide = 80 ! KESWCH = 1 causes input to FMINP with no digits before ! the exponent letter to be treated as if there ! were a leading '1'. This is sometimes better ! for interactive input: 'E7' converts to ! 10.0**7. ! = 0 causes a leading zero to be assumed. This ! gives compatibility with Fortran: 'E7' ! converts to 0.0. keswch = 1 ! CMCHAR defines the exponent letter to be used for ! FM variable output from FMOUT, as in 1.2345M+678. ! Change it to 'E' for output to be read by a ! non-FM program. cmchar = 'M' ! KSUB is an internal flag set during subtraction so that ! the addition routine will negate its second argument. ksub = 0 ! KDEBUG = 0 Error checking is not done for valid input ! arguments and parameters like NDIG and MBASE ! upon entry to each routine. ! = 1 Error checking is done. kdebug = 0 ! Initialize two hash tables that are used for character ! look-up during input conversion. DO 40 j = lhash1, lhash2 khasht(j) = 5 khashv(j) = 0 40 CONTINUE DO 50 j = 1, 21 kpt = ichar(lchars(j)) IF (kptlhash2) THEN WRITE (kw,90010) lchars(j), kpt, lhash1, lhash2 ELSE khasht(kpt) = ltypes(j) khashv(kpt) = lvals(j) END IF 50 CONTINUE ! DPEPS is the approximate machine precision. one = 1.0D0 two = 128.0D0 dpeps = one 60 dpeps = dpeps/two CALL fmdbl(one,dpeps,yt) IF (yt>one) GO TO 60 dpeps = dpeps*two two = 2.0D0 70 dpeps = dpeps/two CALL fmdbl(one,dpeps,yt) IF (yt>one) GO TO 70 dpeps = dpeps*two ! FMCONS sets several real and double precision constants. CALL fmcons RETURN 90000 FORMAT (//' Precision out of range when calling FMSET.',' NPREC =', & I20/' The nearest valid NDIG will be used',' instead: NDIG =',I6//) 90010 FORMAT (/' Error in input conversion.'/ & ' ICHAR function was out of range for the current', & ' dimensions.'/' ICHAR(''',A,''') gave the value ',I12, & ', which is outside the currently'/' dimensioned',' bounds of (',I5, & ':',I5,') for variables KHASHT ','and KHASHV.'/ & ' Re-define the two parameters ', & 'LHASH1 and LHASH2 so the dimensions will'/' contain', & ' all possible output values from ICHAR.'//) END SUBROUTINE fmset SUBROUTINE fmabs(ma,mb) ! MB = ABS(MA) IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: md2b INTEGER :: kwrnsv ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMABS ' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kflag = 0 kwrnsv = kwarn kwarn = 0 CALL fmeq(ma,mb) mb(2) = abs(mb(2)) kwarn = kwrnsv IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),md2b) END IF IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END SUBROUTINE fmabs SUBROUTINE fmacos(ma,mb) ! MB = ACOS(MA) IMPLICIT NONE ! Scratch array usage during FMACOS: M01 - M06 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, macmax, mxsave INTEGER :: k, kasave, kovun, kreslt, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmatan, fmcons, fmdiv, fmentr, fmeq2, fmexit, fmi2m, & fmmpy, fmntr, fmpi, fmrslt, fmsqrt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(1)>0 .OR. ma(2)==0) THEN CALL fmentr('FMACOS',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMACOS' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52-1,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF ma2 = ma(2) macca = ma(0) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) ! Use ACOS(X) = ATAN(SQRT(1-X*X)/X) mb(2) = abs(mb(2)) CALL fmi2m(1,m05) CALL fmsub(m05,mb,m03) CALL fmadd(m05,mb,m04) CALL fmmpy(m03,m04,m04) CALL fmsqrt(m04,m04) CALL fmdiv(m04,mb,mb) CALL fmatan(mb,mb) IF (ma2<0) THEN IF (krad==1) THEN CALL fmpi(m05) ELSE CALL fmi2m(180,m05) END IF CALL fmsub(m05,mb,mb) END IF ! Round the result and return. macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmacos SUBROUTINE fmadd(ma,mb,mc) ! MC = MA + MB ! This routine performs the trace printing for addition. ! FMADD2 is used to do the arithmetic. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmadd2, fmntr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMADD ' CALL fmntr(2,ma,mb,2) CALL fmadd2(ma,mb,mc) CALL fmntr(1,mc,mc,1) ELSE CALL fmadd2(ma,mb,mc) END IF ncall = ncall - 1 RETURN END SUBROUTINE fmadd SUBROUTINE fmadd2(ma,mb,mc) ! Internal addition routine. MC = MA + MB IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL :: b2rda, b2rdb REAL (KIND(0.0D0)) :: ma0, ma1, ma2, mb0, mb1, mb2, mb2rd INTEGER :: j, jcomp, jsign, kreslt, n1, nguard, nmwa ! .. ! .. External Subroutines .. EXTERNAL fmaddn, fmaddp, fmargs, fmcons, fmeq, fmmove, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. abs(mb(1))>mexpab .OR. kdebug==1) THEN IF (ksub==1) THEN CALL fmargs('FMSUB ',2,ma,mb,kreslt) ELSE CALL fmargs('FMADD ',2,ma,mb,kreslt) END IF IF (kreslt/=0) THEN ncall = ncall + 1 IF (ksub==1) THEN namest(ncall) = 'FMSUB ' ELSE namest(ncall) = 'FMADD ' END IF CALL fmrslt(ma,mb,mc,kreslt) ncall = ncall - 1 RETURN END IF ELSE IF (ma(2)==0) THEN ma0 = min(ma(0),mb(0)) CALL fmeq(mb,mc) mc(0) = ma0 kflag = 1 IF (ksub==1) THEN IF (mc(1)/=munkno) mc(2) = -mc(2) kflag = 0 END IF RETURN END IF IF (mb(2)==0) THEN ma0 = min(ma(0),mb(0)) CALL fmeq(ma,mc) mc(0) = ma0 kflag = 1 RETURN END IF END IF ma0 = ma(0) IF (kaccsw==1) THEN mb0 = mb(0) ma1 = ma(1) mb1 = mb(1) END IF kflag = 0 n1 = ndig + 1 ! NGUARD is the number of guard digits used. IF (ncall>1) THEN nguard = ngrd21 IF (nguard>ndig) nguard = ndig ELSE nguard = ngrd52 IF (nguard>ndig) nguard = ndig END IF nmwa = n1 + nguard ! Save the signs of MA and MB and then work with ! positive numbers. ! JSIGN is the sign of the result of MA + MB. jsign = 1 ma2 = ma(2) mb2 = mb(2) IF (ksub==1) mb2 = -mb2 ma(2) = abs(ma(2)) mb(2) = abs(mb(2)) ! See which one is larger in absolute value. IF (ma(1)>mb(1)) THEN jcomp = 1 GO TO 20 END IF IF (mb(1)>ma(1)) THEN jcomp = 3 GO TO 20 END IF DO 10 j = 2, n1 IF (ma(j)>mb(j)) THEN jcomp = 1 GO TO 20 END IF IF (mb(j)>ma(j)) THEN jcomp = 3 GO TO 20 END IF 10 CONTINUE jcomp = 2 20 IF (jcomp<3) THEN IF (ma2<0) jsign = -1 IF (ma2*mb2>0) THEN CALL fmaddp(ma,mb,nguard,nmwa) ELSE CALL fmaddn(ma,mb,nguard,nmwa) END IF ELSE IF (mb2<0) jsign = -1 IF (ma2*mb2>0) THEN CALL fmaddp(mb,ma,nguard,nmwa) ELSE CALL fmaddn(mb,ma,nguard,nmwa) END IF END IF IF (ksub==1) mb2 = -mb2 mb(2) = mb2 ma(2) = ma2 ! Transfer to MC and fix the sign of the result. CALL fmmove(mwa,mc) IF (jsign<0) mc(2) = -mc(2) IF (kflag<0) THEN IF (ksub==1) THEN namest(ncall) = 'FMSUB ' ELSE namest(ncall) = 'FMADD ' END IF CALL fmwarn END IF IF (kaccsw==1) THEN b2rda = log(real(abs(mc(2))+1)/real(abs(ma2)+1))/0.69315 + & real(mc(1)-ma1)*alogm2 + real(ma0) b2rdb = log(real(abs(mc(2))+1)/real(abs(mb2)+1))/0.69315 + & real(mc(1)-mb1)*alogm2 + real(mb0) mb2rd = nint(max(0.0,min(b2rda,b2rdb,(ndig-1)*alogm2+log(real(abs(mc(2 & ))+1))/0.69315))) IF (mc(2)==0) THEN mc(0) = 0 ELSE mc(0) = min(max(ma0,mb0),mb2rd) END IF ELSE mc(0) = ma0 END IF RETURN END SUBROUTINE fmadd2 SUBROUTINE fmaddi(ma,ival) ! MA = MA + IVAL ! Increment MA by one word integer IVAL. ! This routine is faster than FMADD when IVAL is small enough so ! that it can be added to a single word of MA without often causing ! a carry. Otherwise FMI2M and FMADD are used. IMPLICIT NONE ! Scratch array usage during FMADDI: M01 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maexp, md2b, mksum INTEGER :: kptma ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmi2m, fmntr, fmntri ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMADDI' CALL fmntr(2,ma,ma,1) CALL fmntri(2,ival,0) END IF kflag = 0 maexp = ma(1) IF (maexp<=0 .OR. maexp>ndig) GO TO 10 kptma = int(maexp) + 1 IF (kptma>2 .AND. ma(2)<0) THEN mksum = ma(kptma) - ival ELSE mksum = ma(kptma) + ival END IF IF (mksum>=mbase .OR. mksum<=(-mbase)) GO TO 10 IF (ma(2)<0) THEN IF (kptma>2) THEN IF (mksum>=0) THEN ma(kptma) = mksum GO TO 20 ELSE GO TO 10 END IF ELSE IF (mksum<0) THEN ma(kptma) = mksum GO TO 20 ELSE GO TO 10 END IF END IF ELSE IF (kptma>2) THEN IF (mksum>=0) THEN ma(kptma) = mksum GO TO 20 ELSE GO TO 10 END IF ELSE IF (mksum>0) THEN ma(kptma) = mksum GO TO 20 ELSE GO TO 10 END IF END IF END IF 10 CALL fmi2m(ival,m01) CALL fmadd(ma,m01,ma) 20 IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(ma(2))+1))/0.69315) ma(0) = min(ma(0),md2b) END IF IF (ntrace/=0) THEN CALL fmntr(1,ma,ma,1) END IF ncall = ncall - 1 RETURN END SUBROUTINE fmaddi SUBROUTINE fmaddn(ma,mb,nguard,nmwa) ! Internal addition routine. MWA = MA - MB ! The arguments are such that MA.GE.MB.GE.0. ! NGUARD is the number of guard digits being carried. ! NMWA is the number of words in MWA that will be used. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int, min ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: nguard, nmwa ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mk, mr INTEGER :: j, k, kl, kp1, kp2, kpt, ksh, n1, n2, nk, nk1 ! .. ! .. External Subroutines .. EXTERNAL fmrnd ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. n1 = ndig + 1 ! Check for an insignificant operand. mk = ma(1) - mb(1) IF (mk>=ndig+2) THEN DO 10 j = 1, n1 mwa(j) = ma(j) 10 CONTINUE mwa(n1+1) = 0 kflag = 1 RETURN END IF k = int(mk) IF (nguard<=1) nmwa = n1 + 2 ! Subtract MB from MA. kp1 = min(n1,k+1) mwa(k+1) = 0 DO 20 j = 1, kp1 mwa(j) = ma(j) 20 CONTINUE kp2 = k + 2 ! (Inner Loop) DO 30 j = kp2, n1 mwa(j) = ma(j) - mb(j-k) 30 CONTINUE n2 = ndig + 2 IF (n2-k<=1) n2 = 2 + k nk = min(nmwa,n1+k) DO 40 j = n2, nk mwa(j) = -mb(j-k) 40 CONTINUE nk1 = nk + 1 DO 50 j = nk1, nmwa mwa(j) = 0 50 CONTINUE ! Normalize. Fix the sign of any negative digit. IF (k>0) THEN DO 60 j = nmwa, kp2, -1 IF (mwa(j)<0) THEN mwa(j) = mwa(j) + mbase mwa(j-1) = mwa(j-1) - 1 END IF 60 CONTINUE kpt = kp2 - 1 70 IF (mwa(kpt)<0 .AND. kpt>=3) THEN mwa(kpt) = mwa(kpt) + mbase mwa(kpt-1) = mwa(kpt-1) - 1 kpt = kpt - 1 GO TO 70 END IF GO TO 90 END IF DO 80 j = n1, 3, -1 IF (mwa(j)<0) THEN mwa(j) = mwa(j) + mbase mwa(j-1) = mwa(j-1) - 1 END IF 80 CONTINUE ! Shift left if there are any leading zeros in the mantissa. 90 DO 100 j = 2, nmwa IF (mwa(j)>0) THEN ksh = j - 2 GO TO 110 END IF 100 CONTINUE mwa(1) = 0 RETURN 110 IF (ksh>0) THEN kl = nmwa - ksh DO 120 j = 2, kl mwa(j) = mwa(j+ksh) 120 CONTINUE DO 130 j = kl + 1, nmwa mwa(j) = 0 130 CONTINUE mwa(1) = mwa(1) - ksh END IF ! Round the result. mr = 2*mwa(ndig+2) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwa(n1)1) THEN mwa(n1) = mwa(n1) + 1 mwa(n1+1) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,0) END IF END IF ! See if the result is equal to one of the input arguments. IF (abs(ma(1)-mb(1))ndig+1) THEN kflag = 1 GO TO 150 END IF n2 = ndig + 4 DO 140 j = 3, n1 IF (mwa(n2-j)/=ma(n2-j)) GO TO 150 140 CONTINUE IF (mwa(1)/=ma(1)) GO TO 150 IF (mwa(2)/=abs(ma(2))) GO TO 150 kflag = 1 150 RETURN END SUBROUTINE fmaddn SUBROUTINE fmaddp(ma,mb,nguard,nmwa) ! Internal addition routine. MWA = MA + MB ! The arguments are such that MA.GE.MB.GE.0. ! NMWA is the number of words in MWA that will be used. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, min ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: nguard, nmwa ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mk, mkt, mr INTEGER :: j, k, kp, kp2, kpt, kshift, n1, n2, nk ! .. ! .. External Subroutines .. EXTERNAL fmrnd ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. n1 = ndig + 1 ! Check for an insignificant operand. mk = ma(1) - mb(1) IF (mk>=ndig+1) THEN mwa(1) = ma(1) + 1 mwa(2) = 0 DO 10 j = 2, n1 mwa(j+1) = ma(j) 10 CONTINUE mwa(n1+2) = 0 kflag = 1 RETURN END IF k = int(mk) ! Add MA and MB. mwa(1) = ma(1) + 1 mwa(2) = 0 DO 20 j = 2, k + 1 mwa(j+1) = ma(j) 20 CONTINUE kp2 = k + 2 ! (Inner Loop) DO 30 j = kp2, n1 mwa(j+1) = ma(j) + mb(j-k) 30 CONTINUE n2 = ndig + 2 nk = min(nmwa,n1+k) DO 40 j = n2, nk mwa(j+1) = mb(j-k) 40 CONTINUE DO 50 j = nk + 1, nmwa mwa(j+1) = 0 50 CONTINUE ! Normalize. Fix any digit not less than MBASE. IF (k==ndig) GO TO 120 IF (k>0) THEN DO 60 j = n1 + 1, kp2, -1 IF (mwa(j)>=mbase) THEN mwa(j) = mwa(j) - mbase mwa(j-1) = mwa(j-1) + 1 END IF 60 CONTINUE kpt = kp2 - 1 70 IF (mwa(kpt)>=mbase .AND. kpt>=3) THEN mwa(kpt) = mwa(kpt) - mbase mwa(kpt-1) = mwa(kpt-1) + 1 kpt = kpt - 1 GO TO 70 END IF GO TO 90 END IF DO 80 j = n1 + 1, 3, -1 IF (mwa(j)>=mbase) THEN mwa(j) = mwa(j) - mbase mwa(j-1) = mwa(j-1) + 1 END IF 80 CONTINUE ! Shift right if the leading digit is not less than MBASE. 90 IF (mwa(2)>=mbase) THEN 100 kp = nmwa + 4 DO 110 j = 4, nmwa mwa(kp-j) = mwa(kp-j-1) 110 CONTINUE mkt = dint(mwa(2)/mbase) mwa(3) = mwa(2) - mkt*mbase mwa(2) = mkt mwa(1) = mwa(1) + 1 IF (mwa(2)>=mbase) GO TO 100 END IF ! Round the result. 120 kshift = 0 IF (mwa(2)==0) kshift = 1 mr = 2*mwa(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwa(n1+kshift)1) THEN mwa(n1+kshift) = mwa(n1+kshift) + 1 mwa(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,kshift) END IF END IF ! See if the result is equal to one of the input arguments. IF (abs(ma(1)-mb(1))ndig+1) THEN kflag = 1 GO TO 140 END IF n2 = ndig + 4 DO 130 j = 3, n1 IF (mwa(n2-j+1)/=ma(n2-j)) GO TO 140 130 CONTINUE IF (mwa(1)/=ma(1)+1) GO TO 140 IF (mwa(3)/=abs(ma(2))) GO TO 140 kflag = 1 140 RETURN END SUBROUTINE fmaddp SUBROUTINE fmargs(kroutn,nargs,ma,mb,kreslt) ! Check the input arguments to a routine for special cases. ! KROUTN - Name of the subroutine that was called ! NARGS - The number of input arguments (1 or 2) ! MA - First input argument ! MB - Second input argument (if NARGS is 2) ! KRESLT - Result code returned to the calling routine. ! Result codes: ! 0 - Perform the normal operation ! 1 - The result is the first input argument ! 2 - The result is the second input argument ! 3 - The result is -OVERFLOW ! 4 - The result is +OVERFLOW ! 5 - The result is -UNDERFLOW ! 6 - The result is +UNDERFLOW ! 7 - The result is -1.0 ! 8 - The result is +1.0 ! 9 - The result is -pi/2 ! 10 - The result is +pi/2 ! 11 - The result is 0.0 ! 12 - The result is UNKNOWN ! 13 - The result is +pi ! 14 - The result is -pi/4 ! 15 - The result is +pi/4 IMPLICIT NONE ! These tables define the result codes to be returned for ! given values of the input argument(s). ! For example, in row 7 column 2 of this DATA statement ! KADD(2,7) = 2 means that if the first argument in a call ! to FMADD is in category 7 ( -UNDERFLOW ) and the second ! argument is in category 2 ( near -OVERFLOW but ! representable ) then the result code is 2 ( the value ! of the sum is equal to the second input argument). ! See routine FMCAT for descriptions of the categories. ! .. Intrinsic Functions .. INTRINSIC abs, int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kreslt, nargs CHARACTER (6) :: kroutn ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mbs INTEGER :: j, kwrnsv, ncatma, ncatmb, nds ! .. ! .. Local Arrays .. INTEGER :: kacos(15), kadd(15,15), kasin(15), katan(15), kcos(15), & kcosh(15), kdiv(15,15), kexp(15), klg10(15), kln(15), kmpy(15,15), & kpwr(15,15), ksin(15), ksinh(15), ksqrt(15), ktan(15), ktanh(15) ! .. ! .. External Subroutines .. EXTERNAL fmcat, fmcons, fmim, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! .. Data Statements .. DATA kadd/3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 12, 12, 3, 0, 0, 0, 0, & 0, 1, 1, 1, 0, 0, 0, 0, 0, 12, 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, & 0, 4, 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, 3, 0, 0, 0, 0, 0, & 1, 1, 1, 0, 0, 0, 0, 0, 4, 3, 0, 0, 0, 0, 0, 12, 1, 12, 0, 0, 0, 0, 0, & 4, 3, 2, 2, 2, 2, 12, 12, 5, 12, 12, 2, 2, 2, 2, 4, 3, 2, 2, 2, 2, 2, & 5, 2, 6, 2, 2, 2, 2, 2, 4, 3, 2, 2, 2, 2, 12, 12, 6, 12, 12, 2, 2, 2, & 2, 4, 3, 0, 0, 0, 0, 0, 12, 1, 12, 0, 0, 0, 0, 0, 4, 3, 0, 0, 0, 0, 0, & 1, 1, 1, 0, 0, 0, 0, 0, 4, 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, & 4, 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, 12, 0, 0, 0, 0, 0, 1, & 1, 1, 0, 0, 0, 0, 0, 4, 12, 12, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4/ DATA kmpy/4, 4, 4, 4, 12, 12, 12, 11, 12, 12, 12, 3, 3, 3, 3, 4, 0, 0, & 0, 0, 0, 12, 11, 12, 0, 0, 1, 0, 0, 3, 4, 0, 0, 0, 0, 0, 12, 11, 12, & 0, 0, 1, 0, 0, 3, 4, 0, 0, 0, 0, 0, 6, 11, 5, 0, 0, 1, 0, 0, 3, 12, 0, & 0, 0, 0, 0, 6, 11, 5, 0, 0, 1, 0, 0, 12, 12, 0, 0, 0, 0, 0, 6, 11, 5, & 0, 0, 1, 0, 0, 12, 12, 12, 12, 6, 6, 6, 6, 11, 5, 5, 5, 5, 12, 12, 12, & 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 12, 12, & 12, 5, 5, 5, 5, 11, 6, 6, 6, 6, 12, 12, 12, 12, 0, 0, 0, 0, 0, 5, 11, & 6, 0, 0, 1, 0, 0, 12, 12, 0, 0, 0, 0, 0, 5, 11, 6, 0, 0, 1, 0, 0, 12, & 3, 2, 2, 2, 2, 2, 5, 11, 6, 2, 2, 2, 2, 2, 4, 3, 0, 0, 0, 0, 0, 12, & 11, 12, 0, 0, 1, 0, 0, 4, 3, 0, 0, 0, 0, 0, 12, 11, 12, 0, 0, 1, 0, 0, & 4, 3, 3, 3, 3, 12, 12, 12, 11, 12, 12, 12, 4, 4, 4, 4/ DATA kdiv/12, 12, 12, 4, 4, 4, 4, 12, 3, 3, 3, 3, 12, 12, 12, 12, 0, 0, & 0, 0, 0, 4, 12, 3, 0, 0, 1, 0, 0, 12, 12, 0, 0, 0, 0, 0, 4, 12, 3, 0, & 0, 1, 0, 0, 12, 6, 0, 0, 0, 0, 0, 4, 12, 3, 0, 0, 1, 0, 0, 5, 6, 0, 0, & 0, 0, 0, 12, 12, 12, 0, 0, 1, 0, 0, 5, 6, 0, 0, 0, 0, 0, 12, 12, 12, & 0, 0, 1, 0, 0, 5, 6, 6, 6, 6, 12, 12, 12, 12, 12, 12, 12, 5, 5, 5, 5, & 11, 11, 11, 11, 11, 11, 11, 12, 11, 11, 11, 11, 11, 11, 11, 5, 5, 5, & 5, 12, 12, 12, 12, 12, 12, 12, 6, 6, 6, 6, 5, 0, 0, 0, 0, 0, 12, 12, & 12, 0, 0, 1, 0, 0, 6, 5, 0, 0, 0, 0, 0, 12, 12, 12, 0, 0, 1, 0, 0, 6, & 5, 0, 0, 0, 0, 0, 3, 12, 4, 0, 0, 1, 0, 0, 6, 12, 0, 0, 0, 0, 0, 3, & 12, 4, 0, 0, 1, 0, 0, 12, 12, 0, 0, 0, 0, 0, 3, 12, 4, 0, 0, 1, 0, 0, & 12, 12, 12, 12, 3, 3, 3, 3, 12, 4, 4, 4, 4, 12, 12, 12/ DATA kpwr/12, 12, 0, 5, 12, 12, 12, 8, 12, 12, 12, 3, 0, 12, 12, 12, 12, & 0, 0, 12, 12, 12, 8, 12, 12, 12, 1, 0, 12, 12, 12, 12, 0, 0, 12, 12, & 12, 8, 12, 12, 12, 1, 0, 12, 12, 12, 12, 0, 0, 12, 12, 12, 8, 12, 12, & 12, 1, 0, 12, 12, 12, 12, 0, 0, 12, 12, 12, 8, 12, 12, 12, 1, 0, 12, & 12, 12, 12, 0, 0, 12, 12, 12, 8, 12, 12, 12, 1, 0, 12, 12, 12, 12, 0, & 3, 12, 12, 12, 8, 12, 12, 12, 5, 0, 12, 12, 12, 12, 12, 12, 12, 12, & 12, 12, 11, 11, 11, 11, 11, 11, 11, 4, 4, 4, 4, 12, 12, 12, 8, 12, 12, & 12, 6, 6, 6, 6, 4, 4, 0, 0, 0, 8, 8, 8, 8, 0, 0, 1, 0, 6, 6, 4, 4, 0, & 0, 0, 8, 8, 8, 8, 0, 0, 1, 0, 6, 6, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, & 8, 8, 8, 8, 6, 6, 0, 0, 0, 8, 8, 8, 8, 8, 0, 1, 0, 4, 4, 6, 6, 0, 0, & 0, 8, 8, 8, 8, 8, 0, 1, 0, 4, 4, 6, 6, 6, 6, 12, 12, 12, 8, 12, 12, & 12, 4, 4, 4, 4/ DATA ksqrt/12, 12, 12, 12, 12, 12, 12, 11, 12, 0, 0, 8, 0, 0, 12/ DATA kexp/6, 6, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0, 4, 4/ DATA kln/12, 12, 12, 12, 12, 12, 12, 12, 12, 0, 0, 11, 0, 0, 12/ DATA ksin/12, 12, 0, 0, 0, 0, 5, 11, 6, 0, 0, 0, 0, 12, 12/ DATA kcos/12, 12, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0, 12, 12/ DATA ktan/12, 12, 0, 0, 0, 0, 5, 11, 6, 0, 0, 0, 0, 12, 12/ DATA kasin/12, 12, 12, 9, 0, 0, 5, 11, 6, 0, 0, 10, 12, 12, 12/ DATA kacos/12, 12, 12, 13, 0, 10, 10, 10, 10, 10, 0, 11, 12, 12, 12/ DATA katan/9, 9, 0, 14, 0, 0, 5, 11, 6, 0, 0, 15, 0, 10, 10/ DATA ksinh/3, 3, 0, 0, 0, 1, 5, 11, 6, 1, 0, 0, 0, 4, 4/ DATA kcosh/4, 4, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0, 4, 4/ DATA ktanh/7, 7, 0, 0, 0, 1, 5, 11, 6, 1, 0, 0, 0, 8, 8/ DATA klg10/12, 12, 12, 12, 12, 12, 12, 12, 12, 0, 0, 11, 0, 0, 12/ ! .. kreslt = 12 kflag = -4 IF (ma(1)==munkno) RETURN IF (nargs==2) THEN IF (mb(1)==munkno) RETURN END IF IF (mblogs/=mbase) CALL fmcons kflag = 0 namest(ncall) = kroutn ! Check the validity of parameters if this is a user call. IF (ncall>1 .AND. kdebug==0) GO TO 50 ! Check NDIG. IF (ndig<2 .OR. ndig>ndigmx) THEN kflag = -1 CALL fmwarn nds = ndig IF (ndig<2) ndig = 2 IF (ndig>ndigmx) ndig = ndigmx WRITE (kw,90000) nds, ndig RETURN END IF ! Check MBASE. IF (mbase<2 .OR. mbase>mxbase) THEN kflag = -2 CALL fmwarn mbs = mbase IF (mbase<2) mbase = 2 IF (mbase>mxbase) mbase = mxbase WRITE (kw,90010) int(mbs), int(mbase) CALL fmcons RETURN END IF ! Check exponent range. IF (ma(1)>mxexp+1 .OR. ma(1)<-mxexp) THEN IF (abs(ma(1))/=mexpov .OR. abs(ma(2))/=1) THEN CALL fmim(0,ma) kflag = -3 CALL fmwarn ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) RETURN END IF END IF IF (nargs==2) THEN IF (mb(1)>mxexp+1 .OR. mb(1)<-mxexp) THEN IF (abs(mb(1))/=mexpov .OR. abs(mb(2))/=1) THEN CALL fmim(0,mb) kflag = -3 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) RETURN END IF END IF END IF ! Check for properly normalized digits in the ! input arguments. IF (abs(ma(1)-int(ma(1)))/=0) kflag = 1 IF (ma(2)<=(-mbase) .OR. ma(2)>=mbase .OR. abs(ma(2)-int(ma(2)))/=0) & kflag = 2 IF (kdebug==0) GO TO 20 DO 10 j = 3, ndig + 1 IF (ma(j)<0 .OR. ma(j)>=mbase .OR. abs(ma(j)-int(ma(j)))/=0) THEN kflag = j GO TO 20 END IF 10 CONTINUE 20 IF (kflag/=0) THEN j = kflag mbs = ma(j) CALL fmim(0,ma) kflag = -4 kwrnsv = kwarn IF (kwarn>=2) kwarn = 1 CALL fmwarn kwarn = kwrnsv IF (kwarn>=1) THEN WRITE (kw,*) ' First invalid array element: MA(', j, ') = ', mbs END IF ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) IF (kwarn>=2) THEN STOP END IF RETURN END IF IF (nargs==2) THEN IF (abs(mb(1)-int(mb(1)))/=0) kflag = 1 IF (mb(2)<=(-mbase) .OR. mb(2)>=mbase .OR. abs(mb(2)-int(mb(2)))/=0) & kflag = 2 IF (kdebug==0) GO TO 40 DO 30 j = 3, ndig + 1 IF (mb(j)<0 .OR. mb(j)>=mbase .OR. abs(mb(j)-int(mb(j)))/=0) THEN kflag = j GO TO 40 END IF 30 CONTINUE 40 IF (kflag/=0) THEN j = kflag mbs = mb(j) CALL fmim(0,mb) kflag = -4 kwrnsv = kwarn IF (kwarn>=2) kwarn = 1 CALL fmwarn kwarn = kwrnsv IF (kwarn>=1) THEN WRITE (kw,*) ' First invalid array element: MB(', j, ') = ', mbs END IF mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) IF (kwarn>=2) THEN STOP END IF RETURN END IF END IF ! Check for special cases. 50 CALL fmcat(ma,ncatma) ncatmb = 0 IF (nargs==2) CALL fmcat(mb,ncatmb) IF (kroutn=='FMADD ') THEN kreslt = kadd(ncatmb,ncatma) GO TO 60 END IF IF (kroutn=='FMSUB ') THEN IF (ncatmb<16) ncatmb = 16 - ncatmb kreslt = kadd(ncatmb,ncatma) GO TO 60 END IF IF (kroutn=='FMMPY ') THEN kreslt = kmpy(ncatmb,ncatma) GO TO 60 END IF IF (kroutn=='FMDIV ') THEN kreslt = kdiv(ncatmb,ncatma) GO TO 60 END IF IF (kroutn=='FMPWR ') THEN kreslt = kpwr(ncatmb,ncatma) GO TO 60 END IF IF (kroutn=='FMSQRT') THEN kreslt = ksqrt(ncatma) GO TO 60 END IF IF (kroutn=='FMEXP ') THEN kreslt = kexp(ncatma) GO TO 60 END IF IF (kroutn=='FMLN ') THEN kreslt = kln(ncatma) GO TO 60 END IF IF (kroutn=='FMSIN ') THEN kreslt = ksin(ncatma) GO TO 60 END IF IF (kroutn=='FMCOS ') THEN kreslt = kcos(ncatma) GO TO 60 END IF IF (kroutn=='FMTAN ') THEN kreslt = ktan(ncatma) GO TO 60 END IF IF (kroutn=='FMASIN') THEN kreslt = kasin(ncatma) IF ((ncatma==7 .OR. ncatma==9) .AND. krad==0) kreslt = 12 GO TO 60 END IF IF (kroutn=='FMACOS') THEN kreslt = kacos(ncatma) GO TO 60 END IF IF (kroutn=='FMATAN') THEN kreslt = katan(ncatma) IF ((ncatma==7 .OR. ncatma==9) .AND. krad==0) kreslt = 12 GO TO 60 END IF IF (kroutn=='FMSINH') THEN kreslt = ksinh(ncatma) GO TO 60 END IF IF (kroutn=='FMCOSH') THEN kreslt = kcosh(ncatma) GO TO 60 END IF IF (kroutn=='FMTANH') THEN kreslt = ktanh(ncatma) GO TO 60 END IF IF (kroutn=='FMLG10') THEN kreslt = klg10(ncatma) GO TO 60 END IF kreslt = 0 RETURN 60 IF (kreslt==12) THEN kflag = -4 CALL fmwarn END IF IF (kreslt==3 .OR. kreslt==4) THEN IF (ncatma==1 .OR. ncatma==7 .OR. ncatma==9 .OR. ncatma==15 .OR. & ncatmb==1 .OR. ncatmb==7 .OR. ncatmb==9 .OR. ncatmb==15) THEN kflag = -5 ELSE kflag = -5 CALL fmwarn END IF END IF IF (kreslt==5 .OR. kreslt==6) THEN IF (ncatma==1 .OR. ncatma==7 .OR. ncatma==9 .OR. ncatma==15 .OR. & ncatmb==1 .OR. ncatmb==7 .OR. ncatmb==9 .OR. ncatmb==15) THEN kflag = -6 ELSE kflag = -6 CALL fmwarn END IF END IF RETURN 90000 FORMAT (' NDIG was',I10,'. It has been changed to',I10,'.') 90010 FORMAT (' MBASE was',I10,'. It has been changed to',I10,'.') END SUBROUTINE fmargs SUBROUTINE fmasin(ma,mb) ! MB = ARCSIN(MA) IMPLICIT NONE ! Scratch array usage during FMASIN: M01 - M06 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, macmax, mxsave INTEGER :: k, kasave, kovun, kreslt, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmatan, fmcons, fmdiv, fmentr, fmeq2, fmexit, fmi2m, & fmmpy, fmntr, fmrslt, fmsqrt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(1)>0 .OR. ma(2)==0) THEN CALL fmentr('FMASIN',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMASIN' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52-1,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) ! Use ASIN(X) = ATAN(X/SQRT(1-X*X)) CALL fmi2m(1,m05) CALL fmsub(m05,mb,m03) CALL fmadd(m05,mb,m04) CALL fmmpy(m03,m04,m04) CALL fmsqrt(m04,m04) CALL fmdiv(mb,m04,mb) CALL fmatan(mb,mb) ! Round the result and return. macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmasin SUBROUTINE fmatan(ma,mb) ! MB = ARCTAN(MA) IMPLICIT NONE ! Scratch array usage during FMATAN: M01 - M06 ! .. Intrinsic Functions .. INTRINSIC abs, atan, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma1, ma2, macca, macmax, mxsave REAL (KIND(0.0D0)) :: x, xm INTEGER :: j, k, kasave, kovun, kreslt, krsave, kst, kwrnsv, ndsav1, & ndsave, ndsv ! .. ! .. Local Arrays .. INTEGER :: nstack(19) ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdig, fmdiv, fmdivi, fmdpm, fmentr, fmeq, & fmeq2, fmexit, fmi2m, fmm2dp, fmmpy, fmmpyi, fmntr, fmpi, fmrslt, & fmsin, fmsqr, fmsqrt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)==0) THEN CALL fmentr('FMATAN',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMATAN' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52-1,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) CALL fmeq2(ma,m05,ndsave,ndig,0) m05(0) = nint(ndig*alogm2) ! If MA.GE.1 work with 1/MA. ma1 = ma(1) ma2 = ma(2) m05(2) = abs(m05(2)) IF (ma1>=1) THEN CALL fmi2m(1,mb) CALL fmdiv(mb,m05,m05) END IF krsave = krad krad = 1 kwrnsv = kwarn x = m05(1) xm = mxbase ! In case pi has not been computed at the current precision ! and will be needed here, get it to full precision first ! to avoid repeated calls at increasing precision during ! Newton iteration. IF (ma1>=1 .OR. krsave==0) THEN IF (mbspi/=mbase .OR. ndigpi=1) THEN CALL fmdivi(mpisav,2,m06) CALL fmsub(m06,mb,mb) END IF ! Convert to degrees if necessary, round and return. krad = krsave IF (krad==0) THEN CALL fmmpyi(mb,180,mb) CALL fmdiv(mb,mpisav,mb) END IF IF (mb(1)/=munkno .AND. ma2<0) mb(2) = -mb(2) IF (kflag==1) kflag = 0 kwarn = kwrnsv macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmatan SUBROUTINE fmatn2(ma,mb,mc) ! MC = ATAN2(MA,MB) ! MC is returned as the angle between -pi and pi (or -180 and 180 if ! degree mode is selected) for which TAN(MC) = MA/MB. MC is an angle ! for the point (MB,MA) in polar coordinates. IMPLICIT NONE ! Scratch array usage during FMATN2: M01 - M06 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, maccb, macmax, mxexp1, mxsave INTEGER :: jquad, k, kasave, kovun, kreslt, kwrnsv, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmatan, fmcons, fmdiv, fmdivi, fmentr, fmeq2, fmexit, fmi2m, & fmim, fmntr, fmpi, fmrslt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. abs(mb(1))>mexpab) THEN CALL fmentr('FMATN2',ma,mb,2,mc,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMATN2' IF (ntrace/=0) CALL fmntr(2,ma,mb,2) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52-1,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,mb,mc,kreslt) IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF kwrnsv = kwarn kwarn = 0 macca = ma(0) maccb = mb(0) CALL fmeq2(ma,m01,ndsave,ndig,0) m01(0) = nint(ndig*alogm2) CALL fmeq2(mb,m02,ndsave,ndig,0) m02(0) = nint(ndig*alogm2) ! Check for special cases. IF (ma(1)==munkno .OR. mb(1)==munkno .OR. (ma(2)==0 .AND. mb(2)==0)) & THEN CALL fmim(0,mc) mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) kflag = -4 GO TO 10 END IF IF (mb(2)==0 .AND. ma(2)>0) THEN IF (krad==0) THEN CALL fmi2m(90,mc) ELSE CALL fmpi(mc) CALL fmdivi(mc,2,mc) END IF GO TO 10 END IF IF (mb(2)==0 .AND. ma(2)<0) THEN IF (krad==0) THEN CALL fmi2m(-90,mc) ELSE CALL fmpi(mc) CALL fmdivi(mc,-2,mc) END IF GO TO 10 END IF mxexp1 = int(mxexp2/2.01D0) IF (ma(1)==mexpov .AND. mb(1)=0 .AND. mb(2)>0) jquad = 1 IF (ma(2)>=0 .AND. mb(2)<0) jquad = 2 IF (ma(2)<0 .AND. mb(2)<0) jquad = 3 IF (ma(2)<0 .AND. mb(2)>0) jquad = 4 CALL fmdiv(m01,m02,mc) mc(2) = abs(mc(2)) CALL fmatan(mc,mc) IF (jquad==2 .OR. jquad==3) THEN IF (krad==0) THEN CALL fmi2m(180,m05) CALL fmsub(m05,mc,mc) ELSE CALL fmpi(m05) CALL fmsub(m05,mc,mc) END IF END IF IF ((jquad==3 .OR. jquad==4) .AND. mc(1)/=munkno) mc(2) = -mc(2) ! Round the result and return. 10 IF (kflag==1) kflag = 0 kwarn = kwrnsv macmax = nint((ndsave-1)*alogm2+log(real(abs(mc(2))+1))/0.69315) mc(0) = min(mc(0),macca,maccb,macmax) CALL fmexit(mc,mc,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmatn2 SUBROUTINE fmbig(ma) ! MA = The biggest representable FM number using the current base ! and precision. ! The smallest positive number is then 1.0/MA. ! Because of rounding, 1.0/(1.0/MA) will then overflow. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, n1 ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMBIG ' IF (mblogs/=mbase) CALL fmcons kflag = 0 n1 = ndig + 1 DO 10 j = 2, n1 ma(j) = mbase - 1 10 CONTINUE ma(1) = mxexp + 1 ma(0) = nint(ndig*alogm2) IF (ntrace/=0) CALL fmntr(1,ma,ma,1) ncall = ncall - 1 RETURN END SUBROUTINE fmbig SUBROUTINE fmcat(ma,ncat) ! NCAT is returned as the category of MA. This is used by the various ! arithmetic routines to handle special cases such as: ! 'number greater than 1' + 'underflowed result' is the first argument, ! 'overflowed result' / 'overflowed result' is 'unknown'. ! NCAT range ! 1. -OV OV stands for overflowed results. ! 2. (-OV , -OVTH) ( MA(1) .GE. MAXEXP+2 ) ! 3. (-OVTH , -1) ! 4. -1 OVTH stands for a representable ! 5. (-1 , -UNTH) number near the overflow ! 6. (-UNTH , -UN) threshold. ! 7. -UN ( MA(1) .GE. MAXEXP-NDIG+1 ) ! 8. 0 ! 9. +UN UN stands for underflowed results. ! 10. (+UN , +UNTH) ( MA(1) .LE. -MAXEXP-1 ) ! 11. (+UNTH , +1) ! 12. +1 UNTH stands for a representable ! 13. (+1 , +OVTH) number near the underflow ! 14. (+OVTH , +OV) threshold. ! 15. +OV ( MA(1) .LE. -MAXEXP+NDIG-1 ) ! 16. UNKNOWN IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ncat ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, mxexp1 INTEGER :: j, nlast ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! Check for special symbols. ncat = 16 IF (ma(1)==munkno) RETURN IF (ma(1)==mexpov) THEN ncat = 15 IF (ma(2)<0) ncat = 1 RETURN END IF IF (ma(1)==mexpun) THEN ncat = 9 IF (ma(2)<0) ncat = 7 RETURN END IF IF (ma(2)==0) THEN ncat = 8 RETURN END IF ! Check for +1 or -1. ma2 = abs(ma(2)) IF (ma(1)==1 .AND. ma2==1) THEN nlast = ndig + 1 IF (nlast>=3) THEN DO 10 j = 3, nlast IF (ma(j)/=0) GO TO 20 10 CONTINUE END IF ncat = 12 IF (ma(2)<0) ncat = 4 RETURN END IF 20 mxexp1 = int(mxexp2/2.01D0) IF (ma(1)>=mxexp1-ndig+1) THEN ncat = 14 IF (ma(2)<0) ncat = 2 RETURN END IF IF (ma(1)>=1) THEN ncat = 13 IF (ma(2)<0) ncat = 3 RETURN END IF IF (ma(1)>=-mxexp1+ndig) THEN ncat = 11 IF (ma(2)<0) ncat = 5 RETURN END IF IF (ma(1)>=-mxexp2) THEN ncat = 10 IF (ma(2)<0) ncat = 6 RETURN END IF RETURN END SUBROUTINE fmcat SUBROUTINE fmchsh(ma,mb,mc) ! MB = COSH(MA), MC = SINH(MA) ! If both the hyperbolic sine and cosine are needed, this routine ! is faster than calling both FMCOSH and FMSINH. ! MB and MC must be distinct arrays. IMPLICIT NONE ! Scratch array usage during FMCHSH: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, macmax, mxsave INTEGER :: k, kasave, kovun, kreslt, kwrnsv, ncsave, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmcosh, fmentr, fmeq, fmeq2, fmexit, fmi2m, & fmntr, fmntrj, fmprnt, fmsinh, fmsqr, fmsqrt ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons macca = ma(0) ma2 = ma(2) IF (abs(ma(1))>mexpab) THEN ncsave = ncall CALL fmentr('FMCHSH',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (ma(1)==munkno) kovun = 2 ncall = ncsave + 1 CALL fmeq(ma,m04) m04(0) = nint(ndig*alogm2) m04(2) = abs(m04(2)) CALL fmcosh(m04,mb) CALL fmsinh(m04,mc) GO TO 10 ELSE ncall = ncall + 1 namest(ncall) = 'FMCHSH' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN ncall = ncall - 1 ndig = ndsave CALL fmeq(ma,m04) CALL fmcosh(m04,mb) CALL fmsinh(m04,mc) kflag = -9 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF CALL fmeq2(ma,m04,ndsave,ndig,0) m04(0) = nint(ndig*alogm2) m04(2) = abs(m04(2)) k = 1 IF (m04(1)==0 .AND. m04(2)/=0) THEN IF (mbase/m04(2)>=100) k = 2 END IF IF (m04(1)>=0 .AND. m04(2)/=0 .AND. k==1) THEN CALL fmcosh(m04,mb) IF (mb(1)>ndig) THEN CALL fmeq(mb,mc) GO TO 10 END IF CALL fmsqr(mb,m03) CALL fmi2m(-1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,mc) ELSE CALL fmsinh(m04,mc) CALL fmsqr(mc,m03) CALL fmi2m(1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,mb) END IF ! Round and return. 10 macmax = nint((ndsave-1)*alogm2+log(real(abs(mc(2))+1))/0.69315) mc(0) = min(mc(0),macca,macmax) IF (ma2<0 .AND. mc(1)/=munkno) mc(2) = -mc(2) CALL fmeq2(mc,mc,ndig,ndsave,1) macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) IF (kovun==2) THEN kwrnsv = kwarn kwarn = 0 END IF CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) IF (kovun==2) THEN kwarn = kwrnsv END IF IF (ntrace/=0) THEN IF (abs(ntrace)>=1 .AND. ncall+1<=lvltrc) THEN IF (ntrace<0) THEN CALL fmntrj(mc,ndig) ELSE CALL fmprnt(mc) END IF END IF END IF RETURN END SUBROUTINE fmchsh FUNCTION fmcomp(ma,lrel,mb) ! Logical comparison of FM numbers MA and MB. ! LREL is a CHARACTER *2 description of the comparison to be done: ! LREL = 'EQ' returns FMCOMP = .TRUE. if MA.EQ.MB ! = 'NE', 'GE', 'GT', 'LE', 'LT' also work like a logical IF. ! For comparisons involving 'UNKNOWN' or two identical special symbols ! such as +OVERFLOW,'EQ',+OVERFLOW, FMCOMP is returned FALSE and a ! KFLAG = -4 error condition is returned. ! Some compilers object to functions with side effects such as ! changing KFLAG or other common variables. Blocks of code that ! modify common are identified by: ! C DELETE START ! ... ! C DELETE STOP ! These may be removed or commented out to produce a function without ! side effects. This disables trace printing in FMCOMP, and error ! codes are not returned in KFLAG. IMPLICIT NONE ! .. Function Return Value .. LOGICAL :: fmcomp ! .. ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (2) :: lrel ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, jcomp, nlast CHARACTER (2) :: jrel ! .. ! .. External Subroutines .. EXTERNAL fmntrj, fmprnt ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! DELETE START ncall = ncall + 1 namest(ncall) = 'FMCOMP' IF (ncall<=lvltrc .AND. abs(ntrace)>=2) THEN WRITE (kw,90000) IF (ntrace>0) THEN CALL fmprnt(ma) WRITE (kw,90010) lrel CALL fmprnt(mb) ELSE CALL fmntrj(ma,ndig) WRITE (kw,90010) lrel CALL fmntrj(mb,ndig) END IF END IF ! DELETE STOP ! JCOMP will be 1 if MA.GT.MB ! 2 if MA.EQ.MB ! 3 if MA.LT.MB ! Check for special cases. jrel = lrel IF (lrel/='EQ' .AND. lrel/='NE' .AND. lrel/='LT' .AND. lrel/='GT' .AND. & lrel/='LE' .AND. lrel/='GE') THEN IF (lrel=='eq') THEN jrel = 'EQ' ELSE IF (lrel=='ne') THEN jrel = 'NE' ELSE IF (lrel=='lt') THEN jrel = 'LT' ELSE IF (lrel=='gt') THEN jrel = 'GT' ELSE IF (lrel=='le') THEN jrel = 'LE' ELSE IF (lrel=='ge') THEN jrel = 'GE' ELSE fmcomp = .FALSE. ! DELETE START kflag = -4 IF (ncall/=1 .OR. kwarn<=0) GO TO 30 ! DELETE STOP IF (kwarn<=0) GO TO 30 WRITE (kw,90020) lrel IF (kwarn>=2) THEN STOP END IF GO TO 30 END IF END IF IF (ma(1)==munkno .OR. mb(1)==munkno) THEN fmcomp = .FALSE. ! DELETE START kflag = -4 ! DELETE STOP GO TO 30 END IF IF (abs(ma(1))==mexpov .AND. ma(1)==mb(1) .AND. ma(2)==mb(2)) THEN fmcomp = .FALSE. ! DELETE START kflag = -4 IF (ncall/=1 .OR. kwarn<=0) GO TO 30 ! DELETE STOP IF (kwarn<=0) GO TO 30 WRITE (kw,90030) IF (kwarn>=2) THEN STOP END IF GO TO 30 END IF ! Check for zero. ! DELETE START kflag = 0 ! DELETE STOP IF (ma(2)==0) THEN jcomp = 2 IF (mb(2)<0) jcomp = 1 IF (mb(2)>0) jcomp = 3 GO TO 20 END IF IF (mb(2)==0) THEN jcomp = 1 IF (ma(2)<0) jcomp = 3 GO TO 20 END IF ! Check for opposite signs. IF (ma(2)>0 .AND. mb(2)<0) THEN jcomp = 1 GO TO 20 END IF IF (mb(2)>0 .AND. ma(2)<0) THEN jcomp = 3 GO TO 20 END IF ! See which one is larger in absolute value. IF (ma(1)>mb(1)) THEN jcomp = 1 GO TO 20 END IF IF (mb(1)>ma(1)) THEN jcomp = 3 GO TO 20 END IF nlast = ndig + 1 DO 10 j = 2, nlast IF (abs(ma(j))>abs(mb(j))) THEN jcomp = 1 GO TO 20 END IF IF (abs(mb(j))>abs(ma(j))) THEN jcomp = 3 GO TO 20 END IF 10 CONTINUE jcomp = 2 ! Now match the JCOMP value to the requested comparison. 20 IF (jcomp==1 .AND. ma(2)<0) THEN jcomp = 3 ELSE IF (jcomp==3 .AND. mb(2)<0) THEN jcomp = 1 END IF fmcomp = .FALSE. IF (jcomp==1 .AND. (jrel=='GT' .OR. jrel=='GE' .OR. jrel=='NE')) & fmcomp = .TRUE. IF (jcomp==2 .AND. (jrel=='EQ' .OR. jrel=='GE' .OR. jrel=='LE')) & fmcomp = .TRUE. IF (jcomp==3 .AND. (jrel=='NE' .OR. jrel=='LT' .OR. jrel=='LE')) & fmcomp = .TRUE. 30 CONTINUE ! DELETE START IF (ntrace/=0) THEN IF (ncall<=lvltrc .AND. abs(ntrace)>=1) THEN IF (kflag==0) THEN WRITE (kw,90040) ncall, int(mbase), ndig ELSE WRITE (kw,90050) ncall, int(mbase), ndig, kflag END IF IF (fmcomp) THEN WRITE (kw,90060) ELSE WRITE (kw,90070) END IF END IF END IF ncall = ncall - 1 ! DELETE STOP RETURN 90000 FORMAT (' Input to FMCOMP') 90010 FORMAT (7X,'.',A2,'.') 90020 FORMAT (/' Error of type KFLAG = -4 in FM package in', & ' routine FMCOMP'//1X,A,' is not one of the six', & ' recognized comparisons.'//' .FALSE. has been',' returned.'/) 90030 FORMAT (/' Error of type KFLAG = -4 in FM package in routine', & ' FMCOMP'//' Two numbers in the same overflow or', & ' underflow category cannot be compared.'// & ' .FALSE. has been returned.'/) 90040 FORMAT (' FMCOMP',15X,'Call level =',I2,5X,'MBASE =',I10,5X,'NDIG =',I6) 90050 FORMAT (' FMCOMP',6X,'Call level =',I2,4X,'MBASE =',I10,4X,'NDIG =',I6, & 4X,'KFLAG =',I3) 90060 FORMAT (7X,'.TRUE.') 90070 FORMAT (7X,'.FALSE.') END FUNCTION fmcomp SUBROUTINE fmcons ! Set several saved machine precision constants. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC atan, dble, dint, int, log, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. mblogs = mbase alogmb = log(real(mbase)) alogm2 = alogmb/log(2.0) alogmx = log(real(maxint)) alogmt = alogmb/log(10.0) ngrd21 = int(2.0/alogmt+1.0) ngrd52 = int(5.0/alogmt+2.0) ngrd22 = int(2.0/alogmt+2.0) mexpab = dint(mxexp2/5) dlogmb = log(dble(mbase)) dlogtn = log(10.0D0) dlogtw = log(2.0D0) dppi = 4.0D0*atan(1.0D0) dlogtp = log(2.0D0*dppi) dlogpi = log(dppi) dlogeb = -log(dpeps)/dlogmb RETURN END SUBROUTINE fmcons SUBROUTINE fmcos(ma,mb) ! MB = COS(MA) IMPLICIT NONE ! Scratch array usage during FMCOS: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, macmax, mxsave INTEGER :: jcos, jsin, jswap, k, kasave, kovun, kreslt, ndsave, ndsv ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmcos2, fmdivi, fmentr, fmeq2, fmexit, fmi2m, fmmpy, & fmntr, fmpi, fmrdc, fmrslt, fmsin2, fmsqr, fmsqrt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)==0) THEN CALL fmentr('FMCOS ',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMCOS ' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) mb(2) = abs(mb(2)) ! Reduce the argument, convert to radians if the input is ! in degrees, and evaluate the function. CALL fmrdc(mb,mb,jsin,jcos,jswap) IF (mb(1)==munkno) GO TO 10 IF (krad==0) THEN IF (mbspi/=mbase .OR. ndigpindg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mb(j+1) = 0 10 CONTINUE ndig = ndsave kwarn = kwrnsv RETURN END IF ndsav1 = ndig ! Divide the argument by 2**K2. CALL fmeq2(ma,m02,ndsave,ndig,0) ktwo = 1 maxval = mxbase/2 IF (k2>0) THEN DO 20 j = 1, k2 ktwo = 2*ktwo IF (ktwo>maxval) THEN CALL fmdivi(m02,ktwo,m02) ktwo = 1 END IF 20 CONTINUE IF (ktwo>1) CALL fmdivi(m02,ktwo,m02) END IF ! Split into J2 concurrent sums and reduce NDIG while ! computing each term in the sum as the terms get smaller. CALL fmsqr(m02,m02) CALL fmeq(m02,m03) m03(2) = -m03(2) nterm = 2 DO 30 j = 1, j2 nbot = nterm*(nterm-1) CALL fmdivi(m03,nbot,m03) nterm = nterm + 2 kpt = (j-1)*(ndig+2) CALL fmeq(m03,mjsums(kpt)) m03(2) = -m03(2) 30 CONTINUE IF (m02(1)<-ndig) GO TO 60 CALL fmipwr(m02,j2,mb) 40 CALL fmmpy(m03,mb,m03) large = int(intmax/nterm) DO 50 j = 1, j2 nbot = nterm*(nterm-1) IF (nterm>large .OR. nbot>mxbase) THEN CALL fmdivi(m03,nterm,m03) nbot = nterm - 1 CALL fmdivi(m03,nbot,m03) ELSE CALL fmdivi(m03,nbot,m03) END IF kpt = (j-1)*(ndsav1+2) ndig = ndsav1 CALL fmadd(mjsums(kpt),m03,mjsums(kpt)) IF (kflag/=0) GO TO 60 ndig = ndsav1 - int(mjsums(kpt+1)-m03(1)) IF (ndig<2) ndig = 2 m03(2) = -m03(2) nterm = nterm + 2 50 CONTINUE GO TO 40 ! Next put the J2 separate sums back together. 60 kflag = 0 kpt = (j2-1)*(ndig+2) CALL fmeq(mjsums(kpt),mb) IF (j2>=2) THEN DO 70 j = 2, j2 CALL fmmpy(m02,mb,mb) kpt = (j2-j)*(ndig+2) CALL fmadd(mb,mjsums(kpt),mb) 70 CONTINUE END IF ! Reverse the effect of reducing the argument to ! compute COS(MA). ndig = ndsav1 IF (k2>0) THEN IF (ndsave<=20) THEN CALL fmi2m(2,m02) DO 80 j = 1, k2 CALL fmadd(mb,m02,m03) CALL fmmpy(mb,m03,m03) CALL fmadd(m03,m03,mb) 80 CONTINUE ELSE DO 90 j = 1, k2 CALL fmsqr(mb,m03) CALL fmadd(mb,mb,m02) CALL fmadd(m03,m02,m03) CALL fmadd(m03,m03,mb) 90 CONTINUE END IF END IF CALL fmi2m(1,m03) CALL fmadd(m03,mb,mb) CALL fmeq2(mb,mb,ndsav1,ndsave,1) ndig = ndsave kwarn = kwrnsv RETURN END SUBROUTINE fmcos2 SUBROUTINE fmcosh(ma,mb) ! MB = COSH(MA) IMPLICIT NONE ! Scratch array usage during FMCOSH: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, macmax, mxsave INTEGER :: k, kasave, kovun, kreslt, ndsave, nmethd ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmcsh2, fmdiv, fmdivi, fmentr, fmeq2, fmexit, & fmexp, fmi2m, fmntr, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab) THEN CALL fmentr('FMCOSH',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMCOSH' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) mb(2) = abs(mb(2)) IF (ma(2)==0) THEN CALL fmi2m(1,mb) GO TO 20 END IF ! Use a series for small arguments, FMEXP for large ones. IF (mb(1)==munkno) GO TO 20 IF (mbase>99) THEN IF (mb(1)<=0) THEN nmethd = 1 ELSE IF (mb(1)>=2) THEN nmethd = 2 ELSE IF (abs(mb(2))<10) THEN nmethd = 1 ELSE nmethd = 2 END IF ELSE IF (mb(1)<=0) THEN nmethd = 1 ELSE nmethd = 2 END IF END IF IF (nmethd==2) GO TO 10 CALL fmcsh2(mb,mb) GO TO 20 10 CALL fmexp(mb,mb) IF (mb(1)==mexpov) THEN GO TO 20 ELSE IF (mb(1)==mexpun) THEN mb(1) = mexpov GO TO 20 END IF IF (int(mb(1))<=(ndig+1)/2) THEN CALL fmi2m(1,m01) CALL fmdiv(m01,mb,m01) CALL fmadd(mb,m01,mb) END IF CALL fmdivi(mb,2,mb) ! Round and return. 20 macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmcosh SUBROUTINE fmcsh2(ma,mb) ! Internal subroutine for MB = COSH(MA). IMPLICIT NONE ! Scratch array usage during FMCSH2: M01 - M03 ! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent ! sums. Increasing this value will begin to improve the ! speed of COSH when the base is large and precision exceeds ! about 1,500 decimal digits. ! .. Intrinsic Functions .. INTRINSIC int, log, max, min, nint, real, sqrt ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL :: alog2, alogt, b, t, tj REAL (KIND(0.0D0)) :: maxval INTEGER :: j, j2, k, k2, kpt, ktwo, kwrnsv, l, l2, large, n2, nbot, & ndsav1, ndsave, nterm ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdivi, fmeq, fmeq2, fmi2m, fmipwr, fmmpy, & fmsqr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mjsums(0:ljsums), & mlbsav(0:lunpck), mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), & mln4(0:lunpck), mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmsums/mjsums COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (ma(2)==0) THEN CALL fmi2m(1,mb) RETURN END IF ndsave = ndig kwrnsv = kwarn kwarn = 0 ! Use the direct series ! COSH(X) = 1 + X**2/2! + X**4/4! - ... ! The argument will be divided by 2**K2 before the series ! is summed. The series will be added as J2 concurrent ! series. The approximately optimal values of K2 and J2 ! are now computed to try to minimize the time required. ! N2/2 is the approximate number of terms of the series ! that will be needed, and L2 guard digits will be carried. ! Since X is small when the series is summed, COSH(X) - 1 ! is computed. Then a version of the recovery formula can ! be used that does not suffer from severe cancellation. b = real(mbase) k = ngrd52 t = max(ndig-k,2) alog2 = log(2.0) alogt = log(t) tj = 0.03*alogmb*t**0.3333 + 1.85 j2 = int(tj) j2 = max(1,min(j2,ljsums/ndg2mx)) k2 = int(0.5*sqrt(t*alogmb/tj)+2.8) l = int(-(real(ma(1))*alogmb+log(real(ma(2))/b+ & real(ma(3))/(b*b)))/alog2-0.3) k2 = k2 - l IF (l<0) l = 0 IF (k2<0) THEN k2 = 0 j2 = int(.43*sqrt(t*alogmb/(alogt+real(l)*alog2))+.33) END IF IF (j2<=1) j2 = 1 n2 = int(t*alogmb/(alogt+real(l)*alog2)) l2 = int(log(real(n2)+2.0**k2)/alogmb) ndig = ndig + l2 IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mb(j+1) = 0 10 CONTINUE ndig = ndsave kwarn = kwrnsv RETURN END IF ndsav1 = ndig CALL fmeq2(ma,m02,ndsave,ndig,0) ! Divide the argument by 2**K2. ktwo = 1 maxval = mxbase/2 IF (k2>0) THEN DO 20 j = 1, k2 ktwo = 2*ktwo IF (ktwo>maxval) THEN CALL fmdivi(m02,ktwo,m02) ktwo = 1 END IF 20 CONTINUE IF (ktwo>1) CALL fmdivi(m02,ktwo,m02) END IF ! Split into J2 concurrent sums and reduce NDIG while ! computing each term in the sum as the terms get smaller. CALL fmsqr(m02,m02) CALL fmeq(m02,m03) nterm = 2 DO 30 j = 1, j2 nbot = nterm*(nterm-1) CALL fmdivi(m03,nbot,m03) nterm = nterm + 2 kpt = (j-1)*(ndig+2) CALL fmeq(m03,mjsums(kpt)) 30 CONTINUE IF (m02(1)<-ndig) GO TO 60 CALL fmipwr(m02,j2,mb) 40 CALL fmmpy(m03,mb,m03) large = int(intmax/nterm) DO 50 j = 1, j2 nbot = nterm*(nterm-1) IF (nterm>large .OR. nbot>mxbase) THEN CALL fmdivi(m03,nterm,m03) nbot = nterm - 1 CALL fmdivi(m03,nbot,m03) ELSE CALL fmdivi(m03,nbot,m03) END IF kpt = (j-1)*(ndsav1+2) ndig = ndsav1 CALL fmadd(mjsums(kpt),m03,mjsums(kpt)) IF (kflag/=0) GO TO 60 ndig = ndsav1 - int(mjsums(kpt+1)-m03(1)) IF (ndig<2) ndig = 2 nterm = nterm + 2 50 CONTINUE GO TO 40 ! Next put the J2 separate sums back together. 60 kflag = 0 kpt = (j2-1)*(ndig+2) CALL fmeq(mjsums(kpt),mb) IF (j2>=2) THEN DO 70 j = 2, j2 CALL fmmpy(m02,mb,mb) kpt = (j2-j)*(ndig+2) CALL fmadd(mb,mjsums(kpt),mb) 70 CONTINUE END IF ! Reverse the effect of reducing the argument to ! compute COSH(MA). ndig = ndsav1 IF (k2>0) THEN IF (ndsave<=20) THEN CALL fmi2m(2,m02) DO 80 j = 1, k2 CALL fmadd(mb,m02,m03) CALL fmmpy(mb,m03,m03) CALL fmadd(m03,m03,mb) 80 CONTINUE ELSE DO 90 j = 1, k2 CALL fmsqr(mb,m03) CALL fmadd(mb,mb,m02) CALL fmadd(m03,m02,m03) CALL fmadd(m03,m03,mb) 90 CONTINUE END IF END IF CALL fmi2m(1,m03) CALL fmadd(m03,mb,mb) CALL fmeq2(mb,mb,ndsav1,ndsave,1) ndig = ndsave kwarn = kwrnsv RETURN END SUBROUTINE fmcsh2 SUBROUTINE fmcssn(ma,mb,mc) ! MB = COS(MA), MC = SIN(MA) ! If both the sine and cosine are needed, this routine is faster ! than calling both FMCOS and FMSIN. ! MB and MC must be distinct arrays. IMPLICIT NONE ! Scratch array usage during FMCSSN: M01 - M05 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, macmax, mxsave INTEGER :: jcos, jsin, jswap, k, kasave, kovun, kreslt, kwrnsv, ncsave, & ndsave, ndsv ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmcos, fmcos2, fmdivi, fmentr, fmeq, fmeq2, fmexit, & fmi2m, fmmpy, fmntr, fmntrj, fmpi, fmprnt, fmrdc, fmsin, fmsin2, & fmsqr, fmsqrt, fmsub ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons macca = ma(0) ma2 = ma(2) IF (abs(ma(1))>mexpab .OR. ma(2)==0) THEN ncsave = ncall CALL fmentr('FMCSSN',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (ma(1)==munkno) kovun = 2 ncall = ncsave + 1 CALL fmeq(ma,m05) m05(0) = nint(ndig*alogm2) m05(2) = abs(m05(2)) CALL fmcos(m05,mb) CALL fmsin(m05,mc) GO TO 10 ELSE ncall = ncall + 1 namest(ncall) = 'FMCSSN' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN ncall = ncall - 1 ndig = ndsave CALL fmeq(ma,m05) CALL fmcos(m05,mb) CALL fmsin(m05,mc) kflag = -9 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF IF (ma(2)==0) THEN CALL fmi2m(1,mb) CALL fmi2m(0,mc) GO TO 10 END IF CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) mb(2) = abs(mb(2)) ! Reduce the argument, convert to radians if the input is ! in degrees, and evaluate the functions. CALL fmrdc(mb,mb,jsin,jcos,jswap) IF (mb(1)==munkno) THEN CALL fmeq(mb,mc) GO TO 10 END IF IF (krad==0) THEN IF (mbspi/=mbase .OR. ndigpi=1 .AND. ncall+1<=lvltrc) THEN IF (ntrace<0) THEN CALL fmntrj(mc,ndig) ELSE CALL fmprnt(mc) END IF END IF END IF RETURN END SUBROUTINE fmcssn SUBROUTINE fmdbl(a,b,c) ! C = A + B. All are double precision. This routine tries to ! force the compiler to round C to double precision accuracy. ! Some compilers allow double precision loops like the ones in ! FMSET and FMDM to be done in extended precision, which defeats ! the routine's attempt to determine double precision accuracy. ! This can lead to doing too few Newton steps and failing to ! get sufficient accuracy in several FM routines. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: a, b, c ! .. c = a + b RETURN END SUBROUTINE fmdbl SUBROUTINE fmdig(nstack,kst) ! Compute the number of intermediate digits to be used in Newton ! iteration. This assumes that a starting approximation that is ! accurate to double precision is used, and the root is simple. ! KST is the number of iterations needed for final accuracy NDIG. ! NSTACK(J) holds the value of NDIG to be used for the ! Jth iteration. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kst ! .. ! .. Array Arguments .. INTEGER :: nstack(19) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: y INTEGER :: j, jt, l, nd, ndt, ne ! .. ! .. External Subroutines .. EXTERNAL fmcons ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons ! NE is the maximum number of base MBASE digits that ! can be used in the first Newton iteration. ne = int(1.9D0*dlogeb) ! Fill the intermediate digit stack (backwards). kst = 1 nd = ndig nstack(1) = nd IF (ndne .AND. nd>2) GO TO 10 ! Reverse the stack. l = kst/2 DO 20 j = 1, l jt = nstack(j) nstack(j) = nstack(kst+1-j) nstack(kst+1-j) = jt 20 CONTINUE RETURN END SUBROUTINE fmdig SUBROUTINE fmdim(ma,mb,mc) ! MC = DIM(MA,MB) ! Positive difference. MC = MA - MB if MA.GE.MB, ! = 0 otherwise. IMPLICIT NONE ! Scratch array usage during FMDIM: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, maccb, macmax, mxsave INTEGER :: k, kasave, kovun, kreslt, kwrnsv, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmentr, fmeq2, fmexit, fmi2m, fmntr, fmrslt, fmsub, & fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. abs(mb(1))>mexpab) THEN CALL fmentr('FMDIM ',ma,mb,2,mc,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMDIM ' IF (ntrace/=0) CALL fmntr(2,ma,mb,2) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 IF (mb(1)==mexpov .OR. mb(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52-1,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,mb,mc,kreslt) IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw mxsave = mxexp mxexp = mxexp2 END IF kwrnsv = kwarn kwarn = 0 mxexp = mxsave macca = ma(0) maccb = mb(0) CALL fmeq2(ma,m01,ndsave,ndig,0) m01(0) = nint(ndig*alogm2) CALL fmeq2(mb,m02,ndsave,ndig,0) m02(0) = nint(ndig*alogm2) IF (fmcomp(m01,'LT',m02)) THEN CALL fmi2m(0,mc) ELSE CALL fmsub(m01,m02,mc) END IF IF (kflag==1) kflag = 0 kwarn = kwrnsv macmax = nint((ndsave-1)*alogm2+log(real(abs(mc(2))+1))/0.69315) mc(0) = min(mc(0),macca,maccb,macmax) CALL fmexit(mc,mc,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmdim SUBROUTINE fmdiv(ma,mb,mc) ! MC = MA / MB ! This routine performs the trace printing for division. ! FMDIV2 is used to do the arithmetic. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmdiv2, fmntr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMDIV ' CALL fmntr(2,ma,mb,2) CALL fmdiv2(ma,mb,mc) CALL fmntr(1,mc,mc,1) ELSE CALL fmdiv2(ma,mb,mc) END IF ncall = ncall - 1 RETURN END SUBROUTINE fmdiv SUBROUTINE fmdiv2(ma,mb,mc) ! Internal division routine. MC = MA / MB IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dble, dint, int, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, ma2p, macca, maccb, maxmwa, mb1, mb2, mb2p, mbm1, & mcarry, md2b, mkt, mlmax, mlr, mqd REAL (KIND(0.0D0)) :: xb, xbase, xbr, xmwa INTEGER :: j, jb, jl, ka, kb, kl, kptmwa, kreslt, n1, ng, nguard, nl, & nmbwds, nzdmb ! .. ! .. External Subroutines .. EXTERNAL fmargs, fmcons, fmim, fmmove, fmrnd, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons macca = ma(0) maccb = mb(0) IF (abs(ma(1))>mexpab .OR. abs(mb(1))>mexpab .OR. kdebug==1) THEN CALL fmargs('FMDIV ',2,ma,mb,kreslt) IF (kreslt/=0) THEN ncall = ncall + 1 namest(ncall) = 'FMDIV ' CALL fmrslt(ma,mb,mc,kreslt) ncall = ncall - 1 RETURN END IF ELSE IF (mb(2)==0) THEN CALL fmim(0,mc) mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) namest(ncall) = 'FMDIV ' kflag = -4 CALL fmwarn RETURN END IF IF (ma(2)==0) THEN CALL fmim(0,mc) mc(0) = min(macca,maccb) RETURN END IF END IF kflag = 0 ! NGUARD is the number of guard digits used. IF (ncall>1) THEN nguard = ngrd21 IF (nguard>ndig) nguard = ndig ELSE nguard = ngrd52 - 1 END IF ma2p = abs(ma(2)) mb2p = abs(mb(2)) n1 = ndig + 1 ng = ndig + nguard ! Copy MA into the working array. DO 10 j = 3, n1 mwa(j+1) = ma(j) 10 CONTINUE mwa(1) = ma(1) - mb(1) + 1 mwa(2) = 0 nl = n1 + nguard + 3 DO 20 j = ndig + 3, nl mwa(j) = 0 20 CONTINUE ! Save the sign of MA and MB and then work only with ! positive numbers. ma2 = ma(2) mb1 = mb(1) mb2 = mb(2) ma(2) = ma2p mwa(3) = ma(2) mb(1) = 0 mb(2) = mb2p ! NMBWDS is the number of words of MB used to ! compute the estimated quotient digit MQD. nmbwds = 4 IF (mbase<100) nmbwds = 7 ! XB is an approximation of MB used in ! estimating the quotient digits. xbase = dble(mbase) xb = 0 jl = nmbwds IF (jl<=n1) THEN DO 30 j = 2, jl xb = xb*xbase + dble(mb(j)) 30 CONTINUE ELSE DO 40 j = 2, jl IF (j<=n1) THEN xb = xb*xbase + dble(mb(j)) ELSE xb = xb*xbase END IF 40 CONTINUE END IF IF (jl+1<=n1) xb = xb + dble(mb(jl+1))/xbase xbr = 1.0D0/xb ! MLMAX determines when to normalize all of MWA. mbm1 = mbase - 1 mlmax = maxint/mbm1 mkt = intmax - mbase mlmax = min(mlmax,mkt) ! Count the trailing zero digits of MB. DO 50 j = n1, 2, -1 IF (mb(j)/=0) THEN nzdmb = n1 - j GO TO 60 END IF 50 CONTINUE ! MAXMWA is an upper bound on the size of values in MWA ! divided by MBASE-1. It is used to determine whether ! normalization can be postponed. 60 maxmwa = 0 ! KPTMWA points to the next digit in the quotient. kptmwa = 2 ! This is the start of the division loop. ! XMWA is an approximation of the active part of MWA ! used in estimating quotient digits. 70 kl = kptmwa + nmbwds - 1 IF (kl<=nl) THEN xmwa = ((dble(mwa(kptmwa))*xbase+dble(mwa(kptmwa+1)))*xbase+dble(mwa( & kptmwa+2)))*xbase + dble(mwa(kptmwa+3)) DO 80 j = kptmwa + 4, kl xmwa = xmwa*xbase + dble(mwa(j)) 80 CONTINUE ELSE xmwa = dble(mwa(kptmwa)) DO 90 j = kptmwa + 1, kl IF (j<=nl) THEN xmwa = xmwa*xbase + dble(mwa(j)) ELSE xmwa = xmwa*xbase END IF 90 CONTINUE END IF ! MQD is the estimated quotient digit. mqd = dint(xmwa*xbr) IF (mqd<0) mqd = mqd - 1 IF (mqd>0) THEN maxmwa = maxmwa + mqd ELSE maxmwa = maxmwa - mqd END IF ! See if MWA must be normalized. ka = kptmwa + 1 kb = min(ka+ndig-1-nzdmb,nl) IF (maxmwa>=mlmax) THEN DO 100 j = kb, ka, -1 IF (mwa(j)<0) THEN mcarry = int((-mwa(j)-1)/mbase) + 1 mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry ELSE IF (mwa(j)>=mbase) THEN mcarry = -int(mwa(j)/mbase) mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry END IF 100 CONTINUE xmwa = 0 IF (kl<=nl) THEN DO 110 j = kptmwa, kl xmwa = xmwa*xbase + dble(mwa(j)) 110 CONTINUE ELSE DO 120 j = kptmwa, kl IF (j<=nl) THEN xmwa = xmwa*xbase + dble(mwa(j)) ELSE xmwa = xmwa*xbase END IF 120 CONTINUE END IF mqd = dint(xmwa*xbr) IF (mqd<0) mqd = mqd - 1 IF (mqd>0) THEN maxmwa = mqd ELSE maxmwa = -mqd END IF END IF ! Subtract MQD*MB from MWA. jb = ka - 2 IF (mqd/=0) THEN ! Major (Inner Loop) DO 130 j = ka, kb mwa(j) = mwa(j) - mqd*mb(j-jb) 130 CONTINUE END IF mwa(ka) = mwa(ka) + mwa(ka-1)*mbase mwa(kptmwa) = mqd kptmwa = kptmwa + 1 IF (kptmwa<=ng) GO TO 70 IF (mwa(2)==0 .AND. kptmwa<=ng+1) GO TO 70 kl = kptmwa + nmbwds - 1 IF (kl<=nl) THEN xmwa = ((dble(mwa(kptmwa))*xbase+dble(mwa(kptmwa+1)))*xbase+dble(mwa( & kptmwa+2)))*xbase + dble(mwa(kptmwa+3)) DO 140 j = kptmwa + 4, kl xmwa = xmwa*xbase + dble(mwa(j)) 140 CONTINUE ELSE xmwa = dble(mwa(kptmwa)) DO 150 j = kptmwa + 1, kl IF (j<=nl) THEN xmwa = xmwa*xbase + dble(mwa(j)) ELSE xmwa = xmwa*xbase END IF 150 CONTINUE END IF mqd = dint(xmwa*xbr) IF (mqd<0) mqd = mqd - 1 mwa(kptmwa) = mqd mwa(kptmwa+1) = 0 mwa(kptmwa+2) = 0 ! Final normalization. DO 160 j = kptmwa, 3, -1 IF (mwa(j)<0) THEN mcarry = int((-mwa(j)-1)/mbase) + 1 mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry ELSE IF (mwa(j)>=mbase) THEN mcarry = -int(mwa(j)/mbase) mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry END IF 160 CONTINUE ! Round, affix the sign, and return. ma(2) = ma2 mb(1) = mb1 mb(2) = mb2 IF (mwa(2)==0) THEN mlr = 2*mwa(ndig+3) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwa(n1+1)1) THEN mwa(n1+1) = mwa(n1+1) + 1 mwa(n1+2) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,1) END IF END IF ELSE mlr = 2*mwa(ndig+2) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwa(n1)1) THEN mwa(n1) = mwa(n1) + 1 mwa(n1+1) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,0) END IF END IF END IF CALL fmmove(mwa,mc) IF (kflag<0) THEN namest(ncall) = 'FMDIV ' CALL fmwarn END IF IF (ma2*mb2<0) mc(2) = -mc(2) IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(mc(2))+1))/0.69315) mc(0) = min(macca,maccb,md2b) ELSE mc(0) = min(macca,maccb) END IF RETURN END SUBROUTINE fmdiv2 SUBROUTINE fmdivd(ma,mb,mc,md,me) ! Double division routine. MD = MA / MC, ME = MB / MC ! It is usually slightly faster to do two divisions that ! have a common denominator with one call. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dble, dint, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck), & me(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, ma2p, macca, maccb, maccc, maxmwa, mb2, mb2p, mbm1, & mc1, mc2, mc2p, mcarry, md2b, mkt, mlmax, mlr, mqdmwa, mqdmwd, mtemp REAL (KIND(0.0D0)) :: xb, xbase, xbr, xmwa, xmwd INTEGER :: j, jb, jl, ka, kb, kl, kovun, kptmw, n1, ng, nguard, nl, & nmbwds, nzdmb ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmdiv2, fmeq, fmim, fmmove, fmntr, fmntrj, fmprnt, & fmrnd, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa), mwd(lmwa), mwe(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /fmwa/mwd, mwe ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMDIVD' CALL fmntr(2,ma,mb,2) IF (abs(ntrace)>=2 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN CALL fmntrj(mc,ndig) ELSE CALL fmprnt(mc) END IF END IF END IF IF (mblogs/=mbase) CALL fmcons macca = ma(0) maccb = mb(0) maccc = mc(0) IF (abs(ma(1))>mexpab .OR. abs(mb(1))>mexpab .OR. abs(mc(1))>mexpab) & THEN kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun .OR. mb(1)==mexpov .OR. & mb(1)==mexpun .OR. mc(1)==mexpov .OR. mc(1)==mexpun) kovun = 1 IF (ma(1)==munkno .OR. mb(1)==munkno .OR. mc(1)==munkno) kovun = 2 ncall = ncall + 1 CALL fmdiv2(ma,mc,mwd) kb = kflag CALL fmdiv2(mb,mc,me) ncall = ncall - 1 IF (((kflag<0 .OR. kb<0) .AND. kovun==0) .OR. ((kflag==-4 .OR. kb== & -4) .AND. kovun==1)) THEN IF (kflag==-4 .OR. kb==-4) THEN kflag = -4 ELSE IF (kflag==-5 .OR. kb==-5) THEN kflag = -5 ELSE kflag = min(kflag,kb) END IF namest(ncall) = 'FMDIVD' CALL fmwarn END IF CALL fmeq(mwd,md) GO TO 170 END IF IF (mc(2)==0) THEN CALL fmim(0,md) md(1) = munkno md(2) = 1 md(0) = nint(ndig*alogm2) CALL fmim(0,me) me(1) = munkno me(2) = 1 me(0) = nint(ndig*alogm2) namest(ncall) = 'FMDIVD' kflag = -4 CALL fmwarn GO TO 170 END IF IF (ma(2)==0 .OR. mb(2)==0) THEN CALL fmdiv2(ma,mc,mwd) CALL fmdiv2(mb,mc,me) CALL fmeq(mwd,md) GO TO 170 END IF kflag = 0 ! NGUARD is the number of guard digits used. IF (ncall>1) THEN nguard = ngrd21 IF (nguard>ndig) nguard = ndig ELSE nguard = ngrd52 - 1 END IF ma2p = abs(ma(2)) mb2p = abs(mb(2)) mc2p = abs(mc(2)) IF ((mc2p>=ma2p .OR. mc2p>=mb2p) .AND. nguard<2) nguard = 2 n1 = ndig + 1 ng = ndig + nguard ! Copy MA and MB into the working arrays. DO 10 j = 3, n1 mwa(j+1) = ma(j) mwd(j+1) = mb(j) 10 CONTINUE mwa(1) = ma(1) - mc(1) + 1 mwd(1) = mb(1) - mc(1) + 1 mwa(2) = 0 mwd(2) = 0 nl = n1 + nguard + 3 DO 20 j = ndig + 3, nl mwa(j) = 0 mwd(j) = 0 20 CONTINUE ! Save the signs and then work only with ! positive numbers. ma2 = ma(2) mb2 = mb(2) mc1 = mc(1) mc2 = mc(2) ma(2) = ma2p mb(2) = mb2p mwa(3) = ma(2) mwd(3) = mb(2) mc(1) = 0 mc(2) = mc2p ! NMBWDS is the number of words used to compute ! the estimated quotient digits. nmbwds = 4 IF (mbase<100) nmbwds = 7 ! XB is an approximation of MC used in selecting ! estimated quotients. xbase = dble(mbase) xb = 0 jl = nmbwds IF (jl<=n1) THEN DO 30 j = 2, jl xb = xb*xbase + dble(mc(j)) 30 CONTINUE ELSE DO 40 j = 2, jl IF (j<=n1) THEN xb = xb*xbase + dble(mc(j)) ELSE xb = xb*xbase END IF 40 CONTINUE END IF IF (jl+1<=n1) xb = xb + dble(mc(jl+1))/xbase xbr = 1.0D0/xb ! MLMAX determines when to normalize all of MWA. mbm1 = mbase - 1 mlmax = maxint/mbm1 mkt = intmax - mbase mlmax = min(mlmax,mkt) ! Count the trailing zero digits of MC. DO 50 j = n1, 2, -1 IF (mc(j)/=0) THEN nzdmb = n1 - j GO TO 60 END IF 50 CONTINUE ! MAXMWA is an upper bound on the size of values in MWA ! divided by MBASE-1. It is used to determine whether ! normalization can be postponed. 60 maxmwa = 0 ! KPTMW points to the next digit in the quotient. kptmw = 2 ! This is the start of the division loop. ! XMWA is an approximation of the active part of MWA ! used in selecting estimated quotients. 70 kl = kptmw + nmbwds - 1 IF (kl<=nl) THEN xmwa = ((dble(mwa(kptmw))*xbase+dble(mwa(kptmw+1)))*xbase+dble(mwa( & kptmw+2)))*xbase + dble(mwa(kptmw+3)) xmwd = ((dble(mwd(kptmw))*xbase+dble(mwd(kptmw+1)))*xbase+dble(mwd( & kptmw+2)))*xbase + dble(mwd(kptmw+3)) DO 80 j = kptmw + 4, kl xmwa = xmwa*xbase + dble(mwa(j)) xmwd = xmwd*xbase + dble(mwd(j)) 80 CONTINUE ELSE xmwa = dble(mwa(kptmw)) xmwd = dble(mwd(kptmw)) DO 90 j = kptmw + 1, kl IF (j<=nl) THEN xmwa = xmwa*xbase + dble(mwa(j)) xmwd = xmwd*xbase + dble(mwd(j)) ELSE xmwa = xmwa*xbase xmwd = xmwd*xbase END IF 90 CONTINUE END IF ! MQDMWA and MQDMWD are the estimated quotient digits. mqdmwa = dint(xmwa*xbr) IF (mqdmwa<0) mqdmwa = mqdmwa - 1 mqdmwd = dint(xmwd*xbr) IF (mqdmwd<0) mqdmwd = mqdmwd - 1 maxmwa = maxmwa + max(abs(mqdmwa),abs(mqdmwd)) ! See if MWA and MWD must be normalized. ka = kptmw + 1 kb = min(ka+ndig-1-nzdmb,nl) IF (maxmwa>=mlmax) THEN DO 100 j = kb, ka, -1 IF (mwa(j)<0) THEN mcarry = int((-mwa(j)-1)/mbase) + 1 mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry ELSE IF (mwa(j)>=mbase) THEN mcarry = -int(mwa(j)/mbase) mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry END IF IF (mwd(j)<0) THEN mcarry = int((-mwd(j)-1)/mbase) + 1 mwd(j) = mwd(j) + mcarry*mbase mwd(j-1) = mwd(j-1) - mcarry ELSE IF (mwd(j)>=mbase) THEN mcarry = -int(mwd(j)/mbase) mwd(j) = mwd(j) + mcarry*mbase mwd(j-1) = mwd(j-1) - mcarry END IF 100 CONTINUE xmwa = 0 xmwd = 0 IF (kl<=nl) THEN DO 110 j = kptmw, kl xmwa = xmwa*xbase + dble(mwa(j)) xmwd = xmwd*xbase + dble(mwd(j)) 110 CONTINUE ELSE DO 120 j = kptmw, kl IF (j<=nl) THEN xmwa = xmwa*xbase + dble(mwa(j)) xmwd = xmwd*xbase + dble(mwd(j)) ELSE xmwa = xmwa*xbase xmwd = xmwd*xbase END IF 120 CONTINUE END IF mqdmwa = dint(xmwa*xbr) IF (mqdmwa<0) mqdmwa = mqdmwa - 1 mqdmwd = dint(xmwd*xbr) IF (mqdmwd<0) mqdmwd = mqdmwd - 1 maxmwa = max(abs(mqdmwa),abs(mqdmwd)) END IF ! Subtract MQDMWA*MC from MWA and MQDMWD*MC from MWD. jb = ka - 2 ! Major (Inner Loop) DO 130 j = ka, kb mtemp = mc(j-jb) mwa(j) = mwa(j) - mqdmwa*mtemp mwd(j) = mwd(j) - mqdmwd*mtemp 130 CONTINUE mwa(ka) = mwa(ka) + mwa(ka-1)*mbase mwd(ka) = mwd(ka) + mwd(ka-1)*mbase mwa(kptmw) = mqdmwa mwd(kptmw) = mqdmwd kptmw = kptmw + 1 IF (kptmw<=ng) GO TO 70 kl = kptmw + nmbwds - 1 IF (kl<=nl) THEN xmwa = ((dble(mwa(kptmw))*xbase+dble(mwa(kptmw+1)))*xbase+dble(mwa( & kptmw+2)))*xbase + dble(mwa(kptmw+3)) xmwd = ((dble(mwd(kptmw))*xbase+dble(mwd(kptmw+1)))*xbase+dble(mwd( & kptmw+2)))*xbase + dble(mwd(kptmw+3)) DO 140 j = kptmw + 4, kl xmwa = xmwa*xbase + dble(mwa(j)) xmwd = xmwd*xbase + dble(mwd(j)) 140 CONTINUE ELSE xmwa = dble(mwa(kptmw)) xmwd = dble(mwd(kptmw)) DO 150 j = kptmw + 1, kl IF (j<=nl) THEN xmwa = xmwa*xbase + dble(mwa(j)) xmwd = xmwd*xbase + dble(mwd(j)) ELSE xmwa = xmwa*xbase xmwd = xmwd*xbase END IF 150 CONTINUE END IF mqdmwa = dint(xmwa*xbr) IF (mqdmwa<0) mqdmwa = mqdmwa - 1 mqdmwd = dint(xmwd*xbr) IF (mqdmwd<0) mqdmwd = mqdmwd - 1 mwa(kptmw) = mqdmwa mwa(kptmw+1) = 0 mwa(kptmw+2) = 0 mwd(kptmw) = mqdmwd mwd(kptmw+1) = 0 mwd(kptmw+2) = 0 ! Final normalization. DO 160 j = kptmw - 1, 3, -1 IF (mwa(j)<0) THEN mcarry = int((-mwa(j)-1)/mbase) + 1 mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry ELSE IF (mwa(j)>=mbase) THEN mcarry = -int(mwa(j)/mbase) mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry END IF IF (mwd(j)<0) THEN mcarry = int((-mwd(j)-1)/mbase) + 1 mwd(j) = mwd(j) + mcarry*mbase mwd(j-1) = mwd(j-1) - mcarry ELSE IF (mwd(j)>=mbase) THEN mcarry = -int(mwd(j)/mbase) mwd(j) = mwd(j) + mcarry*mbase mwd(j-1) = mwd(j-1) - mcarry END IF 160 CONTINUE ! Round, affix the sign, and return. ma(2) = ma2 mb(2) = mb2 mc(1) = mc1 mc(2) = mc2 IF (mwa(2)==0) THEN mlr = 2*mwa(ndig+3) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwa(n1+1)1) THEN mwa(n1+1) = mwa(n1+1) + 1 mwa(n1+2) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,1) END IF END IF ELSE mlr = 2*mwa(ndig+2) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwa(n1)1) THEN mwa(n1) = mwa(n1) + 1 mwa(n1+1) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,0) END IF END IF END IF CALL fmmove(mwa,md) IF (mwd(2)==0) THEN mlr = 2*mwd(ndig+3) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwd(n1+1)1) THEN mwd(n1+1) = mwd(n1+1) + 1 mwd(n1+2) = 0 END IF ELSE CALL fmrnd(mwd,ndig,nguard,1) END IF END IF ELSE mlr = 2*mwd(ndig+2) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwd(n1)1) THEN mwd(n1) = mwd(n1) + 1 mwd(n1+1) = 0 END IF ELSE CALL fmrnd(mwd,ndig,nguard,0) END IF END IF END IF CALL fmmove(mwd,me) IF (kflag<0) THEN namest(ncall) = 'FMDIVD' CALL fmwarn END IF IF (ma2*mc2<0) md(2) = -md(2) IF (mb2*mc2<0) me(2) = -me(2) IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(md(2))+1))/0.69315) md(0) = min(macca,maccc,md2b) md2b = nint((ndig-1)*alogm2+log(real(abs(me(2))+1))/0.69315) me(0) = min(maccb,maccc,md2b) ELSE md(0) = min(macca,maccc) me(0) = min(maccb,maccc) END IF 170 IF (ntrace/=0) THEN CALL fmntr(1,md,md,1) IF (abs(ntrace)>=1 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN CALL fmntrj(me,ndig) ELSE CALL fmprnt(me) END IF END IF END IF ncall = ncall - 1 RETURN END SUBROUTINE fmdivd SUBROUTINE fmdivi(ma,ival,mb) ! MB = MA / IVAL ! Divide FM number MA by one word integer IVAL. ! This routine is faster than FMDIV when the divisor is less than ! MXBASE (the square root of the largest integer). ! When IVAL is not less than MXBASE, FMDIV2 is used. In this case, ! if IVAL is known to be a product of two integers less than ! MXBASE, it is usually faster to make two calls to FMDIVI with ! half-word factors than one call with their product. IMPLICIT NONE ! Scratch array usage during FMDIVI: M01 ! .. Intrinsic Functions .. INTRINSIC abs, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, md2b ! .. ! .. External Subroutines .. EXTERNAL fmdivn, fmntr, fmntri ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 macca = ma(0) ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMDIVI' CALL fmntr(2,ma,ma,1) CALL fmntri(2,ival,0) CALL fmdivn(ma,ival,mb) IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(macca,md2b) ELSE mb(0) = macca END IF CALL fmntr(1,mb,mb,1) ELSE CALL fmdivn(ma,ival,mb) IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(macca,md2b) ELSE mb(0) = macca END IF END IF ncall = ncall - 1 RETURN END SUBROUTINE fmdivi SUBROUTINE fmdivn(ma,ival,mb) ! Internal divide by integer routine. MB = MA / IVAL IMPLICIT NONE ! Scratch array usage during FMDIVN: M01 ! .. Intrinsic Functions .. INTRINSIC abs, int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma1, ma2, mkt, mlr, modint, mvalp INTEGER :: j, ka, kb, kl, kpt, kptwa, n1, nguard, nmval, nv2 ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmdiv2, fmeq, fmim, fmmove, fmrnd, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! Check for special cases. IF (mblogs/=mbase) CALL fmcons n1 = ndig + 1 IF (ma(1)==munkno .OR. ival==0) THEN ma1 = ma(1) CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -4 IF (ma1/=munkno) THEN namest(ncall) = 'FMDIVI' CALL fmwarn END IF RETURN END IF IF (ma(2)==0) THEN CALL fmeq(ma,mb) RETURN END IF IF (abs(ma(1))1) GO TO 20 IF (abs(ival)==1) THEN DO 10 j = 0, n1 mb(j) = ma(j) 10 CONTINUE mb(2) = ma(2)*ival IF (ma(1)==mexpov) kflag = -5 IF (ma(1)==mexpun) kflag = -6 RETURN END IF IF (ma(1)==mexpun) THEN ma2 = ma(2) CALL fmim(0,mb) mb(1) = mexpun mb(2) = 1 IF ((ma2<0 .AND. ival>0) .OR. (ma2>0 .AND. ival<0)) mb(2) = -1 mb(0) = nint(ndig*alogm2) kflag = -6 RETURN END IF IF (ma(1)==mexpov) THEN CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) namest(ncall) = 'FMDIVI' kflag = -4 CALL fmwarn RETURN END IF ! NGUARD is the number of guard digits used. 20 IF (ncall>1) THEN nguard = ngrd21 ELSE nguard = ngrd52 END IF ! If ABS(IVAL).GE.MXBASE use FMDIV. mvalp = abs(ival) nmval = int(mvalp) nv2 = nmval - 1 IF (abs(ival)>mxbase .OR. nmval/=abs(ival) .OR. nv2/=abs(ival)-1) THEN CALL fmim(ival,m01) CALL fmdiv2(ma,m01,mb) RETURN END IF ! Work with positive numbers. ma2 = ma(2) ma(2) = abs(ma(2)) ! Find the first significant digit of the quotient. mkt = ma(2) IF (mkt>=mvalp) THEN kpt = 2 GO TO 50 END IF DO 30 j = 3, n1 mkt = mkt*mbase + ma(j) IF (mkt>=mvalp) THEN kpt = j GO TO 50 END IF 30 CONTINUE kpt = n1 40 kpt = kpt + 1 mkt = mkt*mbase IF (mkt=mbase) THEN IF (mlr-1>mbase .AND. mwa(n1)1) THEN mwa(n1) = mwa(n1) + 1 mwa(n1+1) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,0) END IF END IF CALL fmmove(mwa,mb) IF (kflag<0) THEN namest(ncall) = 'FMDIVI' CALL fmwarn END IF IF ((ma2<0 .AND. ival>0) .OR. (ma2>0 .AND. ival<0)) mb(2) = -mb(2) RETURN END SUBROUTINE fmdivn SUBROUTINE fmdm(x,ma) ! Internal routine for converting double precision to multiple ! precision. Called by FMDPM. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, min, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mk, mn REAL (KIND(0.0D0)) :: one, xbase, y, yt INTEGER :: j, k, n1, ne ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmdbl, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons kflag = 0 n1 = ndig + 1 one = 1.0D0 xbase = mbase k = 0 ! NE-1 is the number of words at the current precision and ! base roughly equal to machine precision. ne = int(dlogeb) + 3 y = x IF (x<0.0) y = -x IF (x==0.0) THEN DO 10 j = 1, n1 ma(j) = 0 10 CONTINUE GO TO 140 END IF ! Get the exponent. IF (y>one) THEN IF (y/xbaseone) GO TO 20 IF (yy) THEN 40 k = k - 1 y = y*xbase IF (yone) THEN k = k + 1 y = y/xbase ma(1) = k GO TO 80 END IF ELSE DO 50 j = 1, ndig + 1 ma(j) = 0 50 CONTINUE ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) kflag = -4 CALL fmwarn RETURN END IF END IF 60 ma(1) = k + 1 ma(2) = 1 DO 70 j = 3, n1 ma(j) = 0 70 CONTINUE GO TO 140 ! Build the rest of the number. 80 DO 90 j = 2, ne y = y*xbase mk = dint(y) yt = -mk CALL fmdbl(y,yt,y) ma(j) = mk IF (j>=n1) GO TO 110 90 CONTINUE k = ne + 1 DO 100 j = k, n1 ma(j) = 0 100 CONTINUE ! Normalize. 110 IF (abs(ma(2))>=mbase) THEN k = n1 + 1 DO 120 j = 3, n1 k = k - 1 ma(k) = ma(k-1) 120 CONTINUE mn = dint(ma(2)/mbase) ma(3) = ma(2) - mn*mbase ma(2) = mn ma(1) = ma(1) + 1 GO TO 140 END IF IF (ma(2)==0) THEN DO 130 j = 2, ndig ma(j) = ma(j+1) 130 CONTINUE ma(1) = ma(1) - 1 ma(n1) = 0 END IF 140 IF (x<0.0) ma(2) = -ma(2) ma(0) = min(nint((ne-1)*alogm2),nint(ndig*alogm2)) RETURN END SUBROUTINE fmdm SUBROUTINE fmdm2(x,ma) ! Internal routine for converting double precision to multiple ! precision. Called by FMDP2M. IMPLICIT NONE ! Scratch array usage during FMDM2: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC abs, dble, int, log, max, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: two20, y INTEGER :: j, jexp, k, kexp, kreslt, n1, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmi2m, fmipwr, fmmpy, fmntr, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! Increase the working precision. ndsave = ndig IF (ncall==1) THEN k = max(ngrd21,1) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,ma,kreslt) IF (ntrace/=0) CALL fmntr(1,ma,ma,1) ncall = ncall - 1 RETURN END IF END IF IF (mblogs/=mbase) CALL fmcons kflag = 0 n1 = ndig + 1 IF (x==0.0D0) THEN DO 10 j = 1, n1 ma(j) = 0 10 CONTINUE GO TO 60 END IF y = abs(x) two20 = 1048576.0D0 ! If this power of two is not representable at the current ! base and precision, use a smaller one. IF (int(ndig*alogm2)<20) THEN k = int(ndig*alogm2) two20 = 1.0D0 DO 20 j = 1, k two20 = two20*2.0D0 20 CONTINUE END IF kexp = 0 IF (y>two20) THEN 30 y = y/two20 kexp = kexp + 1 IF (y>two20) GO TO 30 ELSE IF (y<1.0D0) THEN 40 y = y*two20 kexp = kexp - 1 IF (y<1.0D0) GO TO 40 END IF k = int(two20) CALL fmi2m(k,m04) k = int(y) CALL fmi2m(k,m02) y = (y-dble(k))*two20 jexp = 0 50 k = int(y) CALL fmi2m(k,m03) CALL fmmpy(m02,m04,m02) jexp = jexp + 1 CALL fmadd(m02,m03,m02) y = (y-dble(k))*two20 IF (jexp<=1000 .AND. y/=0.0D0) GO TO 50 k = kexp - jexp CALL fmipwr(m04,k,m03) CALL fmmpy(m02,m03,ma) 60 IF (x<0.0) ma(2) = -ma(2) ma(0) = nint((ndsave-1)*alogm2+log(real(abs(ma(2))+1))/0.69315) ndig = ndsave RETURN END SUBROUTINE fmdm2 SUBROUTINE fmdp2m(x,ma) ! MA = X ! Convert a double precision floating point number to FM format. ! This version tries to convert the double precision machine ! number to FM with accuracy of nearly full FM precision. ! If conversion to FM with approximately double precision accuracy ! is good enough, FMDPM is faster and uses less scratch space. ! This routine assumes the machine's base for double precision is ! a power of two. IMPLICIT NONE ! Scratch array usage during FMDP2M: M01 - M04 ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmdm2, fmntr, fmntrr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMDP2M' IF (ntrace/=0) CALL fmntrr(2,x,1) CALL fmdm2(x,ma) IF (ntrace/=0) CALL fmntr(1,ma,ma,1) ncall = ncall - 1 RETURN END SUBROUTINE fmdp2m SUBROUTINE fmdpm(x,ma) ! MA = X ! Convert a double precision floating point number to FM format. ! In general, the relative accuracy of the FM number returned is only ! the relative accuracy of a machine precision number. This may be ! true even if X can be represented exactly in the machine floating ! point number system. ! This version is faster than FMDP2M, but often less accurate. ! No scratch arrays are used. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: y, yt INTEGER :: k ! .. ! .. External Subroutines .. EXTERNAL fmdivi, fmdm, fmim, fmntr, fmntrr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMDPM ' IF (ntrace/=0) CALL fmntrr(2,x,1) ! Check to see if X is exactly a small integer. If so, ! converting as an integer is better. ! Also see if X is exactly a small integer divided by ! a small power of two. y = 1048576.0D0 IF (abs(x)ndg2mx) THEN kflag = -9 CALL fmwarn kreslt = 12 ndig = ndsave END IF END IF IF (kreslt/=0) THEN maccab = ma(0) IF (nargs==2) maccab = min(maccab,mb(0)) IF (kreslt==9 .OR. kreslt==10 .OR. kreslt>=13) THEN IF (krad==1) THEN CALL fmpi(mc) ELSE CALL fmi2m(180,mc) END IF IF (kreslt<=10) CALL fmdivi(mc,2,mc) IF (kreslt>=14) CALL fmdivi(mc,4,mc) CALL fmeq2(mc,mc,ndig,ndsave,1) ndig = ndsave IF (kreslt==9 .OR. kreslt==14) mc(2) = -mc(2) mc(0) = maccab IF (ntrace/=0) CALL fmntr(1,mc,mc,1) kasave = kaccsw mxsave = mxexp ncall = ncall - 1 RETURN END IF ndig = ndsave CALL fmrslt(ma,mb,mc,kreslt) IF (ntrace/=0) CALL fmntr(1,mc,mc,1) kasave = kaccsw mxsave = mxexp ncall = ncall - 1 RETURN END IF kasave = kaccsw kaccsw = 0 ! Extend the overflow/underflow threshold. mxsave = mxexp mxexp = mxexp2 RETURN END SUBROUTINE fmentr SUBROUTINE fmeq(ma,mb) ! MB = MA ! This is the standard form of equality, where MA and MB both ! have precision NDIG. Use FMEQU for assignments that also ! change precision. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j ! .. ! .. External Subroutines .. EXTERNAL fmtrap ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. DO 10 j = 0, ndig + 1 mb(j) = ma(j) 10 CONTINUE ! Check for overflow or underflow. IF (abs(mb(1))>mxexp) THEN IF (mb(1)/=munkno .OR. mb(2)/=1) THEN ncall = ncall + 1 CALL fmtrap(mb) ncall = ncall - 1 END IF IF (mb(1)==munkno) kflag = -4 END IF RETURN END SUBROUTINE fmeq SUBROUTINE fmeq2(ma,mb,nda,ndb,ksame) ! Set MB (having NDB digits) equal to MA (having NDA digits). ! If MA and MB are the same array, setting KSAME = 1 before calling ! FMEQ2 gives faster performance. ! If MB has less precision than MA the result is rounded to NDB digits. ! If MB has more precision the result has zero digits padded on the ! right. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ksame, nda, ndb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: m2, macca, mb2, mkt INTEGER :: j, jt, k, kb, l, n1, ndg ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmtrap, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons macca = ma(0) ! Check for precision in range. IF (nda<1 .OR. nda>ndg2mx .OR. ndb<1 .OR. ndb>ndg2mx) THEN ncall = ncall + 1 namest(ncall) = 'FMEQU ' kflag = -1 CALL fmwarn WRITE (kw,90000) nda, ndb DO 10 j = 1, ndig + 1 mb(j) = 0 10 CONTINUE mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) ncall = ncall - 1 RETURN END IF ! Check for special symbols. kflag = 0 IF (abs(ma(1))>=mexpov) THEN DO 20 j = 2, ndb mb(j+1) = 0 20 CONTINUE mb(1) = ma(1) mb(2) = ma(2) GO TO 150 END IF IF (ndb==nda) GO TO 100 IF (ndb>nda) GO TO 120 ! Round to NDB digits. ndg = ndb n1 = ndb + 1 IF (ksame/=1) THEN DO 30 j = 1, n1 mb(j) = ma(j) 30 CONTINUE END IF IF (ndg<1 .OR. (kround==0 .AND. ncall<=1)) GO TO 150 l = ndb + 2 IF (2*(ma(l)+1)0) GO TO 60 40 CONTINUE END IF ! Round to even. IF (int(mb(n1)-dint(mb(n1)/m2)*m2)==0) GO TO 150 END IF ELSE IF (2*ma(l)+1==mbase) THEN IF (l<=nda) THEN DO 50 j = l, nda IF (2*(ma(j+1)+1)mbase) GO TO 60 50 CONTINUE GO TO 150 END IF END IF END IF 60 mb(ndg+1) = mb(ndg+1) + 1 mb(ndg+2) = 0 ! Check whether there was a carry in the rounded digit. mb2 = mb(2) mb(2) = abs(mb(2)) kb = ndg + 1 IF (kb>=3) THEN k = kb + 1 DO 70 j = 3, kb k = k - 1 IF (mb(k)=4) THEN k = kb + 1 DO 80 j = 4, kb k = k - 1 mb(k) = mb(k-1) 80 CONTINUE END IF mkt = dint(mb(2)/mbase) IF (kb>=3) mb(3) = mb(2) - mkt*mbase mb(2) = mkt mb(1) = mb(1) + 1 90 IF (mb2<0) mb(2) = -mb(2) GO TO 150 ! MA and MB have the same precision. 100 IF (ksame/=1) THEN DO 110 j = 1, nda + 1 mb(j) = ma(j) 110 CONTINUE END IF GO TO 150 ! Extend to NDB digits by padding with zeros. 120 IF (ksame/=1) THEN DO 130 j = 1, nda + 1 mb(j) = ma(j) 130 CONTINUE END IF DO 140 j = nda + 2, ndb + 1 mb(j) = 0 140 CONTINUE ! Check for overflow or underflow. 150 IF (abs(mb(1))>mxexp) THEN IF (mb(1)/=munkno .OR. mb(2)/=1) THEN ncall = ncall + 1 CALL fmtrap(mb) ncall = ncall - 1 END IF IF (mb(1)==munkno) kflag = -4 END IF IF (kaccsw==1) THEN jt = nint(log(real(abs(mb(2))+1))/0.69315) IF (ndb>nda) THEN mb(0) = nint((ndb-1)*alogm2+jt) ELSE mb(0) = min(nint((ndb-1)*alogm2+jt),int(macca)) END IF ELSE mb(0) = ma(0) END IF RETURN 90000 FORMAT (/' The two precisions in FMEQU were NDA =',I10,' NDB =',I10/) END SUBROUTINE fmeq2 SUBROUTINE fmequ(ma,mb,nda,ndb) ! Set MB (having NDB digits) equal to MA (having NDA digits). ! If MB has less precision than MA, the result is rounded to ! NDB digits. ! If MB has more precision, the result has its precision extended ! by padding with zero digits on the right. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: nda, ndb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmeq2 ! .. CALL fmeq2(ma,mb,nda,ndb,0) RETURN END SUBROUTINE fmequ SUBROUTINE fmexit(mt,mc,ndsave,mxsave,kasave,kovun) ! Upon exit from an FM routine the result MT (having precision NDIG) ! is rounded and returned in MC (having precision NDSAVE). ! The values of NDIG, MXEXP, and KACCSW are restored. ! KOVUN is nonzero if one of the routine's input arguments was overflow ! or underflow. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: mxsave INTEGER :: kasave, kovun, ndsave ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: mc(0:lunpck), mt(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kfsave, kwrnsv ! .. ! .. External Subroutines .. EXTERNAL fmeq2, fmntr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kwrnsv = kwarn kwarn = 0 mxexp = mxsave kfsave = kflag CALL fmeq2(mt,mc,ndig,ndsave,0) IF (kflag/=-5 .AND. kflag/=-6) kflag = kfsave ndig = ndsave kwarn = kwrnsv IF (kflag==1) kflag = 0 IF ((mc(1)==munkno .AND. kflag/=-9) .OR. (mc(1)==mexpun .AND. kovun==0) & .OR. (mc(1)==mexpov .AND. kovun==0)) CALL fmwarn IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 kaccsw = kasave RETURN END SUBROUTINE fmexit SUBROUTINE fmexp(ma,mb) ! MB = EXP(MA) IMPLICIT NONE ! Scratch array usage during FMEXP: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: m1, ma1, ma2, macca, macmax, mxsave REAL :: xma, xov INTEGER :: iextra, j, k, kasave, kovun, kreslt, kt, kwrnsv, ndmb, & ndsave, ndsv, nmethd CHARACTER (155) :: string ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmcsh2, fmdiv, fmentr, fmeq2, fmexit, fmexp2, & fmi2m, fmim, fmint, fmipwr, fmm2i, fmmpy, fmntr, fmrslt, fmsnh2, & fmsqr, fmsqrt, fmst2m, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)==0) THEN CALL fmentr('FMEXP ',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMEXP ' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52-1,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF ma1 = ma(1) ma2 = ma(2) macca = ma(0) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) ! Check for obvious underflow or overflow. ! XOV is LN(LN(slightly above overflow)) ! XMA is LN(LN(EXP(MA))) approximately. xov = log(1.01*real(mxexp)) + log(alogmb) m1 = 1 xma = log(real(max(abs(ma2),m1))) - alogmb + real(ma1)*alogmb 10 IF (xma>=xov) THEN CALL fmim(0,mb) IF (ma2>0) THEN kflag = -5 mb(1) = mexpov mb(2) = 1 mb(0) = nint(ndig*alogm2) ELSE kflag = -6 mb(1) = mexpun mb(2) = 1 mb(0) = nint(ndig*alogm2) END IF ndig = ndsave mxexp = mxsave kaccsw = kasave CALL fmwarn IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF ! Split MA into integer and fraction parts. ! Work with a positive argument. ! M02 = integer part of ABS(MA) ! MB = fraction part of ABS(MA) mb(2) = abs(mb(2)) CALL fmint(mb,m02) CALL fmsub(mb,m02,mb) ! If the integer part is not zero, use FMIPWR to compute ! E**(M02). If M02 is too large to represent as a one word ! integer, the definition of MXEXP insures that E**(M02) ! overflows or underflows. kwrnsv = kwarn kwarn = 0 CALL fmm2i(m02,kt) kwarn = kwrnsv IF (kflag/=0) THEN xma = xov GO TO 10 END IF IF (kt>0) THEN ! Compute IEXTRA, the number of extra digits required ! to get EXP(KT) correct to the current precision. iextra = int(log(real(kt))/alogmb+0.5) IF (iextra>0 .AND. ndig+iextra<=ndg2mx) THEN CALL fmeq2(mb,mb,ndig,ndig+iextra,1) END IF ndig = ndig + iextra IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 20 j = 2, ndsave mb(j+1) = 0 20 CONTINUE ndig = ndig - iextra CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END IF ! Check whether the current precision of e is large ! enough. IF (mbse/=mbase .OR. ndig>ndige) THEN ndmb = int(150.0*2.302585/alogmb) IF (ndmb>=ndig) THEN ndsv = ndig ndig = min(ndmb,ndg2mx) string = '2.718281828459045235360287471352662497757247' // & '09369995957496696762772407663035354759457138217852516' // & '6427427466391932003059921817413596629043572900334295261' CALL fmst2m(string,mesav) mesav(0) = nint(ndig*alogm2) mbse = mbase ndige = ndig IF (abs(mesav(1))>10) ndige = 0 ndig = ndsv ELSE ndsv = ndig ndig = min(ndig+2,ndg2mx) CALL fmi2m(1,mesav) CALL fmexp2(mesav,mesav) mesav(0) = nint(ndig*alogm2) mbse = mbase ndige = ndig IF (abs(mesav(1))>10) ndige = 0 ndig = ndsv END IF END IF END IF ! Now do the fraction part of MA and combine the results. kwrnsv = kwarn kwarn = 0 nmethd = 1 IF (ndig>50) nmethd = 2 IF (mb(2)/=0 .AND. kt>0 .AND. nmethd==1) THEN CALL fmexp2(mb,mb) CALL fmipwr(mesav,kt,m03) CALL fmmpy(mb,m03,mb) ELSE IF (mb(2)/=0 .AND. kt==0 .AND. nmethd==1) THEN CALL fmexp2(mb,mb) ELSE IF (mb(2)/=0 .AND. kt>0 .AND. nmethd==2) THEN ndsv = ndig ndig = min(ndig+ngrd21,ndg2mx) CALL fmeq2(mb,mb,ndsv,ndig,1) IF (mb(1)>=0) THEN CALL fmcsh2(mb,mb) CALL fmsqr(mb,m03) CALL fmi2m(-1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,m03) CALL fmadd(mb,m03,mb) ELSE CALL fmsnh2(mb,mb) CALL fmsqr(mb,m03) CALL fmi2m(1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,m03) CALL fmadd(mb,m03,mb) END IF ndig = ndsv CALL fmipwr(mesav,kt,m03) CALL fmmpy(mb,m03,mb) ELSE IF (mb(2)/=0 .AND. kt==0 .AND. nmethd==2) THEN ndsv = ndig ndig = min(ndig+ngrd21,ndg2mx) CALL fmeq2(mb,mb,ndsv,ndig,1) IF (mb(1)>=0) THEN CALL fmcsh2(mb,mb) CALL fmsqr(mb,m03) CALL fmi2m(-1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,m03) CALL fmadd(mb,m03,mb) ELSE CALL fmsnh2(mb,mb) CALL fmsqr(mb,m03) CALL fmi2m(1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,m03) CALL fmadd(mb,m03,mb) END IF ndig = ndsv ELSE IF (mb(2)==0 .AND. kt>0) THEN CALL fmipwr(mesav,kt,mb) ELSE CALL fmi2m(1,mb) END IF ! Invert if MA was negative. IF (ma2<0) THEN CALL fmi2m(1,m02) CALL fmdiv(m02,mb,mb) END IF kwarn = kwrnsv ! Round the result and return. macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmexp SUBROUTINE fmexp2(ma,mb) ! MB = EXP(MA) ! Internal exponential routine (called with 0.LT.MA.LE.1). IMPLICIT NONE ! Scratch array usage during FMEXP2: M01 - M03 ! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent ! sums. Increasing this value will begin to improve the ! speed of EXP when the base is large and precision exceeds ! about 1,500 decimal digits. ! .. Intrinsic Functions .. INTRINSIC int, log, max, min, nint, real, sqrt ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL :: alog2, alogt, b, t, tj, xn REAL (KIND(0.0D0)) :: maxval INTEGER :: j, j2, k, k2, kpt, ktwo, l, l2, n2, nbig, nbot, ndsav1, & ndsave, nterm, ntop ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdivi, fmeq, fmeq2, fmi2m, fmipwr, fmmpy, & fmmpyi, fmsqr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mjsums(0:ljsums), & mlbsav(0:lunpck), mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), & mln4(0:lunpck), mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmsums/mjsums COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons ndsave = ndig IF (ma(1)==1) THEN ! Here the special case EXP(1.0) is computed. ! Use the direct series e = 1/0! + 1/1! + 1/2! + ... ! Do as much of the work as possible using small integers ! to minimize the number of FM calls. ! Reduce NDIG while computing each term in the ! sum as the terms get smaller. t = ndig xn = t*alogmb/log(t) k = int(log(xn)/alogmb) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mb(j+1) = 0 10 CONTINUE ndig = ndsave RETURN END IF ndsav1 = ndig CALL fmi2m(2,mb) CALL fmi2m(1,m02) j = 2 nbig = int(mxbase) 20 ntop = 1 nbot = j 30 IF (nbot>nbig/(j+1)) GO TO 40 j = j + 1 ntop = j*ntop + 1 nbot = j*nbot GO TO 30 40 CALL fmdivi(m02,nbot,m02) IF (ntop>1) THEN CALL fmmpyi(m02,ntop,m03) ndig = ndsav1 CALL fmadd(mb,m03,mb) ndig = ndsav1 - int(mb(1)-m03(1)) ELSE ndig = ndsav1 CALL fmadd(mb,m02,mb) ndig = ndsav1 - int(mb(1)-m02(1)) END IF IF (ndig<2) ndig = 2 IF (kflag/=1) THEN j = j + 1 GO TO 20 END IF ndig = ndsave CALL fmi2m(-1,m02) CALL fmadd(mb,m02,m03) kflag = 0 RETURN END IF ! Here is the general case. Compute EXP(MA) where ! 0 .LT. MA .LT. 1. ! Use the direct series ! EXP(X) = 1 + X + X**2/2! + X**3/3! + ... ! The argument will be halved K2 times before the series ! is summed. The series will be added as J2 concurrent ! series. The approximately optimal values of K2 and J2 ! are now computed to try to minimize the time required. ! N2 is the approximate number of terms of the series that ! will be needed, and L2 guard digits will be carried. b = real(mbase) k = ngrd52 t = max(ndig-k,2) alog2 = real(dlogtw) alogt = log(t) tj = 0.051*alogmb*t**0.3333 + 1.85 j2 = int(tj) j2 = max(1,min(j2,ljsums/ndg2mx)) k2 = int(1.13*sqrt(t*alogmb/tj)-0.5*alogt+4.5) l = int(-(real(ma(1))*alogmb+log(real(ma(2))/b+ & real(ma(3))/(b*b)))/alog2-0.3) k2 = k2 - l IF (l<0) l = 0 IF (k2<0) THEN k2 = 0 j2 = int(.43*sqrt(t*alogmb/(alogt+real(l)*alog2))+.33) END IF IF (j2<=1) j2 = 1 n2 = int(t*alogmb/(alogt+real(l)*alog2)) l2 = int(log(real(n2)+2.0**k2)/alogmb) ndig = ndig + l2 IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 50 j = 2, ndsave mb(j+1) = 0 50 CONTINUE ndig = ndsave RETURN END IF ndsav1 = ndig ! Halve the argument K2 times. CALL fmeq2(ma,m02,ndsave,ndig,0) ktwo = 1 maxval = mxbase/2 IF (k2>0) THEN DO 60 j = 1, k2 ktwo = 2*ktwo IF (ktwo>maxval) THEN CALL fmdivi(m02,ktwo,m02) ktwo = 1 END IF 60 CONTINUE IF (ktwo>1) CALL fmdivi(m02,ktwo,m02) END IF ! Sum the series X + X**2/2! + X**3/3! + .... ! Split into J2 concurrent sums and reduce NDIG while ! computing each term in the sum as the terms get smaller. CALL fmeq(m02,mb) nterm = 1 DO 70 j = 1, j2 CALL fmdivi(mb,nterm,mb) nterm = nterm + 1 kpt = (j-1)*(ndig+2) CALL fmeq(mb,mjsums(kpt)) 70 CONTINUE IF (m02(1)<-ndig) GO TO 100 CALL fmipwr(m02,j2,m03) 80 CALL fmmpy(mb,m03,mb) DO 90 j = 1, j2 CALL fmdivi(mb,nterm,mb) kpt = (j-1)*(ndsav1+2) ndig = ndsav1 CALL fmadd(mjsums(kpt),mb,mjsums(kpt)) IF (kflag/=0) GO TO 100 ndig = ndsav1 - int(mjsums(kpt+1)-mb(1)) IF (ndig<2) ndig = 2 nterm = nterm + 1 90 CONTINUE GO TO 80 ! Put the J2 separate sums back together. 100 kflag = 0 kpt = (j2-1)*(ndig+2) CALL fmeq(mjsums(kpt),m03) IF (j2>=2) THEN DO 110 j = 2, j2 CALL fmmpy(m02,m03,m03) kpt = (j2-j)*(ndig+2) CALL fmadd(m03,mjsums(kpt),m03) 110 CONTINUE END IF ! Reverse the effect of halving the argument to ! compute EXP(MA). ndig = ndsav1 IF (k2>0) THEN IF (ndsave<=20) THEN CALL fmi2m(2,m02) DO 120 j = 1, k2 CALL fmadd(m03,m02,mb) CALL fmmpy(mb,m03,m03) 120 CONTINUE ELSE DO 130 j = 1, k2 CALL fmsqr(m03,mb) CALL fmadd(m03,m03,m02) CALL fmadd(mb,m02,m03) 130 CONTINUE END IF END IF CALL fmi2m(1,m02) CALL fmadd(m02,m03,mb) CALL fmeq2(mb,mb,ndsav1,ndsave,1) ndig = ndsave RETURN END SUBROUTINE fmexp2 SUBROUTINE fmform(form,ma,string) ! Convert an FM number (MA) to a character string base 10 (STRING) ! using character string FORM format. ! FORM can be one of these types: Iw, Fw.d, Ew.d, 1PEw.d ! for positive integers w,d. ! If Iw format is used and MA is not exactly an integer, then the ! nearest integer to MA is printed. IMPLICIT NONE ! Scratch array usage during FMFORM: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC abs, index, int, len, log10, max, min, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: form, string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, jf1sav, jf2sav, jpt, k1, k2, k3, kd, ksave, kwd, kwi, & last, lb, lengfm, lengst, lfirst, nd, nexp CHARACTER (20) :: formb ! .. ! .. External Subroutines .. EXTERNAL fmnint, fmout ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMFORM' ksave = kflag jf1sav = jform1 jf2sav = jform2 string = ' ' lengfm = len(form) lengst = len(string) kwi = 75 kwd = 40 IF (index(form,'I')>0 .OR. index(form,'i')>0) THEN k1 = max(index(form,'I'),index(form,'i')) + 1 k2 = lengfm WRITE (formb,90000) k2 - k1 + 1 IF (k2>=k1) THEN READ (form(k1:k2),formb) kwi ELSE kwi = lengst END IF kwi = max(1,min(kwi,lengst)) jform1 = 2 jform2 = 0 kwd = kwi + 21 IF (kwd>lmbuff) GO TO 140 CALL fmnint(ma,m02) IF (m02(2)/=0) THEN CALL fmout(m02,cmbuff,kwd) ELSE DO 10 j = 1, kwd cmbuff(j) = ' ' 10 CONTINUE cmbuff(2) = '0' END IF lfirst = 1 last = 1 DO 20 j = 1, kwd IF (cmbuff(kwd+1-j)/=' ') lfirst = kwd + 1 - j IF (cmbuff(j)/=' ') last = j 20 CONTINUE jpt = 1 IF (last-lfirst+1>kwi) GO TO 140 IF (last<=kwi) THEN DO 30 j = last, lfirst, -1 jpt = kwi - last + j string(jpt:jpt) = cmbuff(j) 30 CONTINUE DO 40 j = 1, jpt - 1 string(j:j) = ' ' 40 CONTINUE ELSE DO 50 j = lfirst, last jpt = kwi - last + j string(jpt:jpt) = cmbuff(j) 50 CONTINUE END IF ELSE IF (index(form,'F')>0 .OR. index(form,'f')>0) THEN k1 = max(index(form,'F'),index(form,'f')) + 1 k2 = index(form,'.') k3 = lengfm IF (k2>k1) THEN WRITE (formb,90000) k2 - k1 READ (form(k1:k2-1),formb) kwi ELSE kwi = 50 END IF IF (k3>k2) THEN WRITE (formb,90000) k3 - k2 READ (form(k2+1:k3),formb) kd ELSE kd = 0 END IF kwi = max(1,min(kwi,lengst)) kd = max(0,min(kd,kwi-2)) jform1 = 2 jform2 = kd nd = int(real(ndig)*log10(real(mbase))) + 1 IF (nd<2) nd = 2 nexp = int(2.0*log10(real(mxbase))) + 6 lb = max(jform2+nexp,nd+nexp) lb = min(lb,lmbuff) kwd = lb CALL fmout(ma,cmbuff,kwd) lfirst = 1 last = 1 DO 60 j = 1, kwd IF (cmbuff(kwd+1-j)/=' ') lfirst = kwd + 1 - j IF (cmbuff(j)/=' ') last = j 60 CONTINUE IF (last-lfirst+1>kwi) THEN ! Not enough room for this F format, or FMOUT converted ! it to E format to avoid showing no significant digits. ! See if a shortened form will fit in E format. nexp = int(log10((abs(real(ma(1)))+1)*log10(real(mbase))+1)+1) nd = kwi - nexp - 5 IF (nd<1) THEN GO TO 140 ELSE jform1 = 0 jform2 = nd CALL fmout(ma,cmbuff,kwi) lfirst = 1 last = 1 DO 70 j = 1, kwi IF (cmbuff(kwi+1-j)/=' ') lfirst = kwi + 1 - j IF (cmbuff(j)/=' ') last = j 70 CONTINUE END IF END IF jpt = 1 IF (last<=kwi) THEN DO 80 j = last, lfirst, -1 jpt = kwi - last + j string(jpt:jpt) = cmbuff(j) 80 CONTINUE DO 90 j = 1, jpt - 1 string(j:j) = ' ' 90 CONTINUE ELSE DO 100 j = lfirst, last jpt = kwi - last + j string(jpt:jpt) = cmbuff(j) 100 CONTINUE END IF ELSE IF (index(form,'1PE')>0 .OR. index(form,'1pe')>0) THEN k1 = max(index(form,'E'),index(form,'e')) + 1 k2 = index(form,'.') k3 = lengfm IF (k2>k1) THEN WRITE (formb,90000) k2 - k1 READ (form(k1:k2-1),formb) kwi ELSE kwi = 50 END IF IF (k3>k2) THEN WRITE (formb,90000) k3 - k2 READ (form(k2+1:k3),formb) kd ELSE kd = 0 END IF kwi = max(1,min(kwi,lengst)) kd = max(0,min(kd,kwi-2)) jform1 = 1 jform2 = kd IF (kwi>lmbuff) GO TO 140 CALL fmout(ma,cmbuff,kwi) DO 110 j = kwi, 1, -1 IF (j>lengst) THEN IF (cmbuff(j)/=' ') GO TO 140 ELSE string(j:j) = cmbuff(j) END IF 110 CONTINUE ELSE IF (index(form,'E')>0 .OR. index(form,'e')>0) THEN k1 = max(index(form,'E'),index(form,'e')) + 1 k2 = index(form,'.') k3 = lengfm IF (k2>k1) THEN WRITE (formb,90000) k2 - k1 READ (form(k1:k2-1),formb) kwi ELSE kwi = 50 END IF IF (k3>k2) THEN WRITE (formb,90000) k3 - k2 READ (form(k2+1:k3),formb) kd ELSE kd = 0 END IF kwi = max(1,min(kwi,lengst)) kd = max(0,min(kd,kwi-2)) jform1 = 0 jform2 = kd IF (kwi>lmbuff) GO TO 140 CALL fmout(ma,cmbuff,kwi) DO 120 j = kwi, 1, -1 IF (j>lengst) THEN IF (cmbuff(j)/=' ') GO TO 140 ELSE string(j:j) = cmbuff(j) END IF 120 CONTINUE ELSE GO TO 140 END IF 130 kflag = ksave jform1 = jf1sav jform2 = jf2sav ncall = ncall - 1 RETURN ! Error condition. 140 kflag = -8 DO 150 j = 1, lengst string(j:j) = '*' 150 CONTINUE GO TO 130 90000 FORMAT ('(I',I5,')') END SUBROUTINE fmform SUBROUTINE fmfprt(form,ma) ! Print an FM number (MA) on unit KW using character ! string FORM format. ! FORM can be one of these types: Iw, Fw.d, Ew.d, 1PEw.d ! for positive integers w,d. ! If Iw format is used and MA is not exactly an integer, then the ! nearest integer to MA is printed. IMPLICIT NONE ! Scratch array usage during FMFPRT: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC abs, index, int, len, log10, max, min, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: form ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, jf1sav, jf2sav, jpt, k, k1, k2, k3, kd, ksave, kwd, kwi, & last, lb, lengfm, lfirst, nd, nexp CHARACTER (20) :: form2, formb ! .. ! .. External Subroutines .. EXTERNAL fmnint, fmout ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMFPRT' ksave = kflag jf1sav = jform1 jf2sav = jform2 lengfm = len(form) kwi = 75 kwd = 40 IF (index(form,'I')>0 .OR. index(form,'i')>0) THEN k1 = max(index(form,'I'),index(form,'i')) + 1 k2 = lengfm WRITE (formb,90000) k2 - k1 + 1 IF (k2>=k1) THEN READ (form(k1:k2),formb) kwi ELSE kwi = 50 END IF kwi = max(1,min(kwi,lmbuff-11)) jform1 = 2 jform2 = 0 kwd = kwi + 21 CALL fmnint(ma,m02) IF (m02(2)/=0) THEN CALL fmout(m02,cmbuff,kwd) ELSE DO 10 j = 1, kwd cmbuff(j) = ' ' 10 CONTINUE cmbuff(2) = '0' END IF lfirst = 1 last = 1 DO 20 j = 1, kwd IF (cmbuff(kwd+1-j)/=' ') lfirst = kwd + 1 - j IF (cmbuff(j)/=' ') last = j 20 CONTINUE jpt = 1 IF (last-lfirst+1>kwi) GO TO 130 IF (last<=kwi) THEN DO 30 j = last, lfirst, -1 jpt = kwi - last + j IF (jpt/=j) cmbuff(jpt) = cmbuff(j) 30 CONTINUE DO 40 j = 1, jpt - 1 cmbuff(j) = ' ' 40 CONTINUE ELSE DO 50 j = lfirst, last jpt = kwi - last + j IF (jpt/=j) cmbuff(jpt) = cmbuff(j) 50 CONTINUE END IF ELSE IF (index(form,'F')>0 .OR. index(form,'f')>0) THEN k1 = max(index(form,'F'),index(form,'f')) + 1 k2 = index(form(1:lengfm),'.') k3 = lengfm IF (k2>k1) THEN WRITE (formb,90000) k2 - k1 READ (form(k1:k2-1),formb) kwi ELSE kwi = 50 END IF IF (k3>k2) THEN WRITE (formb,90000) k3 - k2 READ (form(k2+1:k3),formb) kd ELSE kd = 0 END IF kwi = max(1,min(kwi,lmbuff)) kd = max(0,min(kd,kwi-2)) jform1 = 2 jform2 = kd nd = int(real(ndig)*log10(real(mbase))) + 1 IF (nd<2) nd = 2 nexp = int(2.0*log10(real(mxbase))) + 6 lb = max(jform2+nexp,nd+nexp) lb = min(lb,lmbuff) kwd = lb CALL fmout(ma,cmbuff,kwd) lfirst = 1 last = 1 DO 60 j = 1, kwd IF (cmbuff(kwd+1-j)/=' ') lfirst = kwd + 1 - j IF (cmbuff(j)/=' ') last = j 60 CONTINUE IF (last-lfirst+1>kwi) THEN ! Not enough room for this F format, or FMOUT converted ! it to E format to avoid showing no significant digits. ! See if a shortened form will fit in E format. nexp = int(log10((abs(real(ma(1)))+1)*log10(real(mbase))+1)+1) nd = kwi - nexp - 5 IF (nd<1) THEN GO TO 130 ELSE jform1 = 0 jform2 = nd CALL fmout(ma,cmbuff,kwi) lfirst = 1 last = 1 DO 70 j = 1, kwi IF (cmbuff(kwi+1-j)/=' ') lfirst = kwi + 1 - j IF (cmbuff(j)/=' ') last = j 70 CONTINUE END IF END IF jpt = 1 IF (last<=kwi) THEN DO 80 j = last, lfirst, -1 jpt = kwi - last + j IF (jpt/=j) cmbuff(jpt) = cmbuff(j) 80 CONTINUE DO 90 j = 1, jpt - 1 cmbuff(j) = ' ' 90 CONTINUE ELSE DO 100 j = lfirst, last jpt = kwi - last + j IF (jpt/=j) cmbuff(jpt) = cmbuff(j) 100 CONTINUE END IF ELSE IF (index(form,'1PE')>0 .OR. index(form,'1pe')>0) THEN k1 = max(index(form,'E'),index(form,'e')) + 1 k2 = index(form(1:lengfm),'.') k3 = lengfm IF (k2>k1) THEN WRITE (formb,90000) k2 - k1 READ (form(k1:k2-1),formb) kwi ELSE kwi = 50 END IF IF (k3>k2) THEN WRITE (formb,90000) k3 - k2 READ (form(k2+1:k3),formb) kd ELSE kd = 0 END IF kwi = max(1,min(kwi,lmbuff)) kd = max(0,min(kd,kwi-2)) jform1 = 1 jform2 = kd CALL fmout(ma,cmbuff,kwi) ELSE IF (index(form,'E')>0 .OR. index(form,'e')>0) THEN k1 = max(index(form,'E'),index(form,'e')) + 1 k2 = index(form(1:lengfm),'.') k3 = lengfm IF (k2>k1) THEN WRITE (formb,90000) k2 - k1 READ (form(k1:k2-1),formb) kwi ELSE kwi = 50 END IF IF (k3>k2) THEN WRITE (formb,90000) k3 - k2 READ (form(k2+1:k3),formb) kd ELSE kd = 0 END IF kwi = max(1,min(kwi,lmbuff)) kd = max(0,min(kd,kwi-2)) jform1 = 0 jform2 = kd CALL fmout(ma,cmbuff,kwi) ELSE GO TO 130 END IF 110 last = kwi + 1 WRITE (form2,90010) kswide - 7 IF (kflag/=-8) kflag = ksave jform1 = jf1sav jform2 = jf2sav DO 120 j = kwi, 1, -1 IF (cmbuff(j)/=' ' .OR. j==1) THEN WRITE (kw,form2) (cmbuff(k),k=1,j) ncall = ncall - 1 RETURN END IF 120 CONTINUE ncall = ncall - 1 RETURN ! Error condition. 130 kflag = -8 DO 140 j = 1, kwi cmbuff(j) = '*' 140 CONTINUE GO TO 110 90000 FORMAT ('(I',I5,')') 90010 FORMAT (' (6X,',I3,'A1) ') END SUBROUTINE fmfprt SUBROUTINE fmgcdi(n1,n2) ! Find the Greatest Common Divisor of N1 and N2, and return both ! having been divided by their GCD. Both must be positive. ! .. Intrinsic Functions .. INTRINSIC max, min, mod ! .. ! .. Scalar Arguments .. INTEGER :: n1, n2 ! .. ! .. Local Scalars .. INTEGER :: k1, k2, k3 ! .. k1 = max(n1,n2) k2 = min(n1,n2) 10 k3 = mod(k1,k2) IF (k3==0) THEN n1 = n1/k2 n2 = n2/k2 RETURN ELSE k1 = k2 k2 = k3 GO TO 10 END IF END SUBROUTINE fmgcdi SUBROUTINE fmi2m(ival,ma) ! MA = IVAL ! Convert an integer to FM format. ! The conversion is exact if IVAL is less than MBASE**NDIG, ! otherwise the result is an approximation. ! This routine performs the trace printing for the conversion. ! FMIM is used to do the arithmetic. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmim, fmntr, fmntri ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMI2M ' CALL fmntri(2,ival,1) CALL fmim(ival,ma) CALL fmntr(1,ma,ma,1) ELSE CALL fmim(ival,ma) END IF ncall = ncall - 1 RETURN END SUBROUTINE fmi2m SUBROUTINE fmim(ival,ma) ! MA = IVAL. Internal integer conversion routine. ! The conversion is exact if IVAL is less than MBASE**NDIG. ! Otherwise FMDM is used to get an approximation. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mk, ml, mval REAL (KIND(0.0D0)) :: x INTEGER :: j, jm2, kb, kb1, n1, nmval, nv2 ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmdm, fmims ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons kflag = 0 n1 = ndig + 1 mval = abs(ival) nmval = int(mval) nv2 = nmval - 1 IF (abs(ival)>mxbase .OR. nmval/=abs(ival) .OR. nv2/=abs(ival)-1) THEN CALL fmims(ival,ma) GO TO 50 END IF ! Check for small IVAL. IF (mval0) THEN mval = mk j = j - 1 IF (j>=2) GO TO 20 ! Here IVAL cannot be expressed exactly. x = ival CALL fmdm(x,ma) RETURN END IF ! Normalize MA. kb = n1 - j + 2 jm2 = j - 2 DO 30 j = 2, kb ma(j) = ma(j+jm2) 30 CONTINUE kb1 = kb + 1 IF (kb1<=n1) THEN DO 40 j = kb1, n1 ma(j) = 0 40 CONTINUE END IF IF (ival<0) ma(2) = -ma(2) 50 ma(0) = nint(ndig*alogm2) RETURN END SUBROUTINE fmim SUBROUTINE fmims(ival,ma) ! MA = IVAL. Internal integer conversion routine. ! This routine is called when M-variable precision is less than ! Integer precision. This often happens when single precision ! is chosen for M-variables. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ml REAL (KIND(0.0D0)) :: x INTEGER :: j, jm2, kb, kb1, kbase, kmk, kval, n1 ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmdm ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons kflag = 0 n1 = ndig + 1 ! Check for small IVAL. kval = abs(ival) kbase = int(mbase) IF (kval0) THEN kval = kmk j = j - 1 IF (j>=2) GO TO 20 ! Here IVAL cannot be expressed exactly. x = ival CALL fmdm(x,ma) RETURN END IF ! Normalize MA. kb = n1 - j + 2 jm2 = j - 2 DO 30 j = 2, kb ma(j) = ma(j+jm2) 30 CONTINUE kb1 = kb + 1 IF (kb1<=n1) THEN DO 40 j = kb1, n1 ma(j) = 0 40 CONTINUE END IF IF (ival<0) ma(2) = -ma(2) 50 ma(0) = nint(ndig*alogm2) RETURN END SUBROUTINE fmims SUBROUTINE fminp(line,ma,la,lb) ! Convert an array of characters to floating point multiple precision ! format. ! LINE is an A1 character array of length LB to be converted ! to FM format and returned in MA. ! LA is a pointer telling the routine where in the array to begin ! the conversion. This allows more than one number to be stored ! in an array and converted in place. ! LB is a pointer to the last character of the field for that number. ! The input number may be in integer or any real format. ! KESWCH = 1 causes input to FMINP with no digits before the exponent ! letter to be treated as if there were a leading '1'. ! This is sometimes better for interactive input: ! 'E7' converts to 10.0**7. ! = 0 causes a leading zero to be assumed. This gives ! compatibility with Fortran: ! 'E7' converts to 0.0. ! In exponential format the 'E' may also be 'D', 'Q', or 'M'. ! So that FMINP will convert any output from FMOUT, LINE is tested ! to see if the input is one of the special symbols +OVERFLOW, ! -OVERFLOW, +UNDERFLOW, -UNDERFLOW, or UNKNOWN. ! For user input the abbreviations OVFL, UNFL, UNKN may be used. IMPLICIT NONE ! Simulate a finite-state automaton to scan the input line ! and build the number. States of the machine: ! 1. Initial entry to the subroutine ! 2. Sign of the number ! 3. Scanning digits before a decimal point ! 4. Decimal point ! 5. Scanning digits after a decimal point ! 6. E, D, Q, or M -- precision indicator before the exponent ! 7. Sign of the exponent ! 8. Scanning exponent ! 9. Syntax error ! Character types recognized by the machine: ! 1. Sign (+,-) ! 2. Numeral (0,1,...,9) ! 3. Decimal point (.) ! 4. Precision indicator (E,D,Q,M) ! 5. Illegal character for number ! All blanks are ignored. The analysis of the number proceeds as ! follows: If the simulated machine is in state JSTATE and a character ! of type JTYPE is encountered the new state of the machine is given by ! JTRANS(JSTATE,JTYPE). ! In this DATA statement note the array is loaded by columns. ! State 1 2 3 4 5 6 7 8 ! Type ! .. Intrinsic Functions .. INTRINSIC abs, dble, ichar, int, log10, max, min, mod, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: la, lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) CHARACTER (1) :: line(lb) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: m2, mndsv1 INTEGER :: j, jstate, k, k10pwr, kasave, kdflag, kexp, kf1, kf2, kmn, & kof, kpower, kpt, krsave, ksign, ksignx, kstart, kstop, ktenex, & ktenf1, ktenf2, ktype, kuf, kuk, kval, kwrnsv, large, n2, ndsav1, & ndsave ! .. ! .. Local Arrays .. REAL (KIND(0.0D0)) :: mlv2(0:lunpck), mlv3(0:lunpck), mlv4(0:lunpck), & mlv5(0:lunpck) INTEGER :: jtrans(8,4) CHARACTER (1) :: kovfl(4), kunfl(4), kunkn(4), lovfl(4), lunfl(4), & lunkn(4) ! .. ! .. External Subroutines .. EXTERNAL fmadd2, fmcons, fmdiv2, fmeq, fmeq2, fmim, fminp2, fmmi, & fmmpy2, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! .. Data Statements .. DATA jtrans/2, 9, 9, 9, 9, 7, 9, 9, 3, 3, 3, 5, 5, 8, 8, 8, 4, 4, 4, 9, & 9, 9, 9, 9, 6, 6, 6, 6, 6, 9, 9, 9/ DATA kovfl/'O', 'V', 'F', 'L'/, kunfl/'U', 'N', 'F', 'L'/, kunkn/'U', & 'N', 'K', 'N'/ DATA lovfl/'o', 'v', 'f', 'l'/, lunfl/'u', 'n', 'f', 'l'/, lunkn/'u', & 'n', 'k', 'n'/ ! .. ! To avoid recursion, FMINP calls only internal arithmetic ! routines (FMADD2, FMMPY2, ...), so no trace printout is ! done during a call to FMINP. IF (mblogs/=mbase) CALL fmcons ncall = ncall + 1 namest(ncall) = 'FMINP ' ! Raise the call stack again, since the internal ! routines don't. ncall = ncall + 1 namest(ncall) = 'FMINP ' ndsave = ndig kasave = kaccsw kaccsw = 0 krsave = kround kround = 1 kflag = 0 ! Check for special symbols. kmn = 1 kof = 1 kuf = 1 kuk = 1 DO 10 j = la, lb kpt = ichar(line(j)) IF (kpt>=lhash1 .AND. kpt<=lhash2) THEN ktype = khasht(kpt) IF (ktype==2) GO TO 20 END IF IF (line(j)=='-') kmn = -1 IF (line(j)==kovfl(kof) .OR. line(j)==lovfl(kof)) THEN kof = kof + 1 IF (kof==5) THEN CALL fmim(0,ma) ma(1) = mexpov ma(2) = kmn ma(0) = nint(ndig*alogm2) GO TO 140 END IF END IF IF (line(j)==kunfl(kuf) .OR. line(j)==lunfl(kof)) THEN kuf = kuf + 1 IF (kuf==5) THEN CALL fmim(0,ma) ma(1) = mexpun ma(2) = kmn ma(0) = nint(ndig*alogm2) GO TO 140 END IF END IF IF (line(j)==kunkn(kuk) .OR. line(j)==lunkn(kof)) THEN kuk = kuk + 1 IF (kuk==5) THEN CALL fmim(0,ma) ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) GO TO 140 END IF END IF 10 CONTINUE ! Increase the working precision. 20 IF (ncall<=2) THEN k = ngrd52 ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 ncall = ncall - 1 CALL fmwarn ncall = ncall + 1 ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) DO 30 j = 2, ndsave ma(j+1) = 0 30 CONTINUE GO TO 140 END IF END IF ndsav1 = ndig m2 = 2 mndsv1 = ndsav1 kstart = la kstop = lb jstate = 1 ksign = 1 CALL fmim(0,mlv2) CALL fmim(0,mlv3) CALL fmim(0,mlv4) CALL fmim(0,mlv5) ! If MBASE is a power of ten then call FMINP2 for ! faster input conversion. kpower = int(log10(dble(mbase))+0.5D0) IF (mbase==10**kpower) THEN CALL fminp2(ma,line,kstart,kstop,jtrans,kpower,mlv3,mlv4,mlv5) GO TO 130 END IF n2 = 0 ksignx = 1 kf1 = 0 kf2 = 0 kexp = 0 ktenf1 = 1 ktenf2 = 1 ktenex = 1 k10pwr = 0 ! LARGE is a threshold used in order to do as much of the ! conversion as possible in one-word integer arithmetic. large = int((intmax-10)/10) ! KDFLAG will be 1 if any digits are found before 'E'. kdflag = 0 ! Scan the number. DO 100 j = kstart, kstop IF (line(j)==' ') GO TO 100 kpt = ichar(line(j)) IF (kptlhash2) THEN WRITE (kw,90000) line(j), kpt, lhash1, lhash2 ktype = 5 kval = 0 ELSE ktype = khasht(kpt) kval = khashv(kpt) END IF IF (ktype>=5) GO TO 150 jstate = jtrans(jstate,ktype) GO TO (150,40,50,100,60,70,80,90,150) jstate ! State 2. Sign of the number. 40 ksign = kval GO TO 100 ! State 3. Digits before a decimal point. 50 kdflag = 1 kf1 = 10*kf1 + kval ktenf1 = 10*ktenf1 IF (ktenf1>large) THEN IF (ktenf1/=k10pwr .AND. mlv3(2)/=0) THEN CALL fmim(ktenf1,ma) k10pwr = ktenf1 END IF IF (mlv3(2)==0) THEN CALL fmim(kf1,mlv3) ELSE ndig = int(max(m2,min(mlv3(1)+ma(1),mndsv1))) CALL fmmpy2(mlv3,ma,mlv3) ndig = ndsav1 CALL fmim(kf1,mlv2) ndig = int(max(m2,min(max(mlv3(1),mlv2(1))+1,mndsv1))) IF (kf1/=0) CALL fmadd2(mlv3,mlv2,mlv3) ndig = ndsav1 END IF kf1 = 0 ktenf1 = 1 END IF GO TO 100 ! State 5. Digits after a decimal point. 60 kdflag = 1 n2 = n2 + 1 kf2 = 10*kf2 + kval ktenf2 = 10*ktenf2 IF (ktenf2>large) THEN IF (ktenf2/=k10pwr .AND. mlv4(2)/=0) THEN CALL fmim(ktenf2,ma) k10pwr = ktenf2 END IF IF (mlv4(2)==0) THEN CALL fmim(kf2,mlv4) ELSE ndig = int(max(m2,min(mlv4(1)+ma(1),mndsv1))) CALL fmmpy2(mlv4,ma,mlv4) ndig = ndsav1 CALL fmim(kf2,mlv2) ndig = int(max(m2,min(max(mlv4(1),mlv2(1))+1,mndsv1))) IF (kf2/=0) CALL fmadd2(mlv4,mlv2,mlv4) ndig = ndsav1 END IF kf2 = 0 ktenf2 = 1 END IF GO TO 100 ! State 6. Precision indicator. 70 IF (kdflag==0 .AND. keswch==1) CALL fmim(1,mlv3) GO TO 100 ! State 7. Sign of the exponent. 80 ksignx = kval GO TO 100 ! State 8. Digits of the exponent. 90 kexp = 10*kexp + kval ktenex = 10*ktenex IF (ktenex>large) THEN IF (ktenex/=k10pwr .AND. mlv5(2)/=0) THEN CALL fmim(ktenex,ma) k10pwr = ktenex END IF IF (mlv5(2)==0) THEN CALL fmim(kexp,mlv5) ELSE ndig = int(max(m2,min(mlv5(1)+ma(1),mndsv1))) CALL fmmpy2(mlv5,ma,mlv5) ndig = ndsav1 CALL fmim(kexp,mlv2) ndig = int(max(m2,min(max(mlv5(1),mlv2(1))+1,mndsv1))) IF (kexp/=0) CALL fmadd2(mlv5,mlv2,mlv5) ndig = ndsav1 END IF kexp = 0 ktenex = 1 END IF 100 CONTINUE ! Form the number and return. ! MA = KSIGN*(MLV3 + MLV4/10.0**N2)*10.0**MLV5 IF (ktenf1>1) THEN IF (ktenf1/=k10pwr .AND. mlv3(2)/=0) THEN CALL fmim(ktenf1,ma) k10pwr = ktenf1 END IF IF (mlv3(2)==0) THEN CALL fmim(kf1,mlv3) ELSE ndig = int(max(m2,min(mlv3(1)+ma(1),mndsv1))) CALL fmmpy2(mlv3,ma,mlv3) ndig = ndsav1 CALL fmim(kf1,mlv2) ndig = int(max(m2,min(max(mlv3(1),mlv2(1))+1,mndsv1))) IF (kf1/=0) CALL fmadd2(mlv3,mlv2,mlv3) ndig = ndsav1 END IF END IF IF (ktenf2>1) THEN IF (ktenf2/=k10pwr .AND. mlv4(2)/=0) THEN CALL fmim(ktenf2,ma) k10pwr = ktenf2 END IF IF (mlv4(2)==0) THEN CALL fmim(kf2,mlv4) ELSE ndig = int(max(m2,min(mlv4(1)+ma(1),mndsv1))) CALL fmmpy2(mlv4,ma,mlv4) ndig = ndsav1 CALL fmim(kf2,mlv2) ndig = int(max(m2,min(max(mlv4(1),mlv2(1))+1,mndsv1))) IF (kf2/=0) CALL fmadd2(mlv4,mlv2,mlv4) ndig = ndsav1 END IF END IF IF (ktenex>1) THEN IF (ktenex/=k10pwr .AND. mlv5(2)/=0) THEN CALL fmim(ktenex,ma) k10pwr = ktenex END IF IF (mlv5(2)==0) THEN CALL fmim(kexp,mlv5) ELSE ndig = int(max(m2,min(mlv5(1)+ma(1),mndsv1))) CALL fmmpy2(mlv5,ma,mlv5) ndig = ndsav1 CALL fmim(kexp,mlv2) ndig = int(max(m2,min(max(mlv5(1),mlv2(1))+1,mndsv1))) IF (kexp/=0) CALL fmadd2(mlv5,mlv2,mlv5) ndig = ndsav1 END IF END IF IF (ksignx==-1) mlv5(2) = -mlv5(2) IF (mlv4(2)/=0) THEN CALL fmim(10,mlv2) k = n2 IF (mod(k,2)==0) THEN CALL fmim(1,ma) ELSE CALL fmeq(mlv2,ma) END IF 110 k = k/2 ndig = int(max(m2,min(2*mlv2(1),mndsv1))) CALL fmmpy2(mlv2,mlv2,mlv2) IF (mod(k,2)==1) THEN ndig = int(max(m2,min(mlv2(1)+ma(1),mndsv1))) CALL fmmpy2(mlv2,ma,ma) END IF IF (k>1) GO TO 110 ndig = ndsav1 CALL fmdiv2(mlv4,ma,mlv4) END IF IF (mlv5(2)/=0) THEN CALL fmim(10,mlv2) kwrnsv = kwarn kwarn = 0 CALL fmmi(mlv5,kexp) kwarn = kwrnsv IF (kflag/=0) GO TO 150 k = abs(kexp) IF (mod(k,2)==0) THEN CALL fmim(1,mlv5) ELSE CALL fmeq(mlv2,mlv5) END IF 120 k = k/2 ndig = int(max(m2,min(2*mlv2(1),mndsv1))) CALL fmmpy2(mlv2,mlv2,mlv2) IF (mod(k,2)==1) THEN ndig = int(max(m2,min(mlv2(1)+mlv5(1),mndsv1))) CALL fmmpy2(mlv2,mlv5,mlv5) END IF IF (k>1) GO TO 120 ndig = ndsav1 IF (kexp<0) THEN CALL fmim(1,mlv2) CALL fmdiv2(mlv2,mlv5,mlv5) END IF END IF CALL fmadd2(mlv3,mlv4,ma) IF (mlv5(2)/=0) CALL fmmpy2(ma,mlv5,ma) IF (ksign==-1) ma(2) = -ma(2) 130 CALL fmeq2(ma,ma,ndig,ndsave,1) IF (ma(1)==munkno) GO TO 150 140 ndig = ndsave kaccsw = kasave kround = krsave IF (kflag==1) kflag = 0 ma(0) = nint(ndig*alogm2) ncall = ncall - 2 RETURN ! Error in converting the number. 150 CALL fmim(0,ma) ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) kflag = -7 ncall = ncall - 1 CALL fmwarn ncall = ncall + 1 GO TO 140 90000 FORMAT (/' Error in input conversion.'/ & ' ICHAR function was out of range for the current', & ' dimensions.'/' ICHAR(''',A,''') gave the value ',I12, & ', which is outside the currently'/' dimensioned',' bounds of (',I5, & ':',I5,') for variables KHASHT ','and KHASHV.'/ & ' Re-define the two parameters ', & 'LHASH1 and LHASH2 so the dimensions will'/' contain', & ' all possible output values from ICHAR.'//) END SUBROUTINE fminp SUBROUTINE fminp2(ma,line,kstart,kstop,jtrans,kpower,mlv3,mlv4,mlv5) ! Internal routine for input conversion for a power of ten MBASE. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC ichar, int, mod, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kpower, kstart, kstop ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mlv3(0:lunpck), mlv4(0:lunpck), mlv5(0:lunpck) INTEGER :: jtrans(8,4) CHARACTER (1) :: line(kstop) ! .. ! .. Local Scalars .. INTEGER :: j, jstate, kdflag, kexp, kf1, kf1dig, kf2, kf2dig, kf2pt, & knzdig, kpt, kshift, ksign, ksignx, ktype, kval, large ! .. ! .. External Subroutines .. EXTERNAL fmadd2, fmdivn, fmim, fmmpy2, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. jstate = 1 kdflag = 0 ksign = 1 ksignx = 1 kf1 = 0 knzdig = 0 kf1dig = 0 kf2 = 0 kf2dig = 0 kf2pt = 2 kexp = 0 large = int(intmax/10) ! Scan the number. DO 70 j = kstart, kstop IF (line(j)==' ') GO TO 70 kpt = ichar(line(j)) IF (kptlhash2) THEN WRITE (kw,90000) line(j), kpt, lhash1, lhash2 ktype = 5 kval = 0 ELSE ktype = khasht(kpt) kval = khashv(kpt) END IF IF (ktype>=5) GO TO 80 jstate = jtrans(jstate,ktype) GO TO (80,10,20,70,30,40,50,60,80) jstate ! State 2. Sign of the number. 10 ksign = kval GO TO 70 ! State 3. Digits before a decimal point. 20 kdflag = 1 kf1 = 10*kf1 + kval IF (kval>0 .OR. knzdig/=0) THEN knzdig = 1 kf1dig = kf1dig + 1 END IF IF (kf1dig==kpower) THEN mlv3(1) = mlv3(1) + 1 IF (mlv3(1)ndig+1) GO TO 70 kf2 = 10*kf2 + kval kf2dig = kf2dig + 1 IF (kf2dig==kpower) THEN mlv4(kf2pt) = kf2 IF (kf2==0 .AND. kf2pt==2) THEN mlv4(1) = mlv4(1) - 1 ELSE kf2pt = kf2pt + 1 END IF kf2 = 0 kf2dig = 0 END IF GO TO 70 ! State 6. Precision indicator. 40 IF (kdflag==0 .AND. keswch==1) CALL fmim(1,mlv3) GO TO 70 ! State 7. Sign of the exponent. 50 ksignx = kval GO TO 70 ! State 8. Digits of the exponent. 60 IF (kexp>=large) THEN IF (mlv3(2)==0 .AND. mlv4(2)==0) THEN CALL fmim(0,ma) RETURN END IF CALL fmim(0,ma) IF (ksignx==1) THEN ma(1) = mexpov kflag = -4 ELSE ma(1) = mexpun kflag = -4 END IF ma(2) = ksign ma(0) = nint(ndig*alogm2) ncall = ncall - 1 CALL fmwarn ncall = ncall + 1 RETURN END IF kexp = 10*kexp + kval 70 CONTINUE ! Form the number and return. ! MA = KSIGN*(MLV3 + MLV4)*10.0**(KSIGNX*KEXP) IF (kf1dig/=0) THEN mlv3(1) = mlv3(1) + 1 kshift = 10**(kpower-kf1dig) IF (mlv3(1)1) THEN CALL fmdivn(mlv3,kshift,mlv3) END IF END IF IF (kf2dig/=0) THEN kshift = 10**(kpower-kf2dig) mlv4(kf2pt) = kf2*kshift END IF IF (mlv4(2)==0) mlv4(1) = 0 IF (kexp/=0) THEN IF (ksignx==1) THEN mlv5(1) = int(kexp/kpower) + 1 mlv5(2) = 10**(mod(kexp,kpower)) ELSE mlv5(1) = -int((kexp-1)/kpower) kshift = 10**(mod(kexp,kpower)) IF (kshift>1) THEN mlv5(2) = mbase/kshift ELSE mlv5(2) = 1 END IF END IF END IF CALL fmadd2(mlv3,mlv4,ma) IF (kexp>0) CALL fmmpy2(ma,mlv5,ma) ma(2) = ksign*ma(2) RETURN ! Error in converting the number. 80 CALL fmim(0,ma) ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) RETURN 90000 FORMAT (/' Error in input conversion.'/ & ' ICHAR function was out of range for the current', & ' dimensions.'/' ICHAR(''',A,''') gave the value ',I12, & ', which is outside the currently'/' dimensioned',' bounds of (',I5, & ':',I5,') for variables KHASHT ','and KHASHV.'/ & ' Re-define the two parameters ', & 'LHASH1 and LHASH2 so the dimensions will'/' contain', & ' all possible output values from ICHAR.'//) END SUBROUTINE fminp2 SUBROUTINE fmint(ma,mb) ! MB = INT(MA) ! The integer part of MA is computed and returned in MB as a multiple ! precision floating point number. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, macmax INTEGER :: j, ka, kb, kreslt, n1 ! .. ! .. External Subroutines .. EXTERNAL fmargs, fmcons, fmntr, fmrslt ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons macca = ma(0) kflag = 0 ncall = ncall + 1 namest(ncall) = 'FMINT ' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) IF (abs(ma(1))>mexpab) THEN CALL fmargs('FMINT ',1,ma,mb,kreslt) IF (kreslt/=0) THEN CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF END IF n1 = ndig + 1 ! If MA is less than one in magnitude, return zero. IF (ma(1)<=0) THEN DO 10 j = 1, n1 mb(j) = 0 10 CONTINUE GO TO 50 END IF ! If the radix point is off the right end of MA then MA is ! already an integer. Return MA. IF (ma(1)>=ndig) THEN DO 20 j = 1, n1 mb(j) = ma(j) 20 CONTINUE GO TO 50 END IF ! Here MA has both integer and fraction parts. Replace ! the digits right of the radix point by zeros. ka = int(ma(1)) + 2 kb = ka - 1 DO 30 j = 1, kb mb(j) = ma(j) 30 CONTINUE DO 40 j = ka, n1 mb(j) = 0 40 CONTINUE 50 IF (kaccsw==1) THEN macmax = nint((ndig-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(macca,macmax) ELSE mb(0) = macca END IF IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END SUBROUTINE fmint SUBROUTINE fmipwr(ma,ival,mb) ! MB = MA ** IVAL ! Raise an FM number to an integer power. ! The binary multiplication method used requires an average of ! 1.5 * LOG2(IVAL) multiplications. MA may be negative. IMPLICIT NONE ! Scratch array usage during FMIPWR: M01 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, mod, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, macmax REAL :: xval INTEGER :: j, jsign, k, kwrnsv, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmdiv, fmeq, fmeq2, fmi2m, fmim, fmmpy, fmntr, fmntri, & fmsqr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons kflag = 0 ncall = ncall + 1 namest(ncall) = 'FMIPWR' IF (ntrace/=0) THEN CALL fmntr(2,ma,ma,1) CALL fmntri(2,ival,0) END IF ! Check for special cases. IF (ma(1)==munkno .OR. (ival<=0 .AND. ma(2)==0)) THEN ma2 = ma(2) CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -4 IF (ival<=0 .AND. ma2==0) CALL fmwarn IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF IF (ival==0) THEN CALL fmim(1,mb) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF IF (abs(ival)==1) THEN kwrnsv = kwarn kwarn = 0 IF (ival==1) THEN CALL fmeq(ma,mb) ELSE CALL fmim(1,m01) CALL fmdiv(m01,ma,mb) END IF IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 kwarn = kwrnsv RETURN END IF IF (ma(2)==0) THEN CALL fmeq(ma,mb) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF IF (ma(1)==mexpov) THEN jsign = 1 IF (ma(2)<0) jsign = -1 CALL fmim(0,mb) IF (ival>0) THEN mb(1) = mexpov mb(2) = jsign**mod(ival,2) mb(0) = nint(ndig*alogm2) kflag = -5 ELSE mb(1) = mexpun mb(2) = jsign**mod(ival,2) mb(0) = nint(ndig*alogm2) kflag = -6 END IF IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF IF (ma(1)==mexpun) THEN jsign = 1 IF (ma(2)<0) jsign = -1 CALL fmim(0,mb) IF (ival>0) THEN mb(1) = mexpun mb(2) = jsign**mod(ival,2) mb(0) = nint(ndig*alogm2) kflag = -6 ELSE mb(1) = mexpov mb(2) = jsign**mod(ival,2) mb(0) = nint(ndig*alogm2) kflag = -5 END IF IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF ! Increase the working precision. ndsave = ndig IF (ncall==1) THEN xval = abs(ival) k = int((5.0*real(dlogtn)+log(xval))/alogmb+2.0) ndig = max(ndig+k,2) ELSE xval = abs(ival) IF (xval>10.0 .OR. real(mbase)<=999.0) THEN k = int(log(xval)/alogmb+1.0) ndig = ndig + k END IF END IF IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mb(j+1) = 0 10 CONTINUE ndig = ndsave IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF ! Initialize. kwrnsv = kwarn kwarn = 0 k = abs(ival) macca = ma(0) CALL fmeq2(ma,m01,ndsave,ndig,0) m01(0) = nint(ndig*alogm2) IF (mod(k,2)==0) THEN CALL fmi2m(1,mb) ELSE CALL fmeq(m01,mb) END IF ! This is the multiplication loop. 20 k = k/2 CALL fmsqr(m01,m01) IF (mod(k,2)==1) CALL fmmpy(m01,mb,mb) IF (k>1) GO TO 20 ! Invert if the exponent is negative. IF (ival<0) THEN CALL fmi2m(1,m01) CALL fmdiv(m01,mb,mb) END IF kwarn = kwrnsv ! Round the result and return. CALL fmeq2(mb,mb,ndig,ndsave,1) ndig = ndsave IF (kaccsw==1) THEN macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) ELSE mb(0) = macca END IF IF (kflag<0) CALL fmwarn IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END SUBROUTINE fmipwr SUBROUTINE fmlg10(ma,mb) ! MB = LOG10(MA) IMPLICIT NONE ! Scratch array usage during FMLG10: M01 - M05 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, macmax, mxsave INTEGER :: k, kasave, kovun, kreslt, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdiv, fmentr, fmeq2, fmexit, fmln, fmlni, & fmntr, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)<=0) THEN CALL fmentr('FMLG10',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMLG10' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52-1,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) CALL fmln(mb,mb) IF (mbase/=mbsli .OR. ndig>ndigli) THEN CALL fmlni(10,m03) ELSE CALL fmadd(mln1,mln3,m03) END IF CALL fmdiv(mb,m03,mb) ! Round the result and return. macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmlg10 SUBROUTINE fmln(ma,mb) ! MB = LOG(MA) (Natural logarithm) IMPLICIT NONE ! Scratch array usage during FMLN: M01 - M05 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma1, macca, macmax, mxsave REAL (KIND(0.0D0)) :: y REAL :: x INTEGER :: iextra, ival, j, k, k2, k2exp, kasave, kbot, km1, kovun, & kreslt, kscale, kst, kwrnsv, last, n1, n3, ndsav1, ndsave, ndsv ! .. ! .. Local Arrays .. INTEGER :: nstack(19) ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdig, fmdiv, fmdivi, fmdpm, fmentr, fmeq, & fmeq2, fmexit, fmexp, fmi2m, fmlni, fmm2dp, fmm2i, fmmpy, fmmpyi, & fmntr, fmrslt, fmsqr, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)<=0) THEN CALL fmentr('FMLN ',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMLN ' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52-1,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF ! If MA is close to 1, use the Taylor series: ! LN(1+X) = X - X**2/2 + X**3/3 - ... ! This is faster for small X and avoids cancellation error. ! This method is faster for moderate sized NDIG, but is ! asymptotically slower by a factor of NDIG**(2/3) than ! using Newton and FMEXP. For MBASE=10,000 the Taylor ! series is faster for NDIG less than about 150 (and is ! used only when MA is between .9999 and 1.0001). IF (ma(1)==0 .OR. ma(1)==1) THEN x = real(mbase) x = x**(int(ma(1))-1)*(real(ma(2))+real(ma(3))/x) ELSE x = 2.0 END IF IF (x>0.9999 .AND. x<=1.0001) THEN macca = ma(0) CALL fmeq2(ma,m03,ndsave,ndig,0) m03(0) = nint(ndig*alogm2) CALL fmi2m(-1,m01) CALL fmadd(m03,m01,m03) ! The sum will be done as two concurrent series. ndsav1 = ndig CALL fmeq(m03,m04) CALL fmdivi(m03,2,m05) CALL fmsqr(m03,mb) CALL fmeq(m03,m02) kbot = 2 10 kbot = kbot + 1 CALL fmmpy(m02,mb,m02) CALL fmdivi(m02,kbot,m01) ndig = ndsav1 CALL fmadd(m04,m01,m04) ndig = max(2,ndsav1-int(m04(1)-m01(1))) kbot = kbot + 1 CALL fmdivi(m02,kbot,m01) ndig = ndsav1 CALL fmadd(m05,m01,m05) ndig = max(2,ndsav1-int(m04(1)-m01(1))) IF (kflag/=1) GO TO 10 ndig = ndsav1 CALL fmmpy(m05,m03,m05) CALL fmsub(m04,m05,mb) GO TO 70 END IF ma1 = ma(1) macca = ma(0) CALL fmeq2(ma,m05,ndsave,ndig,0) m05(0) = nint(ndig*alogm2) ! Compute IEXTRA, the number of extra digits required. CALL fmi2m(1,m04) CALL fmsub(m04,m05,m04) iextra = max(0-int(m04(1)),0) IF (iextra>0 .AND. ndig+iextra<=ndg2mx) THEN CALL fmeq2(m05,m05,ndig,ndig+iextra,1) END IF ndig = ndig + iextra IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 20 j = 2, ndsave mb(j+1) = 0 20 CONTINUE ndig = ndig - iextra CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END IF ! Check to see if the argument is a small integer. ! If so use FMLNI. km1 = 0 kwrnsv = kwarn kwarn = 0 CALL fmm2i(m05,ival) kwarn = kwrnsv IF (kflag==0 .AND. ival10) ndiglb = 0 ndig = ndsv END IF IF (kscale/=0 .AND. km1==0) THEN CALL fmmpyi(mlbsav,kscale,mb) CALL fmadd(m04,mb,mb) ELSE IF (kscale/=0 .AND. km1==1) THEN CALL fmmpyi(mlbsav,kscale,mb) ELSE IF (kscale==0 .AND. km1==0) THEN CALL fmeq(m04,mb) ELSE IF (kscale==0 .AND. km1==1) THEN CALL fmi2m(0,mb) END IF IF (k2exp/=0) THEN IF (mbase/=mbsli .OR. ndig>ndigli) THEN CALL fmlni(2,m04) END IF CALL fmmpyi(mln1,k2exp,m04) CALL fmadd(mb,m04,mb) END IF ! Round the result and return. 70 macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmln SUBROUTINE fmlni(ival,ma) ! MA = LOG(IVAL) ! Compute the natural logarithm of an integer IVAL. ! If IVAL has only powers of 2, 3, 5, and 7 in its factorization then ! FMLNI is faster than FMLN. Otherwise, if IVAL.GE.MXBASE (i.e., IVAL ! does not fit in 1/2 word) then FMLN is usually faster. ! Use FMLN instead of FMLNI if 10*IVAL would cause integer overflow. IMPLICIT NONE ! Scratch array usage during FMLNI: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC abs, dble, int, log, max, min, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL :: xval INTEGER :: int2, j, j2, j3, j5, j7, jtemp2, jtemp3, jtemp5, jtemp7, k, & k2, k3, k5, k7, kasave, kdelta, last, nd, ndmb, ndsave, ndsv, nt CHARACTER (155) :: string ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdivi, fmeq2, fmi2m, fmim, fmlni2, fmmpyi, & fmntr, fmntri, fmst2m, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons kflag = 0 ncall = ncall + 1 namest(ncall) = 'FMLNI ' IF (ntrace/=0) CALL fmntri(2,ival,1) ! Check for special cases. IF (ival<=0) THEN CALL fmim(0,ma) ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) kflag = -4 CALL fmwarn IF (ntrace/=0) CALL fmntr(1,ma,ma,1) ncall = ncall - 1 RETURN END IF IF (ival==1) THEN CALL fmi2m(0,ma) IF (ntrace/=0) CALL fmntr(1,ma,ma,1) ncall = ncall - 1 RETURN END IF ! Increase the working precision. ndsave = ndig IF (ncall==1) THEN k = ngrd52 ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ma(1) = munkno ma(2) = 1 ma(0) = nint(ndsave*alogm2) DO 10 j = 2, ndsave ma(j+1) = 0 10 CONTINUE ndig = ndsave IF (ntrace/=0) CALL fmntr(1,ma,ma,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 ! Find integers K2, K3, K5, and K7 such that ! NT = 2**K2 * 3**K3 * 5**K5 * 7**K7 ! is a good approximation of IVAL. ! KDELTA = ABS(IVAL - NT). int2 = ival IF (ival>intmax/100) int2 = ival/100 kdelta = int2 nt = 0 k2 = 0 k3 = 0 k5 = 0 k7 = 0 ! Start the search loop. xval = int2 last = int(log(dble(xval))/dlogtw+2.0D0) jtemp7 = 1 DO 80 j7 = 1, last IF (jtemp7>int2 .AND. abs(jtemp7-int2)>kdelta) GO TO 90 jtemp5 = jtemp7 DO 60 j5 = 1, last IF (jtemp5>int2 .AND. abs(jtemp5-int2)>kdelta) GO TO 70 jtemp3 = jtemp5 DO 40 j3 = 1, last IF (jtemp3>int2 .AND. abs(jtemp3-int2)>kdelta) GO TO 50 jtemp2 = jtemp3 DO 20 j2 = 1, last IF (abs(jtemp2-int2)<=kdelta) THEN IF (abs(jtemp2-int2)==kdelta .AND. jtemp2int2) GO TO 30 jtemp2 = 2*jtemp2 20 CONTINUE 30 jtemp3 = 3*jtemp3 40 CONTINUE 50 jtemp5 = 5*jtemp5 60 CONTINUE 70 jtemp7 = 7*jtemp7 80 CONTINUE ! If IVAL was too close to the integer overflow limit, ! restore NT to an approximation of IVAL. 90 IF (int2/=ival) THEN IF (nt<=int2) THEN nt = nt*100 k2 = k2 + 2 k5 = k5 + 2 ELSE IF (nt<=ival/98) THEN nt = nt*98 k2 = k2 + 1 k7 = k7 + 2 ELSE nt = nt*70 k2 = k2 + 1 k5 = k5 + 1 k7 = k7 + 1 END IF END IF ! End of the search. Now compute LN(NT) as a linear ! combination of LN(2), LN(3), LN(5), and LN(7). IF (mbase/=mbsli .OR. ndig>ndigli) THEN ndmb = int(150.0*2.302585/alogmb) IF (ndmb>=ndig) THEN ndsv = ndig ndig = min(ndmb,ndg2mx) string = '0.693147180559945309417232121458176568075500' // & '13436025525412068000949339362196969471560586332699641' // & '8687542001481020570685733685520235758130557032670751635' CALL fmst2m(string,mln1) string = '1.098612288668109691395245236922525704647490' // & '55782274945173469433363749429321860896687361575481373' // & '2088787970029065957865742368004225930519821052801870767' CALL fmst2m(string,mln2) string = '1.609437912434100374600759333226187639525601' // & '35426851772191264789147417898770765776463013387809317' // & '9610799966303021715562899724005229324676199633616617464' CALL fmst2m(string,mln3) string = '1.945910149055313305105352743443179729637084' // & '72958186118845939014993757986275206926778765849858787' // & '1526993061694205851140911723752257677786843148958095164' CALL fmst2m(string,mln4) mbsli = mbase ndigli = ndig IF (abs(mln1(1))>10 .OR. abs(mln2(1))>10 .OR. abs(mln3( & 1))>10 .OR. abs(mln4(1))>10) ndigli = 0 ELSE ndsv = ndig ndig = min(ndig+2,ndg2mx) mbsli = mbase ndigli = ndig CALL fmlni2(1,126,mln1) CALL fmlni2(1,225,mln2) CALL fmlni2(1,2401,mln3) CALL fmlni2(1,4375,mln4) ! Get Ln(2). CALL fmmpyi(mln1,-72,mln1) CALL fmmpyi(mln2,-27,ma) CALL fmadd(mln1,ma,mln1) CALL fmmpyi(mln3,19,ma) CALL fmadd(mln1,ma,mln1) CALL fmmpyi(mln4,-31,ma) CALL fmadd(mln1,ma,mln1) ! Get Ln(3). CALL fmmpyi(mln2,-3,mln2) CALL fmmpyi(mln1,19,ma) CALL fmadd(mln2,ma,mln2) CALL fmsub(mln2,mln3,mln2) CALL fmadd(mln2,mln4,mln2) CALL fmdivi(mln2,12,mln2) ! Get Ln(5). CALL fmsub(mln3,mln1,mln3) CALL fmmpyi(mln2,27,ma) CALL fmadd(mln3,ma,mln3) CALL fmmpyi(mln4,-4,ma) CALL fmadd(mln3,ma,mln3) CALL fmdivi(mln3,18,mln3) ! Get Ln(7). CALL fmsub(mln1,mln4,mln4) CALL fmmpyi(mln2,7,ma) CALL fmadd(mln4,ma,mln4) CALL fmmpyi(mln3,-4,ma) CALL fmadd(mln4,ma,mln4) END IF mln1(0) = nint(ndig*alogm2) mln2(0) = mln1(0) mln3(0) = mln1(0) mln4(0) = mln1(0) IF (abs(mln1(1))>10 .OR. abs(mln2(1))>10 .OR. abs(mln3( & 1))>10 .OR. abs(mln4(1))>10) ndigli = 0 ndig = ndsv END IF ! If NT.NE.IVAL then the final step is to compute ! LN(IVAL/NT) and then use LN(IVAL) = LN(IVAL/NT) + LN(NT). IF (nt/=ival) THEN nd = nt - ival CALL fmlni2(nd,nt,ma) END IF CALL fmmpyi(mln1,k2,m02) CALL fmmpyi(mln2,k3,m01) CALL fmadd(m02,m01,m02) CALL fmmpyi(mln3,k5,m01) CALL fmadd(m02,m01,m02) CALL fmmpyi(mln4,k7,m01) IF (nt/=ival) CALL fmadd(m02,ma,m02) CALL fmadd(m02,m01,ma) ! Round and move the result to MA. kaccsw = kasave CALL fmeq2(ma,ma,ndig,ndsave,1) ndig = ndsave IF (ntrace/=0) CALL fmntr(1,ma,ma,1) ncall = ncall - 1 RETURN END SUBROUTINE fmlni SUBROUTINE fmlni2(int1,int2,ma) ! MA = LN(1 - INT1/INT2) ! Taylor series for computing the logarithm of a rational number ! near 1. IMPLICIT NONE ! Scratch array usage during FMLNI2: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: int1, int2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmdivi, fmeq, fmi2m, fmmpyi ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. CALL fmi2m(int1,m02) CALL fmdivi(m02,int2,m02) CALL fmeq(m02,ma) ndsave = ndig j = 1 10 j = j + 1 IF (int1/=1) CALL fmmpyi(m02,int1,m02) CALL fmdivi(m02,int2,m02) CALL fmdivi(m02,j,m01) ndig = ndsave CALL fmadd(ma,m01,ma) ndig = ndsave - int(ma(1)-m01(1)) IF (ndig<2) ndig = 2 IF (kflag/=1) GO TO 10 ndig = ndsave ma(0) = nint(ndig*alogm2) ma(2) = -ma(2) RETURN END SUBROUTINE fmlni2 SUBROUTINE fmm2dp(ma,x) ! X = MA ! Convert an FM number to double precision. ! If KFLAG = -4 is returned for a value of MA that is in the range ! of the machine's double precision number system, change the ! definition of DPMAX in routine FMSET to reflect the current machine's ! range. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dble ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kreslt ! .. ! .. External Subroutines .. EXTERNAL fmargs, fmmd, fmntr, fmntrr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMM2DP' kreslt = 0 IF (abs(ma(1))>mexpab) THEN CALL fmargs('FMM2DP',1,ma,ma,kreslt) END IF IF (ntrace/=0) CALL fmntr(2,ma,ma,1) IF (kreslt/=0) THEN ! Here no valid result can be returned. Set X to some ! value that the user is likely to recognize as wrong. x = dble(runkno) kflag = -4 IF (ma(1)/=munkno) CALL fmwarn IF (ntrace/=0) CALL fmntrr(1,x,1) ncall = ncall - 1 RETURN END IF CALL fmmd(ma,x) IF (ntrace/=0) CALL fmntrr(1,x,1) ncall = ncall - 1 RETURN END SUBROUTINE fmm2dp SUBROUTINE fmm2i(ma,ival) ! IVAL = MA ! Convert an FM number to integer. ! KFLAG = 0 is returned if the conversion is exact. ! = -4 is returned if MA is larger than INTMAX in magnitude. ! IVAL = IUNKNO is returned as an indication that IVAL ! could not be computed without integer overflow. ! = 2 is returned if MA is smaller than INTMAX in magnitude ! but MA is not an integer. The next integer toward zero ! is returned in IVAL. ! It is sometimes convenient to call FMM2I to see if an FM number ! can be represented as a one-word integer, by checking KFLAG upon ! return. To avoid an unwanted error message being printed in the ! KFLAG=-4 case, set KWARN=0 before the call to FMM2I and reset it ! after the call. ! This routine performs the trace printing for the conversion. ! FMMI is used to do the arithmetic. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmmi, fmntr, fmntri ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMM2I ' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) CALL fmmi(ma,ival) IF (ntrace/=0) CALL fmntri(1,ival,1) ncall = ncall - 1 RETURN END SUBROUTINE fmm2i SUBROUTINE fmm2sp(ma,x) ! X = MA ! Convert an FM number to single precision. ! MA is converted and the result is returned in X. ! If KFLAG = -4 is returned for a value of MA that is in the range ! of the machine's single precision number system, change the ! definition of SPMAX in routine FMSET to reflect the current machine's ! range. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dble, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: y INTEGER :: kreslt ! .. ! .. External Subroutines .. EXTERNAL fmargs, fmmd, fmntr, fmntrr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMM2SP' kreslt = 0 IF (abs(ma(1))>mexpab) THEN CALL fmargs('FMM2SP',1,ma,ma,kreslt) END IF IF (ntrace/=0) CALL fmntr(2,ma,ma,1) IF (kreslt/=0) THEN ! Here no valid result can be returned. Set X to some ! value that the user is likely to recognize as wrong. x = runkno kflag = -4 IF (ma(1)/=munkno) CALL fmwarn y = dble(x) IF (ntrace/=0) CALL fmntrr(1,y,1) ncall = ncall - 1 RETURN END IF CALL fmmd(ma,y) x = real(y) IF (ntrace/=0) THEN y = dble(x) CALL fmntrr(1,y,1) END IF ncall = ncall - 1 RETURN END SUBROUTINE fmm2sp SUBROUTINE fmmax(ma,mb,mc) ! MC = MAX(MA,MB) IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwrnsv ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmim, fmntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 ncall = ncall + 1 namest(ncall) = 'FMMAX ' IF (ntrace/=0) CALL fmntr(2,ma,mb,2) kwrnsv = kwarn kwarn = 0 IF (ma(1)==munkno .OR. mb(1)==munkno) THEN CALL fmim(0,mc) mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) kflag = -4 ELSE IF (fmcomp(ma,'LT',mb)) THEN CALL fmeq(mb,mc) ELSE CALL fmeq(ma,mc) END IF kwarn = kwrnsv IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END SUBROUTINE fmmax SUBROUTINE fmmd(ma,x) ! X = MA ! Internal routine for conversion to double precision. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dble, log ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma1, ma2 REAL (KIND(0.0D0)) :: dlogdp, one, pmax, rzero, xbase, y, yt INTEGER :: j, kwrnsv, n1, ncase ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmmi, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! Check to see if MA is in range for single or double ! precision. IF (mblogs/=mbase) CALL fmcons pmax = dpmax IF (ncall>0) THEN IF (namest(ncall)=='FMM2SP') pmax = dble(spmax) END IF dlogdp = log(pmax) ma1 = ma(1) ncase = 0 IF (dble(ma(1)-1)*dlogmb>dlogdp) THEN kflag = -4 x = dble(runkno) CALL fmwarn RETURN ELSE IF (dble(ma(1)+1)*dlogmb>dlogdp) THEN ma(1) = ma(1) - 2 ncase = 1 ELSE IF (dble(ma(1)+1)*dlogmb<-dlogdp) THEN kflag = -10 x = 0.0D0 CALL fmwarn RETURN ELSE IF (dble(ma(1)-1)*dlogmb<-dlogdp) THEN ma(1) = ma(1) + 2 ncase = 2 END IF ! Try FMMI first so that small integers will be ! converted exactly. kwrnsv = kwarn kwarn = 0 CALL fmmi(ma,j) kwarn = kwrnsv IF (kflag==0) THEN x = j RETURN END IF kflag = 0 ma2 = ma(2) ma(2) = abs(ma2) rzero = 0.0D0 one = 1.0D0 n1 = ndig + 1 xbase = mbase x = rzero y = one DO 10 j = 2, n1 y = y/xbase yt = ma(j) x = x + y*yt yt = one + y*xbase IF (yt<=one) GO TO 20 10 CONTINUE 20 x = x*xbase**ma(1) IF (ma2<0) x = -x ma(2) = ma2 ! Check the result if it is near overflow or underflow. IF (ncase==1) THEN IF (x<=pmax/(xbase*xbase)) THEN x = x*xbase*xbase ELSE kflag = -4 x = dble(runkno) CALL fmwarn END IF ELSE IF (ncase==2) THEN IF (x>=(1.0D0/pmax)*xbase*xbase) THEN x = x/(xbase*xbase) ELSE kflag = -10 x = 0.0D0 CALL fmwarn END IF END IF ma(1) = ma1 RETURN END SUBROUTINE fmmd SUBROUTINE fmmi(ma,ival) ! IVAL = MA. Internal FM to integer conversion routine. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, ka, kb, large, n1 ! .. ! .. External Subroutines .. EXTERNAL fmwarn ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 n1 = ndig + 1 large = int(intmax/mbase) ival = 0 IF (ma(1)<=0) THEN IF (ma(2)/=0) kflag = 2 RETURN END IF kb = int(ma(1)) + 1 ival = int(abs(ma(2))) IF (kb>=3) THEN DO 10 j = 3, kb IF (ival>large) THEN kflag = -4 IF (ma(1)/=munkno) CALL fmwarn ival = iunkno RETURN END IF IF (j<=n1) THEN ival = ival*int(mbase) IF (ival>intmax-ma(j)) THEN kflag = -4 IF (ma(1)/=munkno) CALL fmwarn ival = iunkno RETURN ELSE ival = ival + int(ma(j)) END IF ELSE ival = ival*int(mbase) END IF 10 CONTINUE END IF IF (ma(2)<0) ival = -ival ! Check to see if MA is an integer. ka = kb + 1 IF (ka<=n1) THEN DO 20 j = ka, n1 IF (ma(j)/=0) THEN kflag = 2 RETURN END IF 20 CONTINUE END IF RETURN END SUBROUTINE fmmi SUBROUTINE fmmin(ma,mb,mc) ! MC = MIN(MA,MB) IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwrnsv ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmim, fmntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 ncall = ncall + 1 namest(ncall) = 'FMMIN ' IF (ntrace/=0) CALL fmntr(2,ma,mb,2) kwrnsv = kwarn kwarn = 0 IF (ma(1)==munkno .OR. mb(1)==munkno) THEN CALL fmim(0,mc) mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) kflag = -4 ELSE IF (fmcomp(ma,'GT',mb)) THEN CALL fmeq(mb,mc) ELSE CALL fmeq(ma,mc) END IF kwarn = kwrnsv IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END SUBROUTINE fmmin SUBROUTINE fmmod(ma,mb,mc) ! MC = MA(MOD MB). IMPLICIT NONE ! Scratch array usage during FMMOD: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, mod, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, maccb, macmax, mvb, mvc, mvy, mvz, mxsave INTEGER :: j, k, kasave, kb, ke, kn, kovun, kreslt, kwrnsv, ndsave, & ntrsav ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdiv, fmentr, fmeq2, fmexit, fmi2m, fmint, & fmm2i, fmmpy, fmntr, fmrslt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. abs(mb(1))>mexpab) THEN CALL fmentr('FMMOD ',ma,mb,2,mc,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMMOD ' IF (ntrace/=0) CALL fmntr(2,ma,mb,2) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 IF (mb(1)==mexpov .OR. mb(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52-1,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,mb,mc,kreslt) IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw mxsave = mxexp mxexp = mxexp2 END IF kwrnsv = kwarn kwarn = 0 macca = ma(0) maccb = mb(0) IF (mb(1)>ma(1) .AND. mb(2)/=0) THEN CALL fmeq2(ma,m01,ndsave,ndig,0) m01(0) = nint(ndig*alogm2) ELSE ! Special cases when MB is a small integer. CALL fmeq2(ma,m02,ndsave,ndig,0) m02(0) = nint(ndig*alogm2) CALL fmeq2(mb,m03,ndsave,ndig,0) m03(0) = nint(ndig*alogm2) CALL fmm2i(m03,kb) IF (kflag==0 .AND. kb=ndig) THEN CALL fmi2m(0,m01) GO TO 70 ELSE CALL fmint(m02,m03) CALL fmsub(m02,m03,m01) GO TO 70 END IF ELSE IF (m02(1)==mexpov .OR. kb==0) THEN kflag = -4 kwarn = kwrnsv kaccsw = kasave mxexp = mxsave CALL fmwarn mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mc(j+1) = 0 10 CONTINUE ndig = ndsave IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 RETURN ELSE IF (m02(1)>ndig .AND. mod(int(mbase),kb)==0) THEN CALL fmi2m(0,m01) GO TO 70 END IF IF (m02(1)1) GO TO 40 END IF mvz = mod(mvz*mvc,mvb) ke = int(mvz) CALL fmi2m(ke,m01) GO TO 70 END IF ! General case. 50 IF (ma(2)/=0) THEN ndig = ndig + int(ma(1)-mb(1)) END IF IF (ndig>ndg2mx .OR. mb(2)==0) THEN kflag = -9 IF (ma(1)==mexpov .OR. mb(1)==mexpun .OR. mb(2)==0) kflag = -4 kwarn = kwrnsv kaccsw = kasave mxexp = mxsave CALL fmwarn mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) DO 60 j = 2, ndsave mc(j+1) = 0 60 CONTINUE ndig = ndsave IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END IF CALL fmeq2(ma,m02,ndsave,ndig,0) m02(0) = nint(ndig*alogm2) CALL fmeq2(mb,m03,ndsave,ndig,0) m03(0) = nint(ndig*alogm2) m02(2) = abs(m02(2)) m03(2) = abs(m03(2)) CALL fmdiv(m02,m03,m01) CALL fmint(m01,m01) CALL fmmpy(m01,m03,m01) CALL fmsub(m02,m01,m01) ! Due to rounding, M01 may not be between 0 and MB here. ntrsav = ntrace ntrace = 0 IF (fmcomp(m01,'GE',m03)) THEN ntrace = ntrsav CALL fmsub(m01,m03,m01) END IF ntrace = ntrsav IF (m01(2)<0) CALL fmadd(m01,m03,m01) IF (ma(2)<0 .AND. m01(1)/=munkno) m01(2) = -m01(2) END IF 70 IF (kflag==1) kflag = 0 kwarn = kwrnsv macmax = nint((ndsave-1)*alogm2+log(real(abs(m01(2))+1))/0.69315) m01(0) = min(m01(0),macca,maccb,macmax) CALL fmexit(m01,mc,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmmod SUBROUTINE fmmove(mw,ma) ! Move a result from a work area (MW) to MA. ! If the result has MW(2)=0, then it is shifted and the exponent ! adjusted when it is moved to MA. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mw(lmwa) ! .. ! .. Local Scalars .. INTEGER :: j, n1, n2 ! .. ! .. External Subroutines .. EXTERNAL fmtrap ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mw(2)/=0) THEN n1 = ndig + 1 ! Major (Inner Loop) DO 10 j = 1, n1 ma(j) = mw(j) 10 CONTINUE ELSE n2 = ndig + 2 DO 20 j = 3, n2 ma(j-1) = mw(j) 20 CONTINUE IF (ma(2)/=0) THEN ma(1) = mw(1) - 1 ELSE ma(1) = 0 END IF END IF IF (abs(ma(1))>mxexp) CALL fmtrap(ma) RETURN END SUBROUTINE fmmove SUBROUTINE fmmpy(ma,mb,mc) ! MC = MA * MB ! When one of the numbers MA, MB is known to have more zero digits ! (base MBASE) than the other, it is faster if MB is the one with ! more zero digits. ! This routine performs the trace printing for multiplication. ! FMMPY2 is used to do the arithmetic. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmmpy2, fmntr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMMPY ' CALL fmntr(2,ma,mb,2) CALL fmmpy2(ma,mb,mc) CALL fmntr(1,mc,mc,1) ELSE CALL fmmpy2(ma,mb,mc) END IF ncall = ncall - 1 RETURN END SUBROUTINE fmmpy SUBROUTINE fmmpy2(ma,mb,mc) ! Internal multiplication routine. MC = MA * MB IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, maccb, mb2, md2b, mr INTEGER :: j, kreslt, kshift, n1, nguard, nzma, nzmb ! .. ! .. External Subroutines .. EXTERNAL fmargs, fmcons, fmim, fmmove, fmmpy3, fmrnd, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons macca = ma(0) maccb = mb(0) IF (abs(ma(1))>mexpab .OR. abs(mb(1))>mexpab .OR. kdebug==1) THEN CALL fmargs('FMMPY ',2,ma,mb,kreslt) IF (kreslt/=0) THEN ncall = ncall + 1 namest(ncall) = 'FMMPY ' CALL fmrslt(ma,mb,mc,kreslt) ncall = ncall - 1 RETURN END IF ELSE IF (ma(2)==0 .OR. mb(2)==0) THEN CALL fmim(0,mc) mc(0) = min(macca,maccb) RETURN END IF kflag = 0 ! Save the sign of MA and MB and then work only with ! positive numbers. ma2 = ma(2) mb2 = mb(2) ma(2) = abs(ma(2)) mb(2) = abs(mb(2)) ! NGUARD is the number of guard digits used. IF (ncall>1) THEN nguard = ngrd22 IF (nguard>ndig) nguard = ndig ELSE nguard = ngrd52 IF (nguard>ndig) nguard = ndig END IF IF (ma(2)*mb(2)=6*mbase) THEN nzma = 0 nzmb = 0 DO 10 j = 2, n1 IF (ma(j)==0) nzma = nzma + 1 IF (mb(j)==0) nzmb = nzmb + 1 10 CONTINUE ! It is faster if the second argument is the one with ! more zero digits. IF (nzma>nzmb) THEN CALL fmmpy3(mb,ma,nguard,kshift) ELSE CALL fmmpy3(ma,mb,nguard,kshift) END IF ELSE CALL fmmpy3(ma,mb,nguard,kshift) END IF ! The multiplication is complete. Round the result, ! move it to MC, and append the correct sign. ma(2) = ma2 mb(2) = mb2 mr = 2*mwa(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwa(n1+kshift)1) THEN mwa(n1+kshift) = mwa(n1+kshift) + 1 mwa(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,kshift) END IF END IF CALL fmmove(mwa,mc) IF (kflag<0) THEN namest(ncall) = 'FMMPY ' CALL fmwarn END IF IF (ma2*mb2<0) mc(2) = -mc(2) IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(mc(2))+1))/0.69315) mc(0) = min(macca,maccb,md2b) ELSE mc(0) = min(macca,maccb) END IF RETURN END SUBROUTINE fmmpy2 SUBROUTINE fmmpy3(ma,mb,nguard,kshift) ! Internal multiplication of MA*MB. The result is returned in MWA. ! Both MA and MB are positive. ! NGUARD is the number of guard digits that will be used. ! KSHIFT = 1 is returned if a left shift is pending (i.e., MWA(2)=0). ! The shift will be done in FMMOVE. KSHIFT = 0 is returned ! if no shift is pending. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC dint, int, min ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kshift, nguard ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maxmwa, mbj, mbkj, mbm1, mbnorm, mk, mkt, mmax, mt INTEGER :: j, jm1, k, kb, ki, kj, kl, knz, kwa, l, n1 ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. n1 = ndig + 1 mwa(1) = ma(1) + mb(1) l = n1 + nguard mwa(l+1) = 0 ! The multiplication loop begins here. ! MBNORM is the minimum number of digits that can be ! multiplied before normalization is required. ! MAXMWA is an upper bound on the size of values in MWA ! divided by (MBASE-1). It is used to determine ! whether to normalize before the next digit is ! multiplied. mbm1 = mbase - 1 mbnorm = dint(maxint/(mbm1*mbm1)) mmax = intmax - mbase mmax = min(dint(maxint/mbm1-mbm1),mmax) IF (mbnorm>1) THEN mbj = mb(2) ! Count the trailing zeros in MA. IF (ma(n1)/=0) THEN knz = n1 ELSE DO 10 j = ndig, 2, -1 IF (ma(j)/=0) THEN knz = j GO TO 20 END IF 10 CONTINUE END IF 20 mwa(2) = 0 DO 30 k = ndig + 2, l mwa(k) = 0 30 CONTINUE ! (Inner Loop) DO 40 k = 2, n1 mwa(k+1) = ma(k)*mbj 40 CONTINUE maxmwa = mbj DO 70 j = 3, n1 mbj = mb(j) IF (mbj/=0) THEN maxmwa = maxmwa + mbj jm1 = j - 1 kl = min(knz,l-jm1) ! Major (Inner Loop) DO 50 k = j + 1, j + kl - 1 mwa(k) = mwa(k) + ma(k-jm1)*mbj 50 CONTINUE END IF IF (maxmwa>mmax) THEN maxmwa = 0 ! Here normalization is only required for the ! range of digits currently changing in MWA. DO 60 kb = jm1 + kl, jm1 + 2, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase 60 CONTINUE END IF 70 CONTINUE ! Perform the final normalization. (Inner Loop) DO 80 kb = l, 3, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase 80 CONTINUE ELSE ! If normalization must be done for each digit, combine ! the two loops and normalize as the digits are multiplied. DO 90 j = 2, l mwa(j) = 0 90 CONTINUE kj = ndig + 2 DO 110 j = 2, n1 kj = kj - 1 mbkj = mb(kj) IF (mbkj==0) GO TO 110 kl = l - kj + 1 IF (kl>n1) kl = n1 ki = kl + 2 kwa = kl + kj + 1 mk = 0 DO 100 k = 2, kl mt = ma(ki-k)*mbkj + mwa(kwa-k) + mk mk = int(mt/mbase) mwa(kwa-k) = mt - mbase*mk 100 CONTINUE mwa(kwa-kl-1) = mk 110 CONTINUE END IF ! Set KSHIFT = 1 if a shift left is necessary. IF (mwa(2)==0) THEN kshift = 1 RETURN ELSE kshift = 0 RETURN END IF END SUBROUTINE fmmpy3 SUBROUTINE fmmpyd(ma,mb,mc,md,me) ! Double multiplication routine. MD = MA * MB, ME = MA * MC ! It is usually slightly faster to do two multiplications that ! have a common factor with one call. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck), & me(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, maccb, maccc, maxmwa, mb2, mbj, mbkj, mbm1, & mbnorm, mc2, mcj, mckj, md2b, mkb, mkc, mkt, mmax, mr, mt, mtemp INTEGER :: j, jm1, k, kb, ki, kj, kl, knz, kovun, kshift, kwa, l, n1, & nguard ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmeq, fmim, fmmove, fmmpy2, fmntr, fmntrj, fmprnt, & fmrnd, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa), mwd(lmwa), mwe(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /fmwa/mwd, mwe ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMMPYD' CALL fmntr(2,ma,mb,2) IF (abs(ntrace)>=2 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN CALL fmntrj(mc,ndig) ELSE CALL fmprnt(mc) END IF END IF END IF IF (mblogs/=mbase) CALL fmcons macca = ma(0) maccb = mb(0) maccc = mc(0) IF (abs(ma(1))>mexpab .OR. abs(mb(1))>mexpab .OR. abs(mc(1))>mexpab) & THEN kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun .OR. mb(1)==mexpov .OR. & mb(1)==mexpun .OR. mc(1)==mexpov .OR. mc(1)==mexpun) kovun = 1 IF (ma(1)==munkno .OR. mb(1)==munkno .OR. mc(1)==munkno) kovun = 2 ncall = ncall + 1 CALL fmmpy2(ma,mb,mwd) kb = kflag CALL fmmpy2(ma,mc,me) ncall = ncall - 1 IF (((kflag<0 .OR. kb<0) .AND. kovun==0) .OR. ((kflag==-4 .OR. kb== & -4) .AND. kovun==1)) THEN IF (kflag==-4 .OR. kb==-4) THEN kflag = -4 ELSE IF (kflag==-5 .OR. kb==-5) THEN kflag = -5 ELSE kflag = min(kflag,kb) END IF namest(ncall) = 'FMMPYD' CALL fmwarn END IF CALL fmeq(mwd,md) GO TO 120 END IF IF (ma(2)==0) THEN CALL fmim(0,md) md(0) = min(macca,maccb) CALL fmim(0,me) me(0) = min(macca,maccc) GO TO 120 END IF IF (mb(2)==0) THEN CALL fmmpy2(ma,mc,me) CALL fmim(0,md) md(0) = min(macca,maccb) GO TO 120 END IF IF (mc(2)==0) THEN CALL fmmpy2(ma,mb,md) CALL fmim(0,me) me(0) = min(macca,maccc) GO TO 120 END IF kflag = 0 ! NGUARD is the number of guard digits used. IF (ncall>1) THEN nguard = ngrd22 IF (nguard>ndig) nguard = ndig ELSE nguard = ngrd52 IF (nguard>ndig) nguard = ndig END IF IF ((ma(2)*mb(2)1) THEN mbj = mb(2) mcj = mc(2) ! Count the trailing zeros in MA. IF (ma(n1)/=0) THEN knz = n1 ELSE DO 10 j = ndig, 2, -1 IF (ma(j)/=0) THEN knz = j GO TO 20 END IF 10 CONTINUE END IF 20 mwa(2) = 0 mwd(2) = 0 DO 30 k = ndig + 2, l mwa(k) = 0 mwd(k) = 0 30 CONTINUE ! (Inner Loop) DO 40 k = 2, n1 mtemp = ma(k) mwa(k+1) = mtemp*mbj mwd(k+1) = mtemp*mcj 40 CONTINUE IF (mbj>mcj) THEN maxmwa = mbj ELSE maxmwa = mcj END IF DO 70 j = 3, n1 mbj = mb(j) mcj = mc(j) IF (mbj>mcj) THEN maxmwa = maxmwa + mbj ELSE maxmwa = maxmwa + mcj END IF jm1 = j - 1 kl = min(knz,l-jm1) ! Major (Inner Loop) DO 50 k = j + 1, j + kl - 1 mtemp = ma(k-jm1) mwa(k) = mwa(k) + mtemp*mbj mwd(k) = mwd(k) + mtemp*mcj 50 CONTINUE IF (maxmwa>mmax) THEN maxmwa = 0 ! Here normalization is only required for the ! range of digits currently changing in MWA. DO 60 kb = jm1 + kl, jm1 + 2, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase mkt = int(mwd(kb)/mbase) mwd(kb-1) = mwd(kb-1) + mkt mwd(kb) = mwd(kb) - mkt*mbase 60 CONTINUE END IF 70 CONTINUE ! Perform the final normalization. (Inner Loop) DO 80 kb = l, 3, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase mkt = int(mwd(kb)/mbase) mwd(kb-1) = mwd(kb-1) + mkt mwd(kb) = mwd(kb) - mkt*mbase 80 CONTINUE ELSE ! If normalization must be done for each digit, combine ! the two loops and normalize as the digits are multiplied. DO 90 j = 2, l mwa(j) = 0 mwd(j) = 0 90 CONTINUE kj = ndig + 2 DO 110 j = 2, n1 kj = kj - 1 mbkj = mb(kj) mckj = mc(kj) kl = l - kj + 1 IF (kl>n1) kl = n1 ki = kl + 2 kwa = kl + kj + 1 mkb = 0 mkc = 0 DO 100 k = 2, kl mt = ma(ki-k)*mbkj + mwa(kwa-k) + mkb mkb = int(mt/mbase) mwa(kwa-k) = mt - mbase*mkb mt = ma(ki-k)*mckj + mwd(kwa-k) + mkc mkc = int(mt/mbase) mwd(kwa-k) = mt - mbase*mkc 100 CONTINUE mwa(kwa-kl-1) = mkb mwd(kwa-kl-1) = mkc 110 CONTINUE END IF ! Set KSHIFT = 1 if a shift left is necessary. IF (mwa(2)==0) THEN kshift = 1 ELSE kshift = 0 END IF ! The multiplications are complete. ma(2) = ma2 mb(2) = mb2 mc(2) = mc2 mr = 2*mwa(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwa(n1+kshift)1) THEN mwa(n1+kshift) = mwa(n1+kshift) + 1 mwa(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,kshift) END IF END IF CALL fmmove(mwa,md) IF (mwd(2)==0) THEN kshift = 1 ELSE kshift = 0 END IF mr = 2*mwd(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwd(n1+kshift)1) THEN mwd(n1+kshift) = mwd(n1+kshift) + 1 mwd(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwd,ndig,nguard,kshift) END IF END IF CALL fmmove(mwd,me) IF (kflag<0) THEN namest(ncall) = 'FMMPYD' CALL fmwarn END IF IF (ma2*mb2<0) md(2) = -md(2) IF (ma2*mc2<0) me(2) = -me(2) IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(md(2))+1))/0.69315) md(0) = min(macca,maccb,md2b) md2b = nint((ndig-1)*alogm2+log(real(abs(me(2))+1))/0.69315) me(0) = min(macca,maccc,md2b) ELSE md(0) = min(macca,maccb) me(0) = min(macca,maccc) END IF 120 IF (ntrace/=0) THEN CALL fmntr(1,md,md,1) IF (abs(ntrace)>=1 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN CALL fmntrj(me,ndig) ELSE CALL fmprnt(me) END IF END IF END IF ncall = ncall - 1 RETURN END SUBROUTINE fmmpyd SUBROUTINE fmmpye(ma,mb,mc,md,me,mf,mg) ! Triple multiplication routine. ! ME = MA * MB, MF = MA * MC, MG = MA * MD ! It is usually slightly faster to do three multiplications that ! have a common factor with one call. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck), & me(0:lunpck), mf(0:lunpck), mg(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, maccb, maccc, maccd, maxj, maxmwa, mb2, mbj, & mbkj, mbm1, mbnorm, mc2, mcj, mckj, md2, md2b, mdj, mdkj, mkb, mkc, & mkd, mkt, mmax, mr, mt, mtemp INTEGER :: j, jm1, k, kb, ki, kj, kl, knz, kovun, kshift, kwa, l, n1, & nguard ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmeq, fmim, fmmove, fmmpy2, fmntr, fmntrj, fmprnt, & fmrnd, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa), mwd(lmwa), mwe(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /fmwa/mwd, mwe ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMMPYE' CALL fmntr(2,ma,mb,2) IF (abs(ntrace)>=2 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN CALL fmntrj(mc,ndig) CALL fmntrj(md,ndig) ELSE CALL fmprnt(mc) CALL fmprnt(md) END IF END IF END IF IF (mblogs/=mbase) CALL fmcons macca = ma(0) maccb = mb(0) maccc = mc(0) maccd = md(0) IF (abs(ma(1))>mexpab .OR. abs(mb(1))>mexpab .OR. abs(mc( & 1))>mexpab .OR. abs(md(1))>mexpab) THEN kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun .OR. mb(1)==mexpov .OR. & mb(1)==mexpun .OR. mc(1)==mexpov .OR. mc(1)==mexpun .OR. & md(1)==mexpov .OR. md(1)==mexpun) kovun = 1 IF (ma(1)==munkno .OR. mb(1)==munkno .OR. mc(1)==munkno .OR. & md(1)==munkno) kovun = 2 ncall = ncall + 1 CALL fmmpy2(ma,mb,mwd) kb = kflag CALL fmmpy2(ma,mc,mwe) kj = kflag CALL fmmpy2(ma,md,mg) ncall = ncall - 1 IF (((kflag<0 .OR. kb<0 .OR. kj<0) .AND. kovun==0) .OR. ((kflag== & -4 .OR. kb==-4 .OR. kj==-4) .AND. kovun==1)) THEN IF (kflag==-4 .OR. kb==-4 .OR. kj==-4) THEN kflag = -4 ELSE IF (kflag==-5 .OR. kb==-5 .OR. kj==-5) THEN kflag = -5 ELSE kflag = min(kflag,kb,kj) END IF namest(ncall) = 'FMMPYE' CALL fmwarn END IF CALL fmeq(mwd,me) CALL fmeq(mwe,mf) GO TO 120 END IF IF (ma(2)==0) THEN CALL fmim(0,me) me(0) = min(macca,maccb) CALL fmim(0,mf) mf(0) = min(macca,maccc) CALL fmim(0,mg) mg(0) = min(macca,maccd) GO TO 120 END IF IF (mb(2)==0 .OR. mc(2)==0 .OR. md(2)==0) THEN CALL fmmpy2(ma,mb,mwd) CALL fmmpy2(ma,mc,mwe) CALL fmmpy2(ma,md,mg) CALL fmeq(mwd,me) CALL fmeq(mwe,mf) GO TO 120 END IF kflag = 0 ! NGUARD is the number of guard digits used. IF (ncall>1) THEN nguard = ngrd22 IF (nguard>ndig) nguard = ndig ELSE nguard = ngrd52 IF (nguard>ndig) nguard = ndig END IF IF ((ma(2)*mb(2)1) THEN mbj = mb(2) mcj = mc(2) mdj = md(2) ! Count the trailing zeros in MA. IF (ma(n1)/=0) THEN knz = n1 ELSE DO 10 j = ndig, 2, -1 IF (ma(j)/=0) THEN knz = j GO TO 20 END IF 10 CONTINUE END IF 20 mwa(2) = 0 mwd(2) = 0 mwe(2) = 0 DO 30 k = ndig + 2, l mwa(k) = 0 mwd(k) = 0 mwe(k) = 0 30 CONTINUE ! (Inner Loop) DO 40 k = 2, n1 mtemp = ma(k) mwa(k+1) = mtemp*mbj mwd(k+1) = mtemp*mcj mwe(k+1) = mtemp*mdj 40 CONTINUE maxmwa = mbj IF (mcj>maxmwa) maxmwa = mcj IF (mdj>maxmwa) maxmwa = mdj DO 70 j = 3, n1 mbj = mb(j) mcj = mc(j) mdj = md(j) maxj = mbj IF (mcj>maxj) maxj = mcj IF (mdj>maxj) maxj = mdj maxmwa = maxmwa + maxj jm1 = j - 1 kl = min(knz,l-jm1) ! Major (Inner Loop) DO 50 k = j + 1, j + kl - 1 mtemp = ma(k-jm1) mwa(k) = mwa(k) + mtemp*mbj mwd(k) = mwd(k) + mtemp*mcj mwe(k) = mwe(k) + mtemp*mdj 50 CONTINUE IF (maxmwa>mmax) THEN maxmwa = 0 ! Here normalization is only required for the ! range of digits currently changing in MWA. DO 60 kb = jm1 + kl, jm1 + 2, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase mkt = int(mwd(kb)/mbase) mwd(kb-1) = mwd(kb-1) + mkt mwd(kb) = mwd(kb) - mkt*mbase mkt = int(mwe(kb)/mbase) mwe(kb-1) = mwe(kb-1) + mkt mwe(kb) = mwe(kb) - mkt*mbase 60 CONTINUE END IF 70 CONTINUE ! Perform the final normalization. (Inner Loop) DO 80 kb = l, 3, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase mkt = int(mwd(kb)/mbase) mwd(kb-1) = mwd(kb-1) + mkt mwd(kb) = mwd(kb) - mkt*mbase mkt = int(mwe(kb)/mbase) mwe(kb-1) = mwe(kb-1) + mkt mwe(kb) = mwe(kb) - mkt*mbase 80 CONTINUE ELSE ! If normalization must be done for each digit, combine ! the two loops and normalize as the digits are multiplied. DO 90 j = 2, l mwa(j) = 0 mwd(j) = 0 mwe(j) = 0 90 CONTINUE kj = ndig + 2 DO 110 j = 2, n1 kj = kj - 1 mbkj = mb(kj) mckj = mc(kj) mdkj = md(kj) kl = l - kj + 1 IF (kl>n1) kl = n1 ki = kl + 2 kwa = kl + kj + 1 mkb = 0 mkc = 0 mkd = 0 DO 100 k = 2, kl mt = ma(ki-k)*mbkj + mwa(kwa-k) + mkb mkb = int(mt/mbase) mwa(kwa-k) = mt - mbase*mkb mt = ma(ki-k)*mckj + mwd(kwa-k) + mkc mkc = int(mt/mbase) mwd(kwa-k) = mt - mbase*mkc mt = ma(ki-k)*mdkj + mwe(kwa-k) + mkd mkd = int(mt/mbase) mwe(kwa-k) = mt - mbase*mkd 100 CONTINUE mwa(kwa-kl-1) = mkb mwd(kwa-kl-1) = mkc mwe(kwa-kl-1) = mkd 110 CONTINUE END IF ! Set KSHIFT = 1 if a shift left is necessary. IF (mwa(2)==0) THEN kshift = 1 ELSE kshift = 0 END IF ! The multiplications are complete. ma(2) = ma2 mb(2) = mb2 mc(2) = mc2 md(2) = md2 mr = 2*mwa(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwa(n1+kshift)1) THEN mwa(n1+kshift) = mwa(n1+kshift) + 1 mwa(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,kshift) END IF END IF CALL fmmove(mwa,me) IF (mwd(2)==0) THEN kshift = 1 ELSE kshift = 0 END IF mr = 2*mwd(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwd(n1+kshift)1) THEN mwd(n1+kshift) = mwd(n1+kshift) + 1 mwd(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwd,ndig,nguard,kshift) END IF END IF CALL fmmove(mwd,mf) IF (mwe(2)==0) THEN kshift = 1 ELSE kshift = 0 END IF mr = 2*mwe(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwe(n1+kshift)1) THEN mwe(n1+kshift) = mwe(n1+kshift) + 1 mwe(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwe,ndig,nguard,kshift) END IF END IF CALL fmmove(mwe,mg) IF (kflag<0) THEN namest(ncall) = 'FMMPYE' CALL fmwarn END IF IF (ma2*mb2<0) me(2) = -me(2) IF (ma2*mc2<0) mf(2) = -mf(2) IF (ma2*md2<0) mg(2) = -mg(2) IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(me(2))+1))/0.69315) me(0) = min(macca,maccb,md2b) md2b = nint((ndig-1)*alogm2+log(real(abs(mf(2))+1))/0.69315) mf(0) = min(macca,maccc,md2b) md2b = nint((ndig-1)*alogm2+log(real(abs(mg(2))+1))/0.69315) mg(0) = min(macca,maccd,md2b) ELSE me(0) = min(macca,maccb) mf(0) = min(macca,maccc) mg(0) = min(macca,maccd) END IF 120 IF (ntrace/=0) THEN CALL fmntr(1,me,me,1) IF (abs(ntrace)>=1 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN CALL fmntrj(mf,ndig) CALL fmntrj(mg,ndig) ELSE CALL fmprnt(mf) CALL fmprnt(mg) END IF END IF END IF ncall = ncall - 1 RETURN END SUBROUTINE fmmpye SUBROUTINE fmmpyi(ma,ival,mb) ! MB = MA * IVAL ! Multiply FM number MA by one word integer IVAL. ! This routine is faster than FMMPY when IVAL*MBASE is a ! one word integer. IMPLICIT NONE ! Scratch array usage during FMMPYI: M01 ! .. Intrinsic Functions .. INTRINSIC abs, dble, int, log, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, mcarry, md2b, mkt, mlr, mval INTEGER :: j, ka, kb, kc, kshift, n1, nguard, nmval, nv2 ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmeq, fmim, fmmove, fmmpy2, fmntr, fmntri, fmrnd, & fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons macca = ma(0) ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMMPYI' CALL fmntr(2,ma,ma,1) CALL fmntri(2,ival,0) END IF kflag = 0 n1 = ndig + 1 ! Check for special cases. IF (ma(2)==0) THEN CALL fmeq(ma,mb) IF (ntrace/=0) THEN CALL fmntr(1,mb,mb,1) END IF ncall = ncall - 1 RETURN END IF IF (abs(ma(1))1) GO TO 20 IF (ma(1)==munkno) THEN CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -4 IF (ntrace/=0) THEN CALL fmntr(1,mb,mb,1) END IF ncall = ncall - 1 RETURN END IF IF (ival==0) THEN CALL fmim(0,mb) IF (ntrace/=0) THEN CALL fmntr(1,mb,mb,1) END IF ncall = ncall - 1 RETURN END IF IF (abs(ival)==1) THEN DO 10 j = 0, n1 mb(j) = ma(j) 10 CONTINUE IF (ma(1)==mexpov) kflag = -5 IF (ma(1)==mexpun) kflag = -6 mb(2) = ma(2)*ival IF (ntrace/=0) THEN CALL fmntr(1,mb,mb,1) END IF ncall = ncall - 1 RETURN END IF IF (ma(1)==mexpov) THEN ma2 = ma(2) CALL fmim(0,mb) kflag = -5 mb(1) = mexpov mb(2) = 1 mb(0) = nint(ndig*alogm2) IF ((ma2<0 .AND. ival>0) .OR. (ma2>0 .AND. ival<0)) mb(2) = -1 IF (ntrace/=0) THEN CALL fmntr(1,mb,mb,1) END IF ncall = ncall - 1 RETURN END IF IF (ma(1)==mexpun) THEN CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) namest(ncall) = 'FMMPYI' kflag = -4 CALL fmwarn IF (ntrace/=0) THEN CALL fmntr(1,mb,mb,1) END IF ncall = ncall - 1 RETURN END IF ! Work with positive numbers. 20 ma2 = ma(2) ma(2) = abs(ma(2)) mval = abs(ival) nmval = int(mval) nv2 = nmval - 1 ! To leave room for the normalization, shift the product ! to the right KSHIFT places in MWA. kshift = int((log(dble(ma(2)+1)*dble(mval)))/dlogmb) ! If IVAL is too big use FMMPY. IF (kshift>ndig .OR. mval>maxint/mbase .OR. nmval/=abs(ival) .OR. & nv2/=abs(ival)-1) THEN CALL fmim(ival,m01) ma(2) = ma2 CALL fmmpy2(ma,m01,mb) IF (ntrace/=0) THEN CALL fmntr(1,mb,mb,1) END IF ncall = ncall - 1 RETURN END IF mwa(1) = ma(1) + kshift ka = 2 + kshift kb = n1 + kshift kc = ndig + 5 DO 30 j = kb, kc mwa(j) = 0 30 CONTINUE mcarry = 0 ! This is the main multiplication loop. DO 40 j = kb, ka, -1 mkt = ma(j-kshift)*mval + mcarry mcarry = int(mkt/mbase) mwa(j) = mkt - mcarry*mbase 40 CONTINUE ! Resolve the final carry. DO 50 j = ka - 1, 2, -1 mkt = int(mcarry/mbase) mwa(j) = mcarry - mkt*mbase mcarry = mkt 50 CONTINUE ! Now the first significant digit in the product is in ! MWA(2) or MWA(3). Round the result and move it to MB. ma(2) = ma2 IF (mwa(2)==0) THEN mlr = 2*mwa(ndig+3) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwa(n1+1)1) THEN mwa(n1+1) = mwa(n1+1) + 1 mwa(n1+2) = 0 END IF ELSE nguard = kshift - 1 CALL fmrnd(mwa,ndig,nguard,1) END IF END IF ELSE mlr = 2*mwa(ndig+2) + 1 IF (mlr>=mbase) THEN IF (mlr-1>mbase .AND. mwa(n1)1) THEN mwa(n1) = mwa(n1) + 1 mwa(n1+1) = 0 END IF ELSE CALL fmrnd(mwa,ndig,kshift,0) END IF END IF END IF CALL fmmove(mwa,mb) IF (kflag<0) THEN namest(ncall) = 'FMMPYI' CALL fmwarn END IF ! Put the sign on the result. IF ((ival>0 .AND. ma2<0) .OR. (ival<0 .AND. ma2>0)) mb(2) = -mb(2) IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(macca,md2b) ELSE mb(0) = macca END IF IF (ntrace/=0) THEN CALL fmntr(1,mb,mb,1) END IF ncall = ncall - 1 RETURN END SUBROUTINE fmmpyi SUBROUTINE fmmset(maxint,ml,mld2,mlm1) ! Internal routine to keep some compilers from doing a loop at ! the highest precision available and then rounding to the ! declared precision. For example, it is used in FMSET while ! trying to find the threshold beyond which integers cannot ! be represented exactly using (M) precision. ! .. Intrinsic Functions .. INTRINSIC dint ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: maxint, ml, mld2, mlm1 ! .. ml = 2*maxint + 1 mld2 = dint(ml/2) mlm1 = ml - 1 RETURN END SUBROUTINE fmmset SUBROUTINE fmnint(ma,mb) ! MB = NINT(MA) -- MB is returned as the nearest integer to MA. IMPLICIT NONE ! Scratch array usage during FMNINT: M01 ! .. Intrinsic Functions .. INTRINSIC abs, int, max ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, mxsave INTEGER :: k, kasave, kovun, kreslt, kwrnsv, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdivi, fmentr, fmeq2, fmexit, fmi2m, fmint, & fmntr, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab) THEN CALL fmentr('FMNINT',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMNINT' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52-1,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF kwrnsv = kwarn kwarn = 0 CALL fmeq2(ma,mb,ndsave,ndig,0) IF (ndsave>int(ma(1))) THEN ma2 = ma(2) mb(2) = abs(mb(2)) CALL fmi2m(1,m01) CALL fmdivi(m01,2,m01) CALL fmadd(mb,m01,mb) CALL fmint(mb,mb) IF (ma2<0) mb(2) = -mb(2) END IF kwarn = kwrnsv ! Round the result and return. CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmnint SUBROUTINE fmntr(ntr,ma,mb,narg) ! Print FM numbers in base 10 format using FMOUT for conversion. ! This is used for trace output from the FM routines. ! NTR = 1 if a result of an FM call is to be printed. ! = 2 to print input argument(s) to an FM call. ! MA - the FM number to be printed. ! MB - an optional second FM number to be printed. ! NARG - the number of arguments. NARG = 1 if only MA is to be ! printed, and NARG = 2 if both MA and MB are to be printed. ! NTRACE and LVLTRC (in COMMON /FMUSER/) control trace printout. ! NTRACE = 0 No printout except warnings and errors. ! NTRACE = 1 The result of each call to one of the routines ! is printed in base 10, using FMOUT. ! NTRACE = -1 The result of each call to one of the routines ! is printed in internal base MBASE format. ! NTRACE = 2 The input arguments and result of each call to one ! of the routines is printed in base 10, using FMOUT. ! NTRACE = -2 The input arguments and result of each call to one ! of the routines is printed in base MBASE format. ! LVLTRC defines the call level to which the trace is done. LVLTRC = 1 ! means only FM routines called directly by the user are traced, ! LVLTRC = K prints traces for FM routines with call levels up ! to and including level K. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: narg, ntr ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. CHARACTER (6) :: name ! .. ! .. External Subroutines .. EXTERNAL fmntrj, fmprnt ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (ntrace==0) RETURN IF (ncall>lvltrc) RETURN IF (ntr==2 .AND. abs(ntrace)==1) RETURN IF (ntr==2) THEN name = namest(ncall) WRITE (kw,90000) name ELSE name = namest(ncall) IF (kflag==0) THEN WRITE (kw,90010) name, ncall, int(mbase), ndig ELSE WRITE (kw,90020) name, ncall, int(mbase), ndig, kflag END IF END IF ! Check for base MBASE internal format trace. IF (ntrace<0) THEN CALL fmntrj(ma,ndig) IF (narg==2) CALL fmntrj(mb,ndig) END IF ! Check for base 10 trace using FMOUT. IF (ntrace>0) THEN CALL fmprnt(ma) IF (narg==2) THEN CALL fmprnt(mb) END IF END IF RETURN 90000 FORMAT (' Input to ',A6) 90010 FORMAT (' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10,5X,'NDIG =',I6) 90020 FORMAT (' ',A6,6X,'Call level =',I2,4X,'MBASE =',I10,4X,'NDIG =',I6,4X, & 'KFLAG =',I3) END SUBROUTINE fmntr SUBROUTINE fmntri(ntr,n,knam) ! Internal routine for trace output of integer variables. ! NTR = 1 for output values ! 2 for input values ! N Integer to be printed. ! KNAM is positive if the routine name is to be printed. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: knam, n, ntr ! .. ! .. Local Scalars .. CHARACTER (6) :: name ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (ntrace==0) RETURN IF (ncall>lvltrc) RETURN IF (ntr==2 .AND. abs(ntrace)==1) RETURN IF (ntr==2 .AND. knam>0) THEN name = namest(ncall) WRITE (kw,90000) name END IF IF (ntr==1 .AND. knam>0) THEN name = namest(ncall) IF (kflag==0) THEN WRITE (kw,90010) name, ncall, int(mbase), ndig ELSE WRITE (kw,90020) name, ncall, int(mbase), ndig, kflag END IF END IF WRITE (kw,90030) n RETURN 90000 FORMAT (' Input to ',A6) 90010 FORMAT (' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10,5X,'NDIG =',I6) 90020 FORMAT (' ',A6,6X,'Call level =',I2,4X,'MBASE =',I10,4X,'NDIG =',I6,4X, & 'KFLAG =',I3) 90030 FORMAT (1X,I18) END SUBROUTINE fmntri SUBROUTINE fmntrj(ma,nd) ! Print trace output in internal base MBASE format. The number to ! be printed is in MA. ! ND is the number of base MBASE digits to be printed. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC dble, int, log10 ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: nd ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, l, n, n1 CHARACTER (50) :: form ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. n1 = nd + 1 l = int(log10(dble(mbase-1))) + 2 n = (kswide-23)/l IF (n>10) n = 5*(n/5) IF (nd<=n) THEN WRITE (form,90000) l + 2, n - 1, l ELSE WRITE (form,90010) l + 2, n - 1, l, n, l END IF WRITE (kw,form) (int(ma(j)),j=1,n1) RETURN 90000 FORMAT (' (1X,I19,I',I2,',',I3,'I',I2,') ') 90010 FORMAT (' (1X,I19,I',I2,',',I3,'I',I2,'/(22X,',I3,'I',I2,')) ') END SUBROUTINE fmntrj SUBROUTINE fmntrr(ntr,x,knam) ! Internal routine for trace output of real variables. ! NTR - 1 for output values ! 2 for input values ! X - Double precision value to be printed if NX.EQ.1 ! KNAM - Positive if the routine name is to be printed. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x INTEGER :: knam, ntr ! .. ! .. Local Scalars .. CHARACTER (6) :: name ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (ntrace==0) RETURN IF (ncall>lvltrc) RETURN IF (ntr==2 .AND. abs(ntrace)==1) RETURN IF (ntr==2 .AND. knam>0) THEN name = namest(ncall) WRITE (kw,90000) name END IF IF (ntr==1 .AND. knam>0) THEN name = namest(ncall) IF (kflag==0) THEN WRITE (kw,90010) name, ncall, int(mbase), ndig ELSE WRITE (kw,90020) name, ncall, int(mbase), ndig, kflag END IF END IF WRITE (kw,90030) x RETURN 90000 FORMAT (' Input to ',A6) 90010 FORMAT (' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10,5X,'NDIG =',I6) 90020 FORMAT (' ',A6,6X,'Call level =',I2,4X,'MBASE =',I10,4X,'NDIG =',I6,4X, & 'KFLAG =',I3) 90030 FORMAT (1X,D30.20) END SUBROUTINE fmntrr SUBROUTINE fmout(ma,line,lb) ! Convert a floating multiple precision number to a character array ! for output. ! MA is an FM number to be converted to an A1 character ! array in base 10 format ! LINE is the CHARACTER*1 array in which the result is returned. ! LB is the length of LINE. ! JFORM1 and JFORM2 (in COMMON) determine the format of LINE. ! JFORM1 = 0 normal setting ( .314159M+6 ) ! = 1 1PE format ( 3.14159M+5 ) ! = 2 F format ( 314159.000 ) ! JFORM2 = number of significant digits to display (if JFORM1 = 0, 1) ! = number of digits after the decimal point (if JFORM1 = 2) ! If JFORM2.EQ.0 and JFORM1.NE.2 then a default number of ! digits is chosen. The default is roughly the full precision ! of MA. ! If JFORM2.EQ.0 and JFORM1.EQ.2 then the number is returned in ! integer format with no decimal point. Rounding is done as ! with other settings, so the value displayed is the nearest ! integer to MA. ! If JFORM1.EQ.2 and MA is too large or too small to display in the ! requested format, it is converted using JFORM1=0, JFORM2=0. ! LINE should be dimensioned at least LOG10(MBASE)*NDIG + 15 on a ! 32-bit machine to allow for up to 10 digit exponents. Replace ! 15 by 20 if 48-bit integers are used, 25 for 64-bit integers, .... IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dble, dint, int, log10, max, min, mod, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) CHARACTER (1) :: line(lb) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: m2, mbsave, mexp, mexp10, mkt, mndgms, ms1, ms2, msd2, mt10, & mxsave REAL :: x INTEGER :: j, jdpt, jf1sav, jf2sav, k, k1, k2, ka, kasave, kb, kc, & kdigit, kexp, kexpsh, kms2sd, kmt, kpt, krsave, l, nd, nde, nde2, & ndigms, nds2, ndsave, npower, nsd1, nsd2, nval, nword, nword1, nword2 CHARACTER (1) :: kchar ! .. ! .. Local Arrays .. REAL (KIND(0.0D0)) :: md(0:lunpck), ms(0:lunpck), mt(0:lunpck) CHARACTER (1) :: nexpov(12), nexpun(12), numb(10), nunkno(12) ! .. ! .. External Subroutines .. EXTERNAL fmadd2, fmcons, fmdiv2, fmeq, fmeq2, fmim, fmmpy2, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! .. Data Statements .. DATA numb/'0', '1', '2', '3', '4', '5', '6', '7', '8', '9'/ DATA nunkno/' ', ' ', ' ', 'U', 'N', 'K', 'N', 'O', 'W', 'N', ' ', ' '/ DATA nexpov/' ', ' ', ' ', 'O', 'V', 'E', 'R', 'F', 'L', 'O', 'W', ' '/ DATA nexpun/' ', ' ', ' ', 'U', 'N', 'D', 'E', 'R', 'F', 'L', 'O', 'W'/ ! .. ! To avoid recursion, FMOUT calls only internal arithmetic ! routines (FMADD2, FMMPY2, ...), so no trace printout is ! done during a call to FMOUT. kflag = 0 ncall = ncall + 1 namest(ncall) = 'FMOUT ' ! Raise the call stack again, since the internal ! routines don't. ncall = ncall + 1 namest(ncall) = 'FMOUT ' DO 10 j = 1, lb line(j) = ' ' 10 CONTINUE ! Check for special cases. IF (ma(1)==munkno) THEN DO 20 j = 1, 12 line(j) = nunkno(j) 20 CONTINUE ncall = ncall - 2 RETURN END IF IF (ma(1)==mexpov) THEN DO 30 j = 1, 12 line(j) = nexpov(j) 30 CONTINUE line(2) = '+' IF (ma(2)<0) line(2) = '-' ncall = ncall - 2 RETURN END IF IF (ma(1)==mexpun) THEN DO 40 j = 1, 12 line(j) = nexpun(j) 40 CONTINUE line(2) = '+' IF (ma(2)<0) line(2) = '-' ncall = ncall - 2 RETURN END IF IF (ma(2)==0 .AND. jform1==2 .AND. jform2==0) THEN line(2) = '0' ncall = ncall - 2 RETURN END IF kasave = kaccsw kaccsw = 0 krsave = kround kround = 1 jf1sav = jform1 jf2sav = jform2 mbsave = mbase ndsave = ndig mxsave = mxexp ! ND is the number of base 10 digits required. 50 nd = jform2 IF (jform1==2 .AND. ma(1)>0) nd = jform2 + int(real(ma(1))*log10(real( & mbase))) + 1 IF (nd<=1) THEN k = int(real(ndig)*log10(real(mbase))) nd = max(k,jform2) END IF IF (jform2<=0 .AND. jform1<=1) nd = int(1.1+real(ndig-1)*log10(real( & mbase))) IF (nd<2) nd = 2 IF (lbndg2mx) THEN kflag = -9 ncall = ncall - 1 CALL fmwarn ncall = ncall + 1 GO TO 270 END IF IF (ma(2)==0) THEN CALL fmim(0,ms) GO TO 110 END IF ! Check to see if MA is already in a base that is a ! power of ten. If so, the conversion can be skipped. k = npower DO 60 j = 1, k mbase = 10**j IF (mbase==mbsave) THEN IF (mblogs/=mbase) CALL fmcons npower = j ndig = nd/npower + 2 IF (ndig<2) ndig = 2 IF (ndig>ndg2mx) THEN kflag = -9 ncall = ncall - 1 CALL fmwarn ncall = ncall + 1 GO TO 270 END IF CALL fmeq2(ma,ms,ndsave,ndig,0) ms(2) = abs(ms(2)) GO TO 110 END IF 60 CONTINUE IF (mblogs/=mbase) CALL fmcons CALL fmim(int(mbsave),md) nds2 = ndsave + 1 CALL fmim(1,mt) kmt = 1 ! Convert the fraction part of MA to the new base. kpt = nds2 + 1 DO 70 j = 3, nds2 kpt = kpt - 1 IF (ma(kpt)/=0) GO TO 80 70 CONTINUE 80 kexpsh = kpt - 1 kdigit = int(abs(ma(2))) CALL fmim(kdigit,ms) ndigms = ndig DO 90 j = 3, kpt kdigit = int(ma(j)) IF (mbsave==2) THEN ndig = min(ndigms,max(2,int(ms(1))+1)) CALL fmadd2(ms,ms,ms) ELSE ndig = min(ndigms,max(2,int(ms(1)+md(1)))) CALL fmmpy2(ms,md,ms) END IF IF (kdigit>0) THEN IF (kmt/=kdigit) THEN ndig = min(ndigms,max(2,int(md(1)))) CALL fmim(kdigit,mt) kmt = kdigit END IF ndig = min(ndigms,max(2,int(max(ms(1),mt(1)))+1)) CALL fmadd2(ms,mt,ms) END IF 90 CONTINUE ! Convert the exponent. ndig = ndigms CALL fmim(1,mt) k = abs(int(ma(1))-kexpsh) IF (mod(k,2)==1) THEN CALL fmeq(md,mt) ELSE CALL fmim(1,mt) END IF 100 k = k/2 m2 = 2 mndgms = ndigms ndig = int(min(mndgms,max(m2,md(1)*m2))) IF (k>0) CALL fmmpy2(md,md,md) IF (mod(k,2)==1) THEN ndig = int(min(mndgms,max(m2,mt(1)+md(1)))) CALL fmmpy2(mt,md,mt) END IF IF (k>1) GO TO 100 ndig = ndigms IF (ma(1)-kexpsh<0) THEN CALL fmdiv2(ms,mt,ms) ELSE CALL fmmpy2(ms,mt,ms) END IF ! Now MS is the value of MA converted to a ! power of ten base. ! Convert it to a character string base 10 for output. ! MEXP10 is the base 10 exponent. ! KMS2SD is the number of base 10 significant digits ! in MS(2). 110 ms1 = ms(1) 120 mexp10 = npower*ms(1) kms2sd = npower k = int(mbase) DO 130 j = 1, npower k = k/10 IF (ms(2)nd) THEN nsd2 = nd ELSE nsd2 = int(msd2) END IF nword = (nsd2-kms2sd-1+npower)/npower + 2 IF (nword<2) nword = -1 IF (nword>ndig) nword = 0 IF (nword>=2 .AND. nsd2<=0) nword = -1 ELSE nword = (nd-kms2sd-1+npower)/npower + 2 END IF nsd1 = kms2sd + npower*(nword-2) IF (nword<2) THEN nval = 0 ELSE nval = 10**(nsd1-nsd2) END IF ! Now do the base 10 rounding. IF (nword>=2) THEN x = 0.0 IF (nval>1) x = mod(int(ms(nword)),nval) IF (nword=mbase) THEN nword1 = nword - 1 nword2 = nword - 2 IF (nword>2) THEN CALL fmeq2(ms,ms,nword1,nword2,1) ELSE ms(1) = ms(1) + 1 ms(2) = int(ms(2)/mbase) ms(3) = 0 END IF END IF IF (ms(1)/=ms1 .OR. ms(2)/=ms2) GO TO 120 END IF ! Build the base 10 character string. 140 IF (ma(2)<0) line(1) = '-' line(2) = '.' k = 10**kms2sd l = 2 IF (nword==-1) nsd2 = nd DO 150 j = 1, nsd2 k = k/10 IF (k==0) THEN k = int(mbase)/10 l = l + 1 END IF kdigit = int(ms(l))/k ms(l) = mod(int(ms(l)),k) line(j+2) = numb(kdigit+1) 150 CONTINUE ka = nsd2 + 3 kb = nd + 2 IF (kb>=ka) THEN DO 160 j = ka, kb line(j) = numb(1) 160 CONTINUE END IF line(nd+3) = cmchar line(nd+4) = '+' IF (mexp10<0) line(nd+4) = '-' IF (ma(2)==0) line(nd+4) = ' ' ! Build the digits of the base 10 exponent backwards, ! then reverse them. nde = 1 mexp = abs(mexp10) mt10 = 10 DO 180 j = 1, lb mkt = dint(mexp/mt10) kdigit = int(mexp-mkt*mt10) line(nd+4+j) = numb(kdigit+1) mexp = mkt IF (mexp==0) GO TO 190 IF (nd+5+j>lb) THEN DO 170 k = 1, lb line(k) = '*' 170 CONTINUE GO TO 210 END IF nde = nde + 1 180 CONTINUE 190 nde2 = nde/2 IF (nde2<1) GO TO 210 k1 = nd + 4 k2 = nd + 5 + nde DO 200 j = 1, nde2 k1 = k1 + 1 k2 = k2 - 1 kchar = line(k1) line(k1) = line(k2) line(k2) = kchar 200 CONTINUE ! If JFORM1 is 1 put the first digit left of the decimal. 210 IF (jform1==1) THEN kchar = line(2) line(2) = line(3) line(3) = kchar END IF ! If JFORM1 is 2 put the number into fixed format. IF (jform1==2 .AND. jform2>=0) THEN IF (mexp10<=-jform2 .OR. mexp10+2>lb) THEN jform1 = 0 jform2 = 0 mbase = mbsave IF (mblogs/=mbase) CALL fmcons ndig = ndsave mxexp = mxsave DO 220 j = 1, lb line(j) = ' ' 220 CONTINUE GO TO 50 END IF ka = nd + 3 DO 230 j = ka, lb line(j) = numb(1) 230 CONTINUE kexp = int(mexp10) IF (mexp10>0) THEN DO 240 j = 1, kexp line(j+1) = line(j+2) 240 CONTINUE line(kexp+2) = '.' END IF IF (mexp10<0) THEN kexp = -int(mexp10) ka = 3 + kexp kb = lb + 1 kc = kb - kexp DO 250 j = ka, lb kb = kb - 1 kc = kc - 1 line(kb) = line(kc) line(kc) = numb(1) 250 CONTINUE END IF jdpt = 0 DO 260 j = 1, lb IF (line(j)=='.') jdpt = j IF (jdpt>0 .AND. j>jdpt+jform2) line(j) = ' ' 260 CONTINUE IF (jform2==0 .AND. jdpt>0) line(kexp+2) = ' ' END IF ! Restore values and return GO TO 290 ! LINE is not big enough to hold the number ! of digits specified. 270 kflag = -8 DO 280 j = 1, lb line(j) = '*' 280 CONTINUE ncall = ncall - 1 CALL fmwarn ncall = ncall + 1 290 mbase = mbsave IF (mblogs/=mbase) CALL fmcons ndig = ndsave mxexp = mxsave ncall = ncall - 2 kaccsw = kasave kround = krsave jform1 = jf1sav jform2 = jf2sav RETURN END SUBROUTINE fmout SUBROUTINE fmpack(ma,mp) ! MA is packed two base NDIG digits per word and returned in MP. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, mod ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mp(0:lpack) ! .. ! .. Local Scalars .. INTEGER :: j, kp ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kp = 2 mp(0) = ma(0) mp(1) = ma(1) mp(2) = abs(ma(2))*mbase + ma(3) IF (ma(2)<0) mp(2) = -mp(2) IF (ndig>=4) THEN DO 10 j = 4, ndig, 2 kp = kp + 1 mp(kp) = ma(j)*mbase + ma(j+1) 10 CONTINUE END IF IF (mod(ndig,2)==1) mp(kp+1) = ma(ndig+1)*mbase RETURN END SUBROUTINE fmpack SUBROUTINE fmpi(ma) ! MA = pi IMPLICIT NONE ! Scratch array usage during FMPI: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC abs, int, max, min, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, k, kasave, ndmb, ndsave, ndsv CHARACTER (155) :: string ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmeq2, fmntr, fmpi2, fmst2m, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons kflag = 0 ncall = ncall + 1 namest(ncall) = 'FMPI ' IF (abs(ntrace)>=2 .AND. ncall<=lvltrc) THEN WRITE (kw,90000) END IF kasave = kaccsw kaccsw = 0 ! Increase the working precision. ndsave = ndig IF (ncall==1) THEN k = ngrd52 ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave ma(j+1) = 0 10 CONTINUE GO TO 20 END IF END IF ! Check to see if pi has previously been computed ! in base MBASE with sufficient precision. IF (mbspi==mbase .AND. ndigpi>=ndig) THEN IF (namest(ncall-1)/='NOEQ ') THEN kaccsw = kasave CALL fmeq2(mpisav,ma,ndigpi,ndsave,0) END IF ELSE ndmb = int(150.0*2.302585/alogmb) IF (ndmb>=ndig) THEN ndsv = ndig ndig = min(ndmb,ndg2mx) string = '3.141592653589793238462643383279502884197169' // & '39937510582097494459230781640628620899862803482534211' // & '7067982148086513282306647093844609550582231725359408128' CALL fmst2m(string,mpisav) mpisav(0) = nint(ndig*alogm2) mbspi = mbase ndigpi = ndig IF (abs(mpisav(1))>10) ndigpi = 0 ELSE ndsv = ndig ndig = min(ndig+2,ndg2mx) CALL fmpi2(mpisav) mpisav(0) = nint(ndig*alogm2) mbspi = mbase ndigpi = ndig IF (abs(mpisav(1))>10) ndigpi = 0 END IF IF (namest(ncall-1)/='NOEQ ') THEN kaccsw = kasave CALL fmeq2(mpisav,ma,ndig,ndsave,0) END IF ndig = ndsv END IF 20 ndig = ndsave kaccsw = kasave IF (ntrace/=0) CALL fmntr(1,ma,ma,1) ncall = ncall - 1 RETURN 90000 FORMAT (' Input to FMPI') END SUBROUTINE fmpi SUBROUTINE fmpi2(mpi) ! Internal routine to compute pi. ! The formula used is due to S. Ramanujan: ! (4n)!(1103+26390n) ! 1/pi = (sqrt(8)/9801) * sum(n=0 to infinity) -------------------- ! ((n!)**4)(396**(4n)) ! The result is returned in MPI. IMPLICIT NONE ! Scratch array usage during FMPI2: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC int, max, nint, sqrt ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: mpi(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mx REAL (KIND(0.0D0)) :: x INTEGER :: j, k, kst, large, n, ndigrd, ndsave ! .. ! .. Local Arrays .. INTEGER :: nstack(19) ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdig, fmdiv, fmdivi, fmdpm, fmi2m, fmmpy, & fmmpyi ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons ndsave = ndig n = -1 CALL fmi2m(1103,mpi) CALL fmi2m(1,m02) CALL fmi2m(26390,m03) CALL fmi2m(1103,m04) mx = mxbase**2/mbase IF (mx>mxexp2) mx = mxexp2 10 n = n + 1 large = int(mx)/(4*n+3) j = 4*n + 1 IF (j>large) THEN CALL fmmpyi(m02,j,m02) j = j + 1 CALL fmmpyi(m02,j,m02) j = j + 1 CALL fmmpyi(m02,j,m02) ELSE IF (j*(j+1)>large) THEN k = j*(j+1) CALL fmmpyi(m02,k,m02) j = j + 2 CALL fmmpyi(m02,j,m02) ELSE k = j*(j+1)*(j+2) CALL fmmpyi(m02,k,m02) END IF j = n + 1 large = int(mxbase)/j IF (j>large) THEN CALL fmdivi(m02,j,m02) CALL fmdivi(m02,j,m02) CALL fmdivi(m02,j,m02) ELSE IF (j*j>large) THEN k = j*j CALL fmdivi(m02,k,m02) CALL fmdivi(m02,j,m02) ELSE k = j*j*j CALL fmdivi(m02,k,m02) END IF ! Break 4/396**4 into 1/(2178*2178*1296). j = 2178 large = int(mxbase)/j IF (j>large) THEN CALL fmdivi(m02,j,m02) CALL fmdivi(m02,j,m02) CALL fmdivi(m02,1296,m02) ELSE k = j*j CALL fmdivi(m02,k,m02) CALL fmdivi(m02,1296,m02) END IF ndigrd = ndig ndig = ndsave CALL fmadd(m03,m04,m04) ndig = ndigrd CALL fmmpy(m02,m04,m01) ndig = ndsave CALL fmadd(mpi,m01,mpi) ndig = max(2,ndsave-int(mpi(1)-m01(1))) IF (kflag/=1) GO TO 10 ndig = ndsave CALL fmi2m(8,m02) x = 8 x = sqrt(x) CALL fmdpm(x,m04) CALL fmdig(nstack,kst) DO 20 j = 1, kst ndig = nstack(j) CALL fmdiv(m02,m04,m01) CALL fmadd(m04,m01,m04) CALL fmdivi(m04,2,m04) 20 CONTINUE m04(0) = nint(ndig*alogm2) CALL fmi2m(9801,m03) CALL fmmpy(mpi,m04,mpi) CALL fmdiv(m03,mpi,mpi) RETURN END SUBROUTINE fmpi2 SUBROUTINE fmprnt(ma) ! Print MA in base 10 format. ! FMPRNT can be called directly by the user for easy output ! in M format. MA is converted using FMOUT and printed. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int, log10, max, min, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, k, ksave, l, last, lb, nd, nexp CHARACTER (20) :: form ! .. ! .. External Subroutines .. EXTERNAL fmout ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMPRNT' ksave = kflag nd = int(real(ndig)*log10(real(mbase))) + 1 IF (nd<2) nd = 2 nexp = int(2.0*log10(real(mxbase))) + 6 lb = max(jform2+nexp,nd+nexp) lb = min(lb,lmbuff) CALL fmout(ma,cmbuff,lb) kflag = ksave last = lb + 1 WRITE (form,90000) kswide - 7 DO 10 j = 1, lb IF (cmbuff(last-j)/=' ' .OR. j==lb) THEN l = last - j WRITE (kw,form) (cmbuff(k),k=1,l) ncall = ncall - 1 RETURN END IF 10 CONTINUE ncall = ncall - 1 RETURN 90000 FORMAT (' (6X,',I3,'A1) ') END SUBROUTINE fmprnt SUBROUTINE fmpwr(ma,mb,mc) ! MC = MA ** MB ! If MB can be expressed exactly as a one word integer, then FMIPWR is ! used. This is much faster when MB is small, and using FMIPWR allows ! MA to be negative. IMPLICIT NONE ! Scratch array usage during FMPWR: M01 - M06 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, maccb, macmax, mxsave INTEGER :: iextra, intmb, j, k, kasave, kfl, kovun, kreslt, kwrnsv, & ndsave ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmentr, fmeq2, fmexit, fmexp, fmim, fmipwr, fmln, fmmi, & fmmpy, fmntr, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! Convert MB to an integer before changing NDIG. kwrnsv = kwarn kwarn = 0 CALL fmmi(mb,intmb) kwarn = kwrnsv kfl = kflag IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. abs(mb(1))>mexpab .OR. ma(2)<=0) THEN CALL fmentr('FMPWR ',ma,mb,2,mc,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMPWR ' IF (ntrace/=0) CALL fmntr(2,ma,mb,2) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 IF (mb(1)==mexpov .OR. mb(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52-1,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,mb,mc,kreslt) IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF ! If the exponent is large or the base is very large, ! raise the precision. IF (ma(1)/=0) THEN iextra = max(0,int(mb(1))) + int(log(abs(real(ma(1))))/alogmb) ELSE iextra = max(0,int(mb(1))) END IF IF (mb(1)-ndig>log(alogmb*real(mxexp2))) THEN iextra = 0 END IF ndig = ndig + iextra IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mc(j+1) = 0 10 CONTINUE ndig = ndig - iextra CALL fmexit(mc,mc,ndsave,mxsave,kasave,kovun) RETURN END IF ! If the exponent is a small integer, call FMIPWR. kwrnsv = kwarn kwarn = 0 macca = ma(0) maccb = nint(ndig*alogm2) CALL fmeq2(ma,m06,ndsave,ndig,0) m06(0) = nint(ndig*alogm2) IF (kfl==0) THEN CALL fmipwr(m06,intmb,mc) ELSE IF (m06(2)<=0) THEN CALL fmim(0,mc) mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) kflag = -4 ELSE CALL fmln(m06,m06) maccb = mb(0) CALL fmeq2(mb,m02,ndsave,ndig,0) m02(0) = nint(ndig*alogm2) CALL fmmpy(m06,m02,m06) CALL fmexp(m06,mc) END IF kwarn = kwrnsv ! Round the result and return. macmax = nint((ndsave-1)*alogm2+log(real(abs(mc(2))+1))/0.69315) mc(0) = min(mc(0),macca,maccb,macmax) CALL fmexit(mc,mc,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmpwr SUBROUTINE fmrdc(ma,mb,jsin,jcos,jswap) ! Reduce MA using various trigonometric identities to an equivalent ! angle MB between 0 and 45 degrees. The reduction is done in radians ! if KRAD (in common /FMUSER/) is 1, in degrees if KRAD is 0. ! JSIN and JCOS are returned +1 or -1 and JSWAP is returned to indicate ! that the sin and cos functions have been interchanged as follows: ! JSWAP = 0 means SIN(MA) = JSIN*SIN(MB) ! COS(MA) = JCOS*COS(MB) ! JSWAP = 1 means SIN(MA) = JSIN*COS(MB) ! COS(MA) = JCOS*SIN(MB) IMPLICIT NONE ! Scratch array usage during FMRDC: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC abs, int, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: jcos, jsin, jswap ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: x INTEGER :: j, kasave, ndsave, ndsv ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdiv, fmdivi, fmeq, fmeq2, fmi2m, fmint, & fmm2dp, fmmpy, fmpi, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons jsin = 1 jcos = 1 jswap = 0 ndsave = ndig ndig = ndig + max(0,int(ma(1))) ! If the argument is too big, return UNKNOWN. IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mb(j+1) = 0 10 CONTINUE ndig = ndsave RETURN END IF ma(0) = ma(0) + nint(alogm2*real(max(0,int(ma(1))))) ! If MA is less than 1/MBASE, no reduction is needed. IF (ma(1)<0) THEN ndig = ndsave CALL fmeq(ma,mb) IF (mb(2)<0) THEN mb(2) = -mb(2) jsin = -1 END IF RETURN END IF j = 1 IF (krad==1) THEN 20 IF (mbspi/=mbase .OR. ndigpindg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 30 j = 2, ndsave mb(j+1) = 0 30 CONTINUE ndig = ndsave RETURN END IF jsin = 1 jcos = 1 jswap = 0 ma(0) = ma(0) + nint(alogm2*real(-m04(1))) GO TO 20 END IF ELSE CALL fmeq2(ma,m04,ndsave,ndig,0) IF (ma(2)<0) jsin = -1 m04(2) = abs(m04(2)) IF (m04(1)==0) THEN CALL fmm2dp(m04,x) IF (x<=44.0) THEN ndig = ndsave CALL fmeq(m04,mb) RETURN END IF END IF CALL fmi2m(360,m02) IF (fmcomp(m04,'GE',m02)) THEN CALL fmdiv(m04,m02,m01) CALL fmint(m01,m01) CALL fmmpy(m01,m02,m01) CALL fmsub(m04,m01,m04) END IF CALL fmi2m(180,m03) IF (fmcomp(m04,'GE',m03)) THEN jsin = -jsin CALL fmsub(m02,m04,m04) END IF CALL fmi2m(90,m02) IF (fmcomp(m04,'GE',m02)) THEN jcos = -jcos CALL fmsub(m03,m04,m04) END IF CALL fmi2m(45,m03) IF (fmcomp(m04,'GE',m03)) THEN jswap = 1 CALL fmsub(m02,m04,m04) END IF END IF ! Round the result and return. CALL fmeq2(m04,mb,ndig,ndsave,0) ndig = ndsave RETURN END SUBROUTINE fmrdc SUBROUTINE fmread(kread,ma) ! Read MA on unit KREAD. Multi-line numbers will have '&' as the ! last nonblank character on all but the last line. Only one ! number is allowed on the line(s). IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC max, min, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kread ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, lb, ndsave ! .. ! .. Local Arrays .. CHARACTER (1) :: line(80) ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmeq2, fminp, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons ncall = ncall + 1 namest(ncall) = 'FMREAD' ndsave = ndig ndig = min(ndg2mx,max(ndig+ngrd52,2)) lb = 0 10 READ (kread,90000,err=30,end=30) line ! Scan the line and look for '&' DO 20 j = 1, 80 IF (line(j)=='&') GO TO 10 IF (line(j)/=' ') THEN lb = lb + 1 IF (lb>lmbuff) THEN kflag = -8 GO TO 40 END IF cmbuff(lb) = line(j) END IF 20 CONTINUE CALL fminp(cmbuff,m01,1,lb) CALL fmeq2(m01,ma,ndig,ndsave,0) ndig = ndsave ncall = ncall - 1 RETURN ! If there is an error, return UNKNOWN. 30 kflag = -4 40 CALL fmwarn ma(1) = munkno ma(2) = 1 ma(0) = nint(ndig*alogm2) DO 50 j = 2, ndig ma(j+1) = 0 50 CONTINUE ncall = ncall - 1 RETURN 90000 FORMAT (80A1) END SUBROUTINE fmread SUBROUTINE fmrnd(mw,nd,nguard,kshift) ! Round MW to ND digits (base MBASE). ! MW is non-negative and has ND+NGUARD+KSHIFT digits. ! NGUARD is the number of guard digits carried. ! KSHIFT is 1 if a left shift is pending when MW(2)=0. ! Round to position MW(ND+1+KSHIFT) using the guard digits ! MW(ND+2+KSHIFT), ..., MW(ND+1+NGUARD+KSHIFT). ! This routine is designed to be called only from within the FM ! package. The user should call FMEQU to round numbers. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC dint, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kshift, nd, nguard ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: mw(lmwa) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: m2, mfactr, mkt INTEGER :: j, k, kb, l ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (kround==0 .AND. ncall<=1) RETURN l = nd + 2 + kshift IF (2*(mw(l)+1)mbase) THEN mw(l-1) = mw(l-1) + 1 mw(l) = 0 IF (mw(l-1)=2) THEN IF (mbase>=1000) THEN IF (mbase<1000000) THEN mfactr = int(0.5D0+0.6883D0*mbase) ELSE mfactr = int(0.5D0+0.687783D0*mbase) END IF IF (mw(l+1)==mfactr) RETURN END IF DO 10 j = 2, nguard IF (mw(l+j-1)>0) GO TO 30 10 CONTINUE END IF ! Round to even. IF (int(mw(l-1)-dint(mw(l-1)/m2)*m2)==0) RETURN END IF ELSE IF (2*mw(l)+1==mbase) THEN IF (nguard>=2) THEN DO 20 j = 2, nguard IF (2*(mw(l+j-1)+1)mbase) GO TO 30 20 CONTINUE RETURN END IF END IF END IF 30 mw(l-1) = mw(l-1) + 1 mw(l) = 0 ! Check whether there was a carry in the rounded digit. 40 kb = l - 1 IF (kb>=3) THEN k = kb + 1 DO 50 j = 3, kb k = k - 1 IF (mw(k)=mbase) THEN IF (kb>=4) THEN k = kb + 1 DO 60 j = 4, kb k = k - 1 mw(k) = mw(k-1) 60 CONTINUE END IF mkt = dint(mw(2)/mbase) IF (kb>=3) mw(3) = mw(2) - mkt*mbase mw(2) = mkt mw(1) = mw(1) + 1 END IF RETURN END SUBROUTINE fmrnd SUBROUTINE fmrpwr(ma,ival,jval,mb) ! MB = MA ** (IVAL/JVAL) rational exponentiation. ! This routine is faster than FMPWR when IVAL and JVAL are ! small integers. IMPLICIT NONE ! Scratch array usage during FMRPWR: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC abs, dble, int, log, max, min, mod, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival, jval ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: f, x REAL (KIND(0.0D0)) :: ma1, ma2, macca, macmax, mxsave REAL :: xval INTEGER :: ijsign, invert, ival2, j, jval2, k, kasave, kovun, kreslt, & kst, kwrnsv, l, lval, ndsave ! .. ! .. Local Arrays .. INTEGER :: nstack(19) ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdig, fmdiv, fmdivi, fmdpm, fmeq, fmeq2, & fmexit, fmgcdi, fmi2m, fmim, fmipwr, fmm2dp, fmmpyi, fmntr, fmntri, & fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons ncall = ncall + 1 namest(ncall) = 'FMRPWR' IF (ntrace/=0) THEN CALL fmntr(2,ma,ma,1) CALL fmntri(2,ival,0) CALL fmntri(2,jval,0) END IF kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN xval = max(abs(ival),abs(jval)) k = int((5.0*real(dlogtn)+2.0*log(xval))/alogmb+2.0) ndig = max(ndig+k,2) ELSE xval = max(abs(ival),abs(jval)) k = int(log(xval)/alogmb+1.0) ndig = ndig + k END IF IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 ma1 = ma(1) ma2 = ma(2) macca = ma(0) CALL fmeq2(ma,m02,ndsave,ndig,0) m02(0) = nint(ndig*alogm2) ! Use GCD-reduced positive exponents. ijsign = 1 ival2 = abs(ival) jval2 = abs(jval) IF (ival>0 .AND. jval<0) ijsign = -1 IF (ival<0 .AND. jval>0) ijsign = -1 IF (ival2>0 .AND. jval2>0) CALL fmgcdi(ival2,jval2) ! Check for special cases. 10 IF (ma1==munkno .OR. jval2==0 .OR. (ijsign<=0 .AND. ma2==0)) THEN CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -4 GO TO 30 END IF IF (ival2==0) THEN CALL fmim(1,mb) GO TO 30 END IF IF (jval2==1) THEN CALL fmipwr(m02,ijsign*ival2,mb) GO TO 30 END IF IF (ma2==0) THEN CALL fmeq(ma,mb) GO TO 30 END IF IF (ma2<0) THEN IF (mod(jval2,2)==0) THEN jval2 = 0 GO TO 10 END IF END IF IF (ma1==mexpov) THEN IF (ival20) THEN mb(1) = mexpov mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -5 ELSE IF (ijsign==-1 .AND. ma2>0) THEN mb(1) = mexpun mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -6 ELSE IF (ijsign==1 .AND. ma2<0) THEN IF (mod(ival2,2)==0) THEN mb(1) = mexpov mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -5 ELSE mb(1) = mexpov mb(2) = -1 mb(0) = nint(ndig*alogm2) kflag = -5 END IF ELSE IF (ijsign==-1 .AND. ma2<0) THEN IF (mod(ival2,2)==0) THEN mb(1) = mexpun mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -6 ELSE mb(1) = mexpun mb(2) = -1 mb(0) = nint(ndig*alogm2) kflag = -6 END IF END IF GO TO 30 END IF IF (ma1==mexpun) THEN IF (ival20) THEN mb(1) = mexpun mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -6 ELSE IF (ijsign==-1 .AND. ma2>0) THEN mb(1) = mexpov mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -5 ELSE IF (ijsign==1 .AND. ma2<0) THEN IF (mod(ival2,2)==0) THEN mb(1) = mexpun mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -6 ELSE mb(1) = mexpun mb(2) = -1 mb(0) = nint(ndig*alogm2) kflag = -6 END IF ELSE IF (ijsign==-1 .AND. ma2<0) THEN IF (mod(ival2,2)==0) THEN mb(1) = mexpov mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -5 ELSE mb(1) = mexpov mb(2) = -1 mb(0) = nint(ndig*alogm2) kflag = -5 END IF END IF GO TO 30 END IF ! Invert MA if MA > 1 and IVAL or JVAL is large. invert = 0 IF (ma(1)>0) THEN IF (ival>5 .OR. jval>5) THEN invert = 1 CALL fmi2m(1,m01) CALL fmdiv(m01,m02,m02) END IF END IF ! Generate the first approximation to ABS(MA)**(1/JVAL2). ma1 = m02(1) m02(1) = 0 m02(2) = abs(m02(2)) CALL fmm2dp(m02,x) l = int(ma1/jval2) f = ma1/dble(jval2) - l x = x**(1.0D0/jval2)*dble(mbase)**f CALL fmdpm(x,mb) mb(1) = mb(1) + l m02(1) = ma1 ! Initialize. CALL fmdig(nstack,kst) ! Newton iteration. DO 20 j = 1, kst ndig = nstack(j) IF (j15) THEN CALL fmim(0,mc) mc(1) = munkno mc(2) = 1 mc(0) = maccab kflag = kfsave RETURN END IF RETURN END SUBROUTINE fmrslt SUBROUTINE fmsign(ma,mb,mc) ! MC = SIGN(MA,MB) ! MC is set to ABS(MA) if MB is positive or zero, ! or -ABS(MA) if MB is negative. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwrnsv ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmim, fmntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 ncall = ncall + 1 namest(ncall) = 'FMSIGN' IF (ntrace/=0) CALL fmntr(2,ma,mb,2) kwrnsv = kwarn kwarn = 0 IF (ma(1)==munkno .OR. mb(1)==munkno) THEN CALL fmim(0,mc) mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) kflag = -4 ELSE IF (mb(2)>=0) THEN CALL fmeq(ma,mc) mc(2) = abs(mc(2)) ELSE CALL fmeq(ma,mc) mc(2) = -abs(mc(2)) END IF kwarn = kwrnsv IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END SUBROUTINE fmsign SUBROUTINE fmsin(ma,mb) ! MB = SIN(MA) IMPLICIT NONE ! Scratch array usage during FMSIN: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, macmax, mxsave INTEGER :: jcos, jsin, jswap, k, kasave, kovun, kreslt, ndsave, ndsv ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmcos2, fmdivi, fmentr, fmeq2, fmexit, fmi2m, fmmpy, & fmntr, fmpi, fmrdc, fmrslt, fmsin2, fmsqr, fmsqrt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)==0) THEN CALL fmentr('FMSIN ',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMSIN ' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) ma2 = ma(2) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) mb(2) = abs(mb(2)) ! Reduce the argument, convert to radians if the input is ! in degrees, and evaluate the function. CALL fmrdc(mb,mb,jsin,jcos,jswap) IF (mb(1)==munkno) GO TO 10 IF (krad==0) THEN IF (mbspi/=mbase .OR. ndigpindg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mb(j+1) = 0 10 CONTINUE ndig = ndsave kwarn = kwrnsv RETURN END IF ndsav1 = ndig ! Divide the argument by 3**K2. CALL fmeq2(ma,m02,ndsave,ndig,0) kthree = 1 maxval = mxbase/3 IF (k2>0) THEN DO 20 j = 1, k2 kthree = 3*kthree IF (kthree>maxval) THEN CALL fmdivi(m02,kthree,m02) kthree = 1 END IF 20 CONTINUE IF (kthree>1) CALL fmdivi(m02,kthree,m02) END IF ! Split into J2 concurrent sums and reduce NDIG while ! computing each term in the sum as the terms get smaller. CALL fmeq(m02,m03) nterm = 1 DO 30 j = 1, j2 nbot = nterm*(nterm-1) IF (nbot>1) CALL fmdivi(m03,nbot,m03) nterm = nterm + 2 kpt = (j-1)*(ndig+2) CALL fmeq(m03,mjsums(kpt)) m03(2) = -m03(2) 30 CONTINUE CALL fmsqr(m02,m02) IF (m02(1)<-ndig) GO TO 60 CALL fmipwr(m02,j2,mb) 40 CALL fmmpy(m03,mb,m03) large = int(intmax/nterm) DO 50 j = 1, j2 nbot = nterm*(nterm-1) IF (nterm>large .OR. nbot>mxbase) THEN CALL fmdivi(m03,nterm,m03) nbot = nterm - 1 CALL fmdivi(m03,nbot,m03) ELSE CALL fmdivi(m03,nbot,m03) END IF kpt = (j-1)*(ndsav1+2) ndig = ndsav1 CALL fmadd(mjsums(kpt),m03,mjsums(kpt)) IF (kflag/=0) GO TO 60 ndig = ndsav1 - int(mjsums(kpt+1)-m03(1)) IF (ndig<2) ndig = 2 m03(2) = -m03(2) nterm = nterm + 2 50 CONTINUE GO TO 40 ! Next put the J2 separate sums back together. 60 kflag = 0 kpt = (j2-1)*(ndig+2) CALL fmeq(mjsums(kpt),mb) IF (j2>=2) THEN DO 70 j = 2, j2 CALL fmmpy(m02,mb,mb) kpt = (j2-j)*(ndig+2) CALL fmadd(mb,mjsums(kpt),mb) 70 CONTINUE END IF ! Reverse the effect of reducing the argument to ! compute SIN(MA). ndig = ndsav1 IF (k2>0) THEN CALL fmi2m(3,m02) DO 80 j = 1, k2 CALL fmsqr(mb,m03) CALL fmmpyi(m03,-4,m03) CALL fmadd(m02,m03,m03) CALL fmmpy(m03,mb,mb) 80 CONTINUE END IF CALL fmeq2(mb,mb,ndsav1,ndsave,1) ndig = ndsave kwarn = kwrnsv RETURN END SUBROUTINE fmsin2 SUBROUTINE fmsinh(ma,mb) ! MB = SINH(MA) IMPLICIT NONE ! Scratch array usage during FMSINH: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, macmax, mxsave INTEGER :: k, kasave, kovun, kreslt, ndsave, nmethd ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmcsh2, fmdiv, fmdivi, fmentr, fmeq, fmeq2, fmexit, & fmexp, fmi2m, fmntr, fmrslt, fmsnh2, fmsqr, fmsqrt, fmsub, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab) THEN CALL fmentr('FMSINH',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMSINH' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) ma2 = ma(2) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) mb(2) = abs(mb(2)) IF (ma2==0) THEN CALL fmeq(ma,mb) GO TO 20 END IF ! Use a series for small arguments, FMEXP for large ones. IF (mb(1)==munkno) GO TO 20 IF (mbase>99) THEN IF (mb(1)<=0) THEN nmethd = 1 ELSE IF (mb(1)>=2) THEN nmethd = 2 ELSE IF (abs(mb(2))<10) THEN nmethd = 1 ELSE nmethd = 2 END IF ELSE IF (mb(1)<=0) THEN nmethd = 1 ELSE nmethd = 2 END IF END IF IF (nmethd==2) GO TO 10 IF (mb(1)<0 .OR. ndig<=50) THEN CALL fmsnh2(mb,mb) ELSE CALL fmcsh2(mb,mb) CALL fmi2m(1,m03) CALL fmsqr(mb,mb) CALL fmsub(mb,m03,mb) CALL fmsqrt(mb,mb) END IF GO TO 20 10 CALL fmexp(mb,mb) IF (mb(1)==mexpov) THEN GO TO 20 ELSE IF (mb(1)==mexpun) THEN mb(1) = mexpov GO TO 20 END IF IF (int(mb(1))<=(ndig+1)/2) THEN CALL fmi2m(1,m01) CALL fmdiv(m01,mb,m01) CALL fmsub(mb,m01,mb) END IF CALL fmdivi(mb,2,mb) ! Round and return. 20 macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) IF (ma2<0 .AND. mb(1)/=munkno) mb(2) = -mb(2) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmsinh SUBROUTINE fmsnh2(ma,mb) ! Internal subroutine for MB = SINH(MA). IMPLICIT NONE ! Scratch array usage during FMSNH2: M01 - M03 ! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent ! sums. Increasing this value will begin to improve the ! speed of SINH when the base is large and precision exceeds ! about 1,500 decimal digits. ! .. Intrinsic Functions .. INTRINSIC int, log, max, min, nint, real, sqrt ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL :: alog3, alogt, b, t, tj REAL (KIND(0.0D0)) :: maxval INTEGER :: j, j2, k, k2, kpt, kthree, kwrnsv, l, l2, large, n2, nbot, & ndsav1, ndsave, nterm ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdivi, fmeq, fmeq2, fmi2m, fmipwr, fmmpy, & fmmpyi, fmsqr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mjsums(0:ljsums), & mlbsav(0:lunpck), mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), & mln4(0:lunpck), mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmsums/mjsums COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (ma(2)==0) THEN CALL fmeq(ma,mb) RETURN END IF ndsave = ndig kwrnsv = kwarn kwarn = 0 ! Use the direct series ! SINH(X) = X + X**3/3! + X**5/5! - ... ! The argument will be divided by 3**K2 before the series ! is summed. The series will be added as J2 concurrent ! series. The approximately optimal values of K2 and J2 ! are now computed to try to minimize the time required. ! N2/2 is the approximate number of terms of the series ! that will be needed, and L2 guard digits will be carried. b = real(mbase) k = ngrd52 t = max(ndig-k,2) alog3 = log(3.0) alogt = log(t) tj = 0.05*alogmb*t**0.3333 + 1.85 j2 = int(tj) j2 = max(1,min(j2,ljsums/ndg2mx)) k2 = int(0.1*sqrt(t*alogmb/tj)-0.05*alogt+2.5) l = int(-(real(ma(1))*alogmb+log(real(ma(2))/b+ & real(ma(3))/(b*b)))/alog3-0.3) k2 = k2 - l IF (l<0) l = 0 IF (k2<0) THEN k2 = 0 j2 = int(.43*sqrt(t*alogmb/(alogt+real(l)*alog3))+.33) END IF IF (j2<=1) j2 = 1 n2 = int(t*alogmb/(alogt+real(l)*alog3)) l2 = int(log(real(n2)+3.0**k2)/alogmb) ndig = ndig + l2 IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) DO 10 j = 2, ndsave mb(j+1) = 0 10 CONTINUE ndig = ndsave kwarn = kwrnsv RETURN END IF ndsav1 = ndig ! Divide the argument by 3**K2. CALL fmeq2(ma,m02,ndsave,ndig,0) kthree = 1 maxval = mxbase/3 IF (k2>0) THEN DO 20 j = 1, k2 kthree = 3*kthree IF (kthree>maxval) THEN CALL fmdivi(m02,kthree,m02) kthree = 1 END IF 20 CONTINUE IF (kthree>1) CALL fmdivi(m02,kthree,m02) END IF ! Split into J2 concurrent sums and reduce NDIG while ! computing each term in the sum as the terms get smaller. CALL fmeq(m02,m03) nterm = 1 DO 30 j = 1, j2 nbot = nterm*(nterm-1) IF (nbot>1) CALL fmdivi(m03,nbot,m03) nterm = nterm + 2 kpt = (j-1)*(ndig+2) CALL fmeq(m03,mjsums(kpt)) 30 CONTINUE CALL fmsqr(m02,m02) IF (m02(1)<-ndig) GO TO 60 CALL fmipwr(m02,j2,mb) 40 CALL fmmpy(m03,mb,m03) large = int(intmax/nterm) DO 50 j = 1, j2 nbot = nterm*(nterm-1) IF (nterm>large .OR. nbot>mxbase) THEN CALL fmdivi(m03,nterm,m03) nbot = nterm - 1 CALL fmdivi(m03,nbot,m03) ELSE CALL fmdivi(m03,nbot,m03) END IF kpt = (j-1)*(ndsav1+2) ndig = ndsav1 CALL fmadd(mjsums(kpt),m03,mjsums(kpt)) IF (kflag/=0) GO TO 60 ndig = ndsav1 - int(mjsums(kpt+1)-m03(1)) IF (ndig<2) ndig = 2 nterm = nterm + 2 50 CONTINUE GO TO 40 ! Next put the J2 separate sums back together. 60 kflag = 0 kpt = (j2-1)*(ndig+2) CALL fmeq(mjsums(kpt),mb) IF (j2>=2) THEN DO 70 j = 2, j2 CALL fmmpy(m02,mb,mb) kpt = (j2-j)*(ndig+2) CALL fmadd(mb,mjsums(kpt),mb) 70 CONTINUE END IF ! Reverse the effect of reducing the argument to ! compute SINH(MA). ndig = ndsav1 IF (k2>0) THEN CALL fmi2m(3,m02) DO 80 j = 1, k2 CALL fmsqr(mb,m03) CALL fmmpyi(m03,4,m03) CALL fmadd(m02,m03,m03) CALL fmmpy(m03,mb,mb) 80 CONTINUE END IF CALL fmeq2(mb,mb,ndsav1,ndsave,1) ndig = ndsave kwarn = kwrnsv RETURN END SUBROUTINE fmsnh2 SUBROUTINE fmsp2m(x,ma) ! MA = X ! Convert a single precision number to FM format. ! In general the relative accuracy of the number returned is only ! the relative accuracy of a machine precision number. This may be ! true even if X can be represented exactly in the machine floating ! point number system. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dble, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: xdp, y, yt INTEGER :: k ! .. ! .. External Subroutines .. EXTERNAL fmdivi, fmdm, fmim, fmntr, fmntrr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMSP2M' xdp = dble(x) IF (ntrace/=0) CALL fmntrr(2,xdp,1) ! Check to see if X is exactly a small integer. If so, ! converting as an integer is better. ! Also see if X is exactly a small integer divided by ! a small power of two. y = mxexp2 IF (abs(xdp)mexpab .OR. kdebug==1) THEN kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 IF (ma(1)==munkno) kovun = 2 ncall = ncall + 1 CALL fmmpy2(ma,ma,mb) ncall = ncall - 1 IF ((kflag<0 .AND. kovun==0) .OR. (kflag==-4 .AND. kovun==1)) THEN namest(ncall) = 'FMSQR ' CALL fmwarn END IF GO TO 140 ELSE IF (ma(2)==0) THEN CALL fmeq(ma,mb) GO TO 140 END IF kflag = 0 maxmax = 0 macca = ma(0) ma2 = ma(2) n1 = ndig + 1 mwa(1) = ma(1) + ma(1) ! NGUARD is the number of guard digits used. IF (ncall>1) THEN nguard = ngrd22 IF (nguard>ndig) nguard = ndig ELSE nguard = ngrd52 IF (nguard>ndig) nguard = ndig END IF IF (ma(2)*ma(2)1) THEN mbj = ma(2) ! Count the trailing zeros in MA. IF (ma(n1)/=0) THEN knz = n1 ELSE DO 10 j = ndig, 2, -1 IF (ma(j)/=0) THEN knz = j GO TO 20 END IF 10 CONTINUE END IF 20 mwa(2) = 0 mwa(3) = 0 DO 30 k = ndig + 2, l mwa(k) = 0 30 CONTINUE ! (Inner Loop) DO 40 k = 3, n1 mwa(k+1) = ma(k)*mbj 40 CONTINUE maxmwa = mbj DO 70 j = 3, l/2 mbj = ma(j) IF (mbj/=0) THEN maxmwa = maxmwa + mbj jm1 = j - 1 kl = min(knz,l-jm1) ! Major (Inner Loop) DO 50 k = 2*j, jm1 + kl mwa(k) = mwa(k) + ma(k-jm1)*mbj 50 CONTINUE END IF IF (maxmwa>mmax) THEN maxmax = max(maxmax,maxmwa) maxmwa = 0 ! Normalization is only required for the ! range of digits currently changing in MWA. DO 60 kb = jm1 + kl, 2*j, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase 60 CONTINUE END IF 70 CONTINUE ! Double MWA, add the square terms, and perform ! the final normalization. (Inner Loop) IF (2*max(maxmax,maxmwa)+mbase>mmax) THEN DO 80 kb = l, 4, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase 80 CONTINUE END IF DO 90 j = 3, l - 1, 2 mka = ma((j+1)/2) mwa(j) = 2*mwa(j) + mka*mka mwa(j+1) = 2*mwa(j+1) 90 CONTINUE IF (mod(l,2)==1) THEN mka = ma((l+1)/2) mwa(l) = 2*mwa(l) + mka*mka END IF DO 100 kb = l, 3, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase 100 CONTINUE ELSE ! If normalization must be done for each digit, combine ! the two loops and normalize as the digits are multiplied. DO 110 j = 2, l mwa(j) = 0 110 CONTINUE kj = ndig + 2 DO 130 j = 2, n1 kj = kj - 1 mbkj = ma(kj) IF (mbkj==0) GO TO 130 kl = l - kj + 1 IF (kl>n1) kl = n1 ki = kl + 2 kwa = kl + kj + 1 mk = 0 DO 120 k = 2, kl mt = ma(ki-k)*mbkj + mwa(kwa-k) + mk mk = int(mt/mbase) mwa(kwa-k) = mt - mbase*mk 120 CONTINUE mwa(kwa-kl-1) = mk 130 CONTINUE END IF ! Set KSHIFT = 1 if a shift left is necessary. IF (mwa(2)==0) THEN kshift = 1 ELSE kshift = 0 END IF ! The multiplication is complete. ! Round the result and move it to MB. ma(2) = ma2 mr = 2*mwa(ndig+2+kshift) + 1 IF (mr>=mbase) THEN IF (mr-1>mbase .AND. mwa(n1+kshift)1) THEN mwa(n1+kshift) = mwa(n1+kshift) + 1 mwa(n1+1+kshift) = 0 END IF ELSE CALL fmrnd(mwa,ndig,nguard,kshift) END IF END IF CALL fmmove(mwa,mb) IF (kflag<0) THEN namest(ncall) = 'FMSQR ' CALL fmwarn END IF IF (kaccsw==1) THEN md2b = nint((ndig-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(macca,md2b) ELSE mb(0) = macca END IF 140 RETURN END SUBROUTINE fmsqr2 SUBROUTINE fmsqrt(ma,mb) ! MB = SQRT(MA) IMPLICIT NONE ! Scratch array usage during FMSQRT: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, mod, nint, real, sqrt ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma1, macca, md2b, mke, mxsave REAL (KIND(0.0D0)) :: x, xb INTEGER :: j, k, kasave, kma1, kovun, kreslt, kst, ndsave ! .. ! .. Local Arrays .. INTEGER :: nstack(19) ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdig, fmdiv, fmdivi, fmdpm, fmentr, fmeq2, & fmexit, fmm2dp, fmntr, fmrslt, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)<=0) THEN CALL fmentr('FMSQRT',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMSQRT' CALL fmntr(2,ma,ma,1) END IF ndsave = ndig IF (ncall==1) THEN k = max(ngrd52-1,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN namest(ncall) = 'FMSQRT' kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF ma1 = ma(1) macca = ma(0) CALL fmeq2(ma,m02,ndsave,ndig,0) m02(0) = nint(ndig*alogm2) ! Generate the first approximation. m02(1) = 0 CALL fmm2dp(m02,x) x = sqrt(x) mke = ma1/2 kma1 = int(abs(ma1)) IF (mod(kma1,2)==1) THEN xb = mbase x = x*sqrt(xb) mke = (ma1-1)/2 END IF CALL fmdpm(x,mb) mb(1) = mb(1) + mke ! Initialize. m02(1) = ma1 CALL fmdig(nstack,kst) ! Newton iteration. DO 10 j = 1, kst ndig = nstack(j) CALL fmdiv(m02,mb,m01) CALL fmadd(mb,m01,mb) CALL fmdivi(mb,2,mb) 10 CONTINUE ! Round the result and return. IF (kasave==1) THEN md2b = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(macca,md2b) ELSE mb(0) = macca END IF CALL fmexit(mb,mb,ndsave,mxsave,kasave,0) RETURN END SUBROUTINE fmsqrt SUBROUTINE fmst2m(string,ma) ! MA = STRING ! Convert a character string to FM format. ! This is often more convenient than using FMINP, which converts an ! array of CHARACTER*1 values. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC len ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, lb ! .. ! .. External Subroutines .. EXTERNAL fmcons, fminp ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons ncall = ncall + 1 namest(ncall) = 'FMST2M' lb = len(string) DO 10 j = 1, lb cmbuff(j) = string(j:j) 10 CONTINUE CALL fminp(cmbuff,ma,1,lb) ncall = ncall - 1 RETURN END SUBROUTINE fmst2m SUBROUTINE fmsub(ma,mb,mc) ! MC = MA - MB IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kflg1 ! .. ! .. External Subroutines .. EXTERNAL fmadd2, fmntr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'FMSUB ' IF (ntrace/=0) CALL fmntr(2,ma,mb,2) kflg1 = 0 IF (mb(1)>ma(1) .OR. ma(2)==0) kflg1 = 1 IF (mb(2)==0) kflg1 = 0 ! FMADD2 will negate MB and add. ksub = 1 CALL fmadd2(ma,mb,mc) ksub = 0 ! If MA was smaller than MB, then KFLAG = 1 returned from ! FMADD means the result from FMSUB is the opposite of the ! input argument of larger magnitude, so reset KFLAG. IF (kflag==1 .AND. kflg1==1) kflag = 0 IF (ntrace/=0) CALL fmntr(1,mc,mc,1) ELSE kflg1 = 0 IF (mb(1)>ma(1) .OR. ma(2)==0) kflg1 = 1 IF (mb(2)==0) kflg1 = 0 ksub = 1 CALL fmadd2(ma,mb,mc) ksub = 0 IF (kflag==1 .AND. kflg1==1) kflag = 0 END IF ncall = ncall - 1 RETURN END SUBROUTINE fmsub SUBROUTINE fmtan(ma,mb) ! MB = TAN(MA) IMPLICIT NONE ! Scratch array usage during FMTAN: M01 - M04 ! .. Intrinsic Functions .. INTRINSIC abs, log, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, macmax, mxsave INTEGER :: jcos, jsin, jswap, k, kasave, kovun, kreslt, ndsave, ndsv ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmcos2, fmdiv, fmdivi, fmentr, fmeq2, fmexit, fmi2m, & fmim, fmmpy, fmntr, fmpi, fmrdc, fmrslt, fmsin2, fmsqr, fmsqrt, fmsub, & fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons IF (abs(ma(1))>mexpab .OR. ma(2)==0) THEN CALL fmentr('FMTAN ',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMTAN ' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52-1,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF macca = ma(0) ma2 = ma(2) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) mb(2) = abs(mb(2)) ! Reduce the argument, convert to radians if the input is ! in degrees, and evaluate the function. CALL fmrdc(mb,mb,jsin,jcos,jswap) IF (mb(1)==munkno) GO TO 10 IF (mb(2)==0) THEN IF (jswap==1) THEN CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -4 CALL fmwarn END IF GO TO 10 END IF IF (krad==0) THEN IF (mbspi/=mbase .OR. ndigpimexpab) THEN CALL fmentr('FMTANH',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 namest(ncall) = 'FMTANH' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun) kovun = 1 ndsave = ndig IF (ncall==1) THEN k = max(ngrd52-1,2) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL fmwarn ndig = ndsave kreslt = 12 CALL fmrslt(ma,ma,mb,kreslt) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 END IF kwrnsv = kwarn kwarn = 0 ma2 = ma(2) macca = ma(0) CALL fmeq2(ma,mb,ndsave,ndig,0) mb(0) = nint(ndig*alogm2) mb(2) = abs(mb(2)) IF (ma(2)==0) THEN CALL fmeq(ma,mb) GO TO 10 END IF IF (ma(1)>=1) THEN xt = real((ndig+1)/2)*alogmb k = int(log(xt)/alogmb) IF (ma(1)>k+1) THEN CALL fmi2m(1,mb) GO TO 10 ELSE x = real(mb(2)*mbase+mb(3)+1)*real(mbase)**int(mb(1)-2) IF (x>xt+5.0) THEN CALL fmi2m(1,mb) GO TO 10 END IF END IF END IF IF (mb(1)==0 .AND. ndig<50) THEN CALL fmexp2(mb,mb) CALL fmsqr(mb,mb) CALL fmi2m(1,m02) CALL fmsub(mb,m02,m03) CALL fmadd(mb,m02,m02) CALL fmdiv(m03,m02,mb) GO TO 10 END IF IF (mb(1)>=0 .AND. mb(2)/=0) THEN CALL fmcosh(mb,mb) IF (mb(1)>ndig) THEN IF (ma2>0) THEN CALL fmi2m(1,mb) GO TO 10 ELSE CALL fmi2m(-1,mb) GO TO 10 END IF END IF CALL fmsqr(mb,m03) CALL fmi2m(-1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,m03) CALL fmdiv(m03,mb,mb) ELSE CALL fmsinh(mb,mb) CALL fmsqr(mb,m03) CALL fmi2m(1,m02) CALL fmadd(m03,m02,m03) CALL fmsqrt(m03,m03) CALL fmdiv(mb,m03,mb) END IF ! Round and return. 10 kwarn = kwrnsv macmax = nint((ndsave-1)*alogm2+log(real(abs(mb(2))+1))/0.69315) mb(0) = min(mb(0),macca,macmax) IF (ma2<0 .AND. mb(1)/=munkno) mb(2) = -mb(2) CALL fmexit(mb,mb,ndsave,mxsave,kasave,kovun) RETURN END SUBROUTINE fmtanh SUBROUTINE fmtrap(ma) ! If MA has overflowed or underflowed, replace it by the appropriate ! symbol. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (ncall<=0) RETURN IF (ma(1)>mxexp+1) THEN ma(1) = mexpov IF (ma(2)>0) THEN ma(2) = 1 ELSE ma(2) = -1 END IF ma(0) = nint(ndig*alogm2) kflag = -5 END IF IF (ma(1)<-mxexp) THEN ma(1) = mexpun IF (ma(2)>0) THEN ma(2) = 1 ELSE ma(2) = -1 END IF ma(0) = nint(ndig*alogm2) kflag = -6 END IF RETURN END SUBROUTINE fmtrap SUBROUTINE fmulp(ma,mb) ! MB = The value of one Unit in the Last Place of MA at the current ! base and precision. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma1 INTEGER :: j, kwrnsv, n1 ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmim, fmmove, fmntr, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons kflag = 0 ncall = ncall + 1 namest(ncall) = 'FMULP ' IF (ntrace/=0) CALL fmntr(2,ma,ma,1) ma1 = ma(1) n1 = ndig + 1 DO 10 j = 3, n1 mwa(j) = 0 10 CONTINUE mwa(2) = 1 IF (ma(2)<0) mwa(2) = -1 mwa(1) = ma(1) - ndig + 1 IF (ma(2)==0 .OR. ma(1)>=mexpov) THEN CALL fmim(0,mb) mb(1) = munkno mb(2) = 1 mb(0) = nint(ndig*alogm2) kflag = -4 IF (ma1/=munkno) CALL fmwarn ELSE kwrnsv = kwarn IF (ma1==mexpun) kwarn = 0 CALL fmmove(mwa,mb) IF (kflag<0) THEN namest(ncall) = 'FMULP ' CALL fmwarn END IF kwarn = kwrnsv END IF mb(0) = nint(ndig*alogm2) IF (ntrace/=0) CALL fmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END SUBROUTINE fmulp SUBROUTINE fmunpk(mp,ma) ! MP is unpacked and the value returned in MA. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, mod ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mp(0:lpack) ! .. ! .. Local Scalars .. INTEGER :: j, kp ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Common Blocks .. COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kp = 2 ma(0) = mp(0) ma(1) = mp(1) ma(2) = dint(abs(mp(2))/mbase) ma(3) = abs(mp(2)) - ma(2)*mbase IF (mp(2)<0) ma(2) = -ma(2) IF (ndig>=4) THEN DO 10 j = 4, ndig, 2 kp = kp + 1 ma(j) = dint(mp(kp)/mbase) ma(j+1) = mp(kp) - ma(j)*mbase 10 CONTINUE END IF IF (mod(ndig,2)==1) ma(ndig+1) = dint(mp(kp+1)/mbase) RETURN END SUBROUTINE fmunpk SUBROUTINE fmwarn ! Called by one of the FM routines to print a warning message ! if any error condition arises in that routine. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Local Scalars .. INTEGER :: ncs CHARACTER (6) :: name ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (kflag>=0 .OR. ncall/=1 .OR. kwarn<=0) RETURN ncs = ncall name = namest(ncall) WRITE (kw,90000) kflag, name 10 ncall = ncall - 1 IF (ncall>0) THEN name = namest(ncall) WRITE (kw,90010) name GO TO 10 END IF IF (kflag==-1) THEN WRITE (kw,90020) ndigmx ELSE IF (kflag==-2) THEN WRITE (kw,90030) int(mxbase) ELSE IF (kflag==-3) THEN WRITE (kw,90040) WRITE (kw,90050) ELSE IF (kflag==-4 .OR. kflag==-7) THEN WRITE (kw,90060) WRITE (kw,90050) ELSE IF (kflag==-5) THEN WRITE (kw,90070) ELSE IF (kflag==-6) THEN WRITE (kw,90080) ELSE IF (kflag==-8 .AND. name=='FMOUT ') THEN WRITE (kw,90090) ELSE IF (kflag==-8 .AND. name=='FMREAD') THEN WRITE (kw,90100) ELSE IF (kflag==-9) THEN WRITE (kw,90110) WRITE (kw,90120) ndig, ndg2mx WRITE (kw,90050) ELSE IF (kflag==-10) THEN IF (namest(ncs)=='FMM2SP') THEN WRITE (kw,90130) ELSE WRITE (kw,90140) END IF WRITE (kw,90150) END IF ncall = ncs IF (kwarn>=2) THEN STOP END IF RETURN 90000 FORMAT (/' Error of type KFLAG =',I3,' in FM package in routine ',A6/) 90010 FORMAT (' called from ',A6) 90020 FORMAT (' NDIG must be between 2 and',I10/) 90030 FORMAT (' MBASE must be between 2 and',I10/) 90040 FORMAT (' An input argument is not a valid FM number.', & ' Its exponent is out of range.'/) 90050 FORMAT (' UNKNOWN has been returned.'/) 90060 FORMAT (' Invalid input argument for this routine.'/) 90070 FORMAT (' The result has overflowed.'/) 90080 FORMAT (' The result has underflowed.'/) 90090 FORMAT (' The result array is not big enough to hold the', & ' output character string'/' in the current format.'/ & ' The result ''***...***'' has been returned.'/) 90100 FORMAT (' The CMBUFF array is not big enough to hold the', & ' input character string'/' UNKNOWN has been returned.'/) 90110 FORMAT (' Precision could not be raised enough to provide all', & ' requested guard digits.'/) 90120 FORMAT (I23,' digits were requested (NDIG).'/ & ' Maximum number of digits currently available',' (NDG2MX) is',I7, & '.'/) 90130 FORMAT (' An FM number was too small in magnitude to ', & 'convert to single precision.'/) 90140 FORMAT (' An FM number was too small in magnitude to ', & 'convert to double precision.'/) 90150 FORMAT (' Zero has been returned.'/) END SUBROUTINE fmwarn SUBROUTINE fmwrit(kwrite,ma) ! Write MA on unit KWRITE. Multi-line numbers will have '&' as the ! last nonblank character on all but the last line. These numbers can ! then be read easily using FMREAD. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int, log10, max, min, mod, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kwrite ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, jf1sav, jf2sav, k, ksave, l, last, lb, nd, ndsave, nexp ! .. ! .. External Subroutines .. EXTERNAL fmeq2, fmout ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'FMWRIT' ndsave = ndig ndig = min(ndg2mx,max(ndig+ngrd52,2)) CALL fmeq2(ma,m01,ndsave,ndig,0) ksave = kflag nd = int(real(ndig)*log10(real(mbase))) + 1 IF (nd<2) nd = 2 nexp = int(2.0*log10(real(mxbase))) + 6 lb = min(nd+nexp,lmbuff) jf1sav = jform1 jf2sav = jform2 jform1 = 1 jform2 = nd + 6 CALL fmout(m01,cmbuff,lb) kflag = ksave ndig = ndsave jform1 = jf1sav jform2 = jf2sav last = lb + 1 DO 10 j = 1, lb IF (cmbuff(last-j)/=' ' .OR. j==lb) THEN l = last - j IF (mod(l,73)/=0) THEN WRITE (kwrite,90000) (cmbuff(k),k=1,l) ELSE IF (l>73) WRITE (kwrite,90000) (cmbuff(k),k=1,l-73) WRITE (kwrite,90010) (cmbuff(k),k=l-72,l) END IF ncall = ncall - 1 RETURN END IF 10 CONTINUE ncall = ncall - 1 RETURN 90000 FORMAT (4X,73A1,' &') 90010 FORMAT (4X,73A1) END SUBROUTINE fmwrit ! Here are the routines that work with packed FM numbers. All names ! are the same as unpacked versions with 'FM' replaced by 'FP'. ! To convert a program using the FM package from unpacked calls to ! packed calls make these changes to the program: ! '(0:LUNPCK)' to '(0:LPACK)' in dimensions. ! 'CALL FM' to 'CALL FP' ! 'FMCOMP' to 'FPCOMP'. SUBROUTINE fpabs(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmabs, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmabs(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpabs SUBROUTINE fpacos(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmacos, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmacos(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpacos SUBROUTINE fpadd(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmadd(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpadd SUBROUTINE fpaddi(ma,l) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: l ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmaddi, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmaddi(mx,l) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpaddi SUBROUTINE fpasin(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmasin, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmasin(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpasin SUBROUTINE fpatan(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmatan, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmatan(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpatan SUBROUTINE fpatn2(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmatn2, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmatn2(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpatn2 SUBROUTINE fpbig(ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmbig, fmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmbig(mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpbig SUBROUTINE fpchsh(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmchsh, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmchsh(mx,my,mx) CALL fmpack(my,mb) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpchsh FUNCTION fpcomp(ma,lrel,mb) IMPLICIT NONE ! .. Function Return Value .. LOGICAL :: fpcomp ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (2) :: lrel ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) fpcomp = fmcomp(mx,lrel,my) RETURN END FUNCTION fpcomp SUBROUTINE fpcos(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmcos, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmcos(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpcos SUBROUTINE fpcosh(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmcosh, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmcosh(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpcosh SUBROUTINE fpcssn(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmcssn, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmcssn(mx,my,mx) CALL fmpack(my,mb) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpcssn SUBROUTINE fpdig(nstack,kst) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kst ! .. ! .. Array Arguments .. INTEGER :: nstack(19) ! .. ! .. External Subroutines .. EXTERNAL fmdig ! .. CALL fmdig(nstack,kst) RETURN END SUBROUTINE fpdig SUBROUTINE fpdim(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmdim, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmdim(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpdim SUBROUTINE fpdiv(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmdiv, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmdiv(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpdiv SUBROUTINE fpdivi(ma,ival,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmdivi, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmdivi(mx,ival,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpdivi SUBROUTINE fpdp2m(x,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmdp2m(x,mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpdp2m SUBROUTINE fpdpm(x,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmdpm, fmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmdpm(x,mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpdpm SUBROUTINE fpeq(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmeq(mx,my) CALL fmpack(my,mb) RETURN END SUBROUTINE fpeq SUBROUTINE fpequ(ma,mb,nda,ndb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: nda, ndb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. Local Scalars .. INTEGER :: ndasav, ndbsav, ndgsav ! .. ! .. External Subroutines .. EXTERNAL fmeq2, fmpack, fmunpk ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: mbase INTEGER :: jform1, jform2, kdebug, keswch, kflag, krad, kround, kswide, & kw, kwarn, lvltrc, ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ndgsav = ndig ndasav = nda ndbsav = ndb ndig = ndasav CALL fmunpk(ma,mx) CALL fmeq2(mx,mx,ndasav,ndbsav,1) ndig = ndbsav CALL fmpack(mx,mb) nda = ndasav ndb = ndbsav ndig = ndgsav RETURN END SUBROUTINE fpequ SUBROUTINE fpexp(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmexp, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmexp(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpexp SUBROUTINE fpform(form,ma,string) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: form, string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmform, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmform(form,mx,string) RETURN END SUBROUTINE fpform SUBROUTINE fpfprt(form,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: form ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmfprt, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmfprt(form,mx) RETURN END SUBROUTINE fpfprt SUBROUTINE fpi2m(ival,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmi2m(ival,mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpi2m SUBROUTINE fpinp(line,ma,la,lb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: la, lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) CHARACTER (1) :: line(lb) ! .. ! .. External Subroutines .. EXTERNAL fminp, fmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fminp(line,mx,la,lb) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpinp SUBROUTINE fpint(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmint, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmint(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpint SUBROUTINE fpipwr(ma,ival,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmipwr, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmipwr(mx,ival,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpipwr SUBROUTINE fplg10(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmlg10, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmlg10(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fplg10 SUBROUTINE fpln(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmln, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmln(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpln SUBROUTINE fplni(ival,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmlni, fmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmlni(ival,mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fplni SUBROUTINE fpm2dp(ma,x) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmm2dp, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmm2dp(mx,x) RETURN END SUBROUTINE fpm2dp SUBROUTINE fpm2i(ma,ival) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmm2i, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmm2i(mx,ival) RETURN END SUBROUTINE fpm2i SUBROUTINE fpm2sp(ma,x) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmm2sp, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmm2sp(mx,x) RETURN END SUBROUTINE fpm2sp SUBROUTINE fpmax(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmmax, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmmax(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpmax SUBROUTINE fpmin(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmmin, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmmin(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpmin SUBROUTINE fpmod(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmmod, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmmod(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpmod SUBROUTINE fpmpy(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmmpy, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmmpy(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpmpy SUBROUTINE fpmpyi(ma,ival,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmmpyi, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmmpyi(mx,ival,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpmpyi SUBROUTINE fpnint(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmnint, fmpack, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmnint(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpnint SUBROUTINE fpout(ma,line,lb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) CHARACTER (1) :: line(lb) ! .. ! .. External Subroutines .. EXTERNAL fmout, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmout(mx,line,lb) RETURN END SUBROUTINE fpout SUBROUTINE fppi(ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmpi ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmpi(mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fppi SUBROUTINE fpprnt(ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmprnt, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmprnt(mx) RETURN END SUBROUTINE fpprnt SUBROUTINE fppwr(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmpwr, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmpwr(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fppwr SUBROUTINE fpread(kread,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kread ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmread ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmread(kread,mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpread SUBROUTINE fprpwr(ma,kval,jval,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: jval, kval ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmrpwr, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmrpwr(mx,kval,jval,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fprpwr SUBROUTINE fpset(nprec) ! .. Scalar Arguments .. INTEGER :: nprec ! .. ! .. External Subroutines .. EXTERNAL fmset ! .. CALL fmset(nprec) RETURN END SUBROUTINE fpset SUBROUTINE fpsign(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmsign, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmsign(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpsign SUBROUTINE fpsin(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmsin, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmsin(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpsin SUBROUTINE fpsinh(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmsinh, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmsinh(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpsinh SUBROUTINE fpsp2m(x,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL :: x ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmsp2m ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmsp2m(x,mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpsp2m SUBROUTINE fpsqr(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmsqr, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmsqr(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpsqr SUBROUTINE fpsqrt(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmsqrt, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmsqrt(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpsqrt SUBROUTINE fpst2m(string,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmst2m ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmst2m(string,mx) CALL fmpack(mx,ma) RETURN END SUBROUTINE fpst2m SUBROUTINE fpsub(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmsub, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmunpk(mb,my) CALL fmsub(mx,my,mx) CALL fmpack(mx,mc) RETURN END SUBROUTINE fpsub SUBROUTINE fptan(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmtan, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmtan(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fptan SUBROUTINE fptanh(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmtanh, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmtanh(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fptanh SUBROUTINE fpulp(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, fmulp, fmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmulp(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE fpulp SUBROUTINE fpwrit(kwrite,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kwrite ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmunpk, fmwrit ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL fmwrit(kwrite,mx) RETURN END SUBROUTINE fpwrit ! The IM routines perform integer multiple-precision arithmetic. SUBROUTINE imabs(ma,mb) ! MB = ABS(MA) IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwrnsv, ndsave ! .. ! .. External Subroutines .. EXTERNAL imargs, imeq, imntr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMABS ',1,ma,ma) ndsave = ndig IF (ntrace/=0) THEN namest(ncall) = 'IMABS ' CALL imntr(2,ma,ma,1) END IF kflag = 0 kwrnsv = kwarn kwarn = 0 CALL imeq(ma,mb) mb(2) = abs(mb(2)) kwarn = kwrnsv IF (ntrace/=0) CALL imntr(1,mb,mb,1) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imabs SUBROUTINE imadd(ma,mb,mc) ! MC = MA + MB IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, min, nint, sign ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mda, mdab, mdb INTEGER :: j, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd2, fmwarn, imargs, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMADD ',2,ma,mb) ndsave = ndig IF (ntrace/=0) THEN namest(ncall) = 'IMADD ' CALL imntr(2,ma,mb,2) END IF kflag = 0 IF (ma(1)<=2) THEN IF (mb(1)>2 .OR. ma(1)<0 .OR. mb(1)<0) GO TO 10 IF (ma(1)<=1) THEN mda = ma(2) ELSE IF (ma(2)<0) THEN mda = ma(2)*mbase - ma(3) ELSE mda = ma(2)*mbase + ma(3) END IF IF (mb(1)<=1) THEN mdb = mb(2) ELSE IF (mb(2)<0) THEN mdb = mb(2)*mbase - mb(3) ELSE mdb = mb(2)*mbase + mb(3) END IF mdab = mda + mdb IF (abs(mdab)ndg2mx .OR. mb(1)>ndg2mx .OR. ma(1)<0 .OR. mb(1)<0) THEN IF (ma(1)==munkno .OR. mb(1)==munkno) THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 GO TO 50 END IF IF (ma(1)==mexpov) THEN mda = 1 IF ((sign(mda,ma(2))==sign(mda,mb(2))) .OR. (mb(2)==0)) THEN mc(0) = ma(0) mc(1) = ma(1) mc(2) = ma(2) mc(3) = ma(3) kflag = -5 GO TO 50 ELSE mc(0) = nint(ndg2mx*alogm2) mc(1) = munkno mc(2) = 1 mc(3) = 0 kflag = -4 namest(ncall) = 'IMADD ' CALL fmwarn GO TO 50 END IF END IF IF (mb(1)==mexpov) THEN mda = 1 IF ((sign(mda,mb(2))==sign(mda,ma(2))) .OR. (ma(2)==0)) THEN mc(0) = mb(0) mc(1) = mb(1) mc(2) = mb(2) mc(3) = mb(3) kflag = -5 GO TO 50 ELSE mc(0) = nint(ndg2mx*alogm2) mc(1) = munkno mc(2) = 1 mc(3) = 0 kflag = -4 namest(ncall) = 'IMADD ' CALL fmwarn GO TO 50 END IF END IF mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 namest(ncall) = 'IMADD ' CALL fmwarn GO TO 50 END IF IF (ma(1)>mb(1)) THEN ndig = int(ma(1)) + 1 IF (ndig<2 .OR. ndig>ndg2mx) ndig = 2 ma(ndig+1) = 0 DO 20 j = int(mb(1)) + 2, ndig + 1 mb(j) = 0 20 CONTINUE ELSE ndig = int(mb(1)) + 1 IF (ndig<2 .OR. ndig>ndg2mx) ndig = 2 mb(ndig+1) = 0 DO 30 j = int(ma(1)) + 2, ndig + 1 ma(j) = 0 30 CONTINUE END IF CALL fmadd2(ma,mb,mc) 40 IF (mc(1)>ndigmx) THEN IF (ncall==1 .OR. mc(1)>ndg2mx) THEN mc(0) = nint(ndg2mx*alogm2) mc(1) = mexpov IF (mc(2)>0) THEN mc(2) = 1 ELSE mc(2) = -1 END IF mc(3) = 0 kflag = -5 namest(ncall) = 'IMADD ' CALL fmwarn END IF END IF 50 IF (ntrace/=0) CALL imntr(1,mc,mc,1) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imadd SUBROUTINE imargs(kroutn,nargs,ma,mb) ! Check the input arguments to a routine for special cases. ! KROUTN - Name of the subroutine that was called ! NARGS - The number of input arguments (1 or 2) ! MA - First input argument ! MB - Second input argument (if NARGS is 2) IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: nargs CHARACTER (6) :: kroutn ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mbs INTEGER :: j, kwrnsv, last ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = -4 IF (ma(1)==munkno) RETURN IF (nargs==2) THEN IF (mb(1)==munkno) RETURN END IF IF (mblogs/=mbase) CALL fmcons kflag = 0 ! Check the validity of parameters. IF (ncall>1 .AND. kdebug==0) RETURN namest(ncall) = kroutn ! Check MBASE. IF (mbase<2 .OR. mbase>mxbase) THEN kflag = -2 CALL fmwarn mbs = mbase IF (mbase<2) mbase = 2 IF (mbase>mxbase) mbase = mxbase WRITE (kw,90000) int(mbs), int(mbase) CALL fmcons RETURN END IF ! Check exponent range. IF (ma(1)>lunpck .OR. ma(1)<0) THEN IF (abs(ma(1))/=mexpov .OR. abs(ma(2))/=1) THEN kflag = -3 CALL fmwarn ma(0) = nint(ndg2mx*alogm2) ma(1) = munkno ma(2) = 1 ma(3) = 0 RETURN END IF END IF IF (nargs==2) THEN IF (mb(1)>lunpck .OR. mb(1)<0) THEN IF (abs(mb(1))/=mexpov .OR. abs(mb(2))/=1) THEN kflag = -3 CALL fmwarn mb(0) = nint(ndg2mx*alogm2) mb(1) = munkno mb(2) = 1 mb(3) = 0 RETURN END IF END IF END IF ! Check for properly normalized digits in the ! input arguments. IF (abs(ma(1)-int(ma(1)))/=0) kflag = 1 IF (ma(2)<=(-mbase) .OR. ma(2)>=mbase .OR. abs(ma(2)-int(ma(2)))/=0) & kflag = 2 IF (kdebug==0) GO TO 20 last = int(ma(1)) + 1 IF (ma(1)>lunpck) last = 3 DO 10 j = 3, last IF (ma(j)<0 .OR. ma(j)>=mbase .OR. abs(ma(j)-int(ma(j)))/=0) THEN kflag = j GO TO 20 END IF 10 CONTINUE 20 IF (kflag/=0) THEN j = kflag mbs = ma(j) kflag = -4 kwrnsv = kwarn IF (kwarn>=2) kwarn = 1 CALL fmwarn kwarn = kwrnsv IF (kwarn>=1) THEN WRITE (kw,*) ' First invalid array element: MA(', j, ') = ', mbs END IF ma(0) = nint(ndg2mx*alogm2) ma(1) = munkno ma(2) = 1 ma(3) = 0 IF (kwarn>=2) THEN STOP END IF RETURN END IF IF (nargs==2) THEN IF (abs(mb(1)-int(mb(1)))/=0) kflag = 1 IF (mb(2)<=(-mbase) .OR. mb(2)>=mbase .OR. abs(mb(2)-int(mb(2)))/=0) & kflag = 2 IF (kdebug==0) GO TO 40 last = int(mb(1)) + 1 IF (mb(1)>lunpck) last = 3 DO 30 j = 3, last IF (mb(j)<0 .OR. mb(j)>=mbase .OR. abs(mb(j)-int(mb(j)))/=0) THEN kflag = j GO TO 40 END IF 30 CONTINUE 40 IF (kflag/=0) THEN j = kflag mbs = mb(j) kflag = -4 kwrnsv = kwarn IF (kwarn>=2) kwarn = 1 CALL fmwarn kwarn = kwrnsv IF (kwarn>=1) THEN WRITE (kw,*) ' First invalid array element: MB(', j, ') = ', mbs END IF mb(0) = nint(ndg2mx*alogm2) mb(1) = munkno mb(2) = 1 mb(3) = 0 IF (kwarn>=2) THEN STOP END IF RETURN END IF END IF RETURN 90000 FORMAT (' MBASE was',I10,'. It has been changed to',I10,'.') END SUBROUTINE imargs SUBROUTINE imbig(ma) ! MA = The biggest representable IM integer. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j ! .. ! .. External Subroutines .. EXTERNAL fmcons, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'IMBIG ' IF (mblogs/=mbase) CALL fmcons kflag = 0 DO 10 j = 2, ndigmx + 1 ma(j) = mbase - 1 10 CONTINUE ma(1) = ndigmx ma(0) = nint(ndigmx*alogm2) IF (ntrace/=0) CALL imntr(1,ma,ma,1) ncall = ncall - 1 RETURN END SUBROUTINE imbig FUNCTION imcomp(ma,lrel,mb) ! Logical comparison of FM numbers MA and MB. ! LREL is a CHARACTER *2 description of the comparison to be done: ! LREL = 'EQ' returns IMCOMP = .TRUE. if MA.EQ.MB ! = 'NE', 'GE', 'GT', 'LE', 'LT' also work like a logical IF. ! Some compilers object to functions with side effects such as ! changing KFLAG or other common variables. Blocks of code that ! modify common are identified by: ! C DELETE START ! ... ! C DELETE STOP ! These may be removed or commented out to produce a function without ! side effects. This disables trace printing in IMCOMP, and error ! codes are not returned in KFLAG. IMPLICIT NONE ! .. Function Return Value .. LOGICAL :: imcomp ! .. ! .. Intrinsic Functions .. INTRINSIC abs, int, max ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (2) :: lrel ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, jcomp, ndsave, nlast, ntrsav CHARACTER (2) :: jrel ! .. ! .. External Subroutines .. EXTERNAL imargs, imntrj, imprnt ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ! DELETE START ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMCOMP',2,ma,mb) namest(ncall) = 'IMCOMP' IF (ncall<=lvltrc .AND. abs(ntrace)>=2) THEN WRITE (kw,90000) ndsave = ndig IF (ntrace>0) THEN CALL imprnt(ma) WRITE (kw,90010) lrel CALL imprnt(mb) ELSE ndig = max(2,int(ma(1))) IF (ndig>ndg2mx) ndig = 2 IF (ma(1)<=1) ma(3) = 0 ntrsav = ntrace IF (ntrace<-2) ntrace = -2 CALL imntrj(ma,ndig) WRITE (kw,90010) lrel ndig = max(2,int(mb(1))) IF (ndig>ndg2mx) ndig = 2 IF (mb(1)<=1) mb(3) = 0 CALL imntrj(mb,ndig) ntrace = ntrsav END IF ndig = ndsave END IF ! DELETE STOP ! JCOMP will be 1 if MA.GT.MB ! 2 if MA.EQ.MB ! 3 if MA.LT.MB ! Check for special cases. jrel = lrel IF (lrel/='EQ' .AND. lrel/='NE' .AND. lrel/='LT' .AND. lrel/='GT' .AND. & lrel/='LE' .AND. lrel/='GE') THEN IF (lrel=='eq') THEN jrel = 'EQ' ELSE IF (lrel=='ne') THEN jrel = 'NE' ELSE IF (lrel=='lt') THEN jrel = 'LT' ELSE IF (lrel=='gt') THEN jrel = 'GT' ELSE IF (lrel=='le') THEN jrel = 'LE' ELSE IF (lrel=='ge') THEN jrel = 'GE' ELSE imcomp = .FALSE. ! DELETE START kflag = -4 IF (ncall/=1 .OR. kwarn<=0) GO TO 30 ! DELETE STOP IF (kwarn<=0) GO TO 30 WRITE (kw,90020) lrel IF (kwarn>=2) THEN STOP END IF GO TO 30 END IF END IF IF (ma(1)==munkno .OR. mb(1)==munkno) THEN imcomp = .FALSE. ! DELETE START kflag = -4 ! DELETE STOP GO TO 30 END IF IF (abs(ma(1))==mexpov .AND. ma(1)==mb(1) .AND. ma(2)==mb(2)) THEN imcomp = .FALSE. ! DELETE START kflag = -4 IF (ncall/=1 .OR. kwarn<=0) GO TO 30 ! DELETE STOP IF (kwarn<=0) GO TO 30 WRITE (kw,90030) IF (kwarn>=2) THEN STOP END IF GO TO 30 END IF ! Check for zero. ! DELETE START kflag = 0 ! DELETE STOP IF (ma(2)==0) THEN jcomp = 2 IF (mb(2)<0) jcomp = 1 IF (mb(2)>0) jcomp = 3 GO TO 20 END IF IF (mb(2)==0) THEN jcomp = 1 IF (ma(2)<0) jcomp = 3 GO TO 20 END IF ! Check for opposite signs. IF (ma(2)>0 .AND. mb(2)<0) THEN jcomp = 1 GO TO 20 END IF IF (mb(2)>0 .AND. ma(2)<0) THEN jcomp = 3 GO TO 20 END IF ! See which one is larger in absolute value. IF (ma(1)>mb(1)) THEN jcomp = 1 GO TO 20 END IF IF (mb(1)>ma(1)) THEN jcomp = 3 GO TO 20 END IF nlast = int(ma(1)) + 1 IF (nlast>ndg2mx+1) nlast = 2 DO 10 j = 2, nlast IF (abs(ma(j))>abs(mb(j))) THEN jcomp = 1 GO TO 20 END IF IF (abs(mb(j))>abs(ma(j))) THEN jcomp = 3 GO TO 20 END IF 10 CONTINUE jcomp = 2 ! Now match the JCOMP value to the requested comparison. 20 IF (jcomp==1 .AND. ma(2)<0) THEN jcomp = 3 ELSE IF (jcomp==3 .AND. mb(2)<0) THEN jcomp = 1 END IF imcomp = .FALSE. IF (jcomp==1 .AND. (jrel=='GT' .OR. jrel=='GE' .OR. jrel=='NE')) & imcomp = .TRUE. IF (jcomp==2 .AND. (jrel=='EQ' .OR. jrel=='GE' .OR. jrel=='LE')) & imcomp = .TRUE. IF (jcomp==3 .AND. (jrel=='NE' .OR. jrel=='LT' .OR. jrel=='LE')) & imcomp = .TRUE. 30 CONTINUE ! DELETE START IF (ntrace/=0) THEN IF (ncall<=lvltrc .AND. abs(ntrace)>=1) THEN IF (kflag==0) THEN WRITE (kw,90040) ncall, int(mbase) ELSE WRITE (kw,90050) ncall, int(mbase), kflag END IF IF (imcomp) THEN WRITE (kw,90060) ELSE WRITE (kw,90070) END IF END IF END IF ncall = ncall - 1 ! DELETE STOP RETURN 90000 FORMAT (' Input to IMCOMP') 90010 FORMAT (7X,'.',A2,'.') 90020 FORMAT (/' Error of type KFLAG = -4 in FM package in', & ' routine IMCOMP'//1X,A,' is not one of the six', & ' recognized comparisons.'//' .FALSE. has been',' returned.'/) 90030 FORMAT (/' Error of type KFLAG = -4 in FM package in routine', & ' IMCOMP'//' Two numbers in the same overflow', & ' category cannot be compared.'//' .FALSE. has been returned.'/) 90040 FORMAT (' IMCOMP',15X,'Call level =',I2,5X,'MBASE =',I10) 90050 FORMAT (' IMCOMP',6X,'Call level =',I2,4X,'MBASE =',I10,4X,'KFLAG =',I3) 90060 FORMAT (7X,'.TRUE.') 90070 FORMAT (7X,'.FALSE.') END FUNCTION imcomp SUBROUTINE imdim(ma,mb,mc) ! MC = DIM(MA,MB) ! Positive difference. MC = MA - MB if MA.GE.MB, ! = 0 otherwise. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kovfl ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL fmwarn, imargs, imntr, imsub ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMDIM ',2,ma,mb) IF (ntrace/=0) THEN namest(ncall) = 'IMDIM ' CALL imntr(2,ma,mb,2) END IF IF (ma(1)==munkno .OR. mb(1)==munkno) THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 GO TO 10 END IF IF (ma(1)<0 .OR. mb(1)<0) THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 namest(ncall) = 'IMDIM ' CALL fmwarn GO TO 10 END IF kovfl = 0 IF (ma(1)==mexpov .OR. mb(1)==mexpov) THEN kovfl = 1 IF (ma(1)==mexpov .AND. mb(1)==mexpov .AND. ma(2)==mb(2)) THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 namest(ncall) = 'IMDIM ' CALL fmwarn GO TO 10 END IF END IF IF (imcomp(ma,'GE',mb)) THEN CALL imsub(ma,mb,mc) IF (kflag==1) kflag = 0 ELSE mc(1) = 0 mc(2) = 0 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) END IF IF (mc(1)>ndigmx) THEN IF (mc(1)==munkno) THEN kflag = -4 namest(ncall) = 'IMDIM ' CALL fmwarn ELSE IF (ncall==1 .OR. mc(1)>ndg2mx) THEN mc(0) = nint(ndg2mx*alogm2) mc(1) = mexpov IF (mc(2)>0) THEN mc(2) = 1 ELSE mc(2) = -1 END IF mc(3) = 0 kflag = -5 namest(ncall) = 'IMDIM ' IF (kovfl/=1) CALL fmwarn END IF END IF 10 IF (ntrace/=0) CALL imntr(1,mc,mc,1) ncall = ncall - 1 RETURN END SUBROUTINE imdim SUBROUTINE imdiv(ma,mb,mc) ! MC = INT(MA/MB) ! Use IMDIVR if both INT(MA/MB) and MOD(MA,MB) are needed. IMPLICIT NONE ! Scratch array usage during IMDIV: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: ndsave ! .. ! .. External Subroutines .. EXTERNAL fmwarn, imargs, imdivr, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMDIV ',2,ma,mb) kflag = 0 ndsave = ndig IF (ntrace/=0) THEN namest(ncall) = 'IMDIV ' CALL imntr(2,ma,mb,2) END IF IF (ma(1)==munkno .OR. mb(1)==munkno) THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 GO TO 10 END IF CALL imdivr(ma,mb,mc,m03) IF (mc(1)==munkno) THEN kflag = -4 namest(ncall) = 'IMDIV ' CALL fmwarn END IF 10 IF (ntrace/=0) CALL imntr(1,mc,mc,1) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imdiv SUBROUTINE imdivi(ma,idiv,mb) ! MB = INT(MA/IDIV) ! Use IMDVIR if both INT(MA/IDIV) and MOD(MA,IDIV) are needed. IMPLICIT NONE ! Scratch array usage during IMDIVI: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: idiv ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: irem, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmwarn, imargs, imdvir, imntr, imntri ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMDIVI',1,ma,ma) kflag = 0 ndsave = ndig IF (ntrace/=0) THEN namest(ncall) = 'IMDIVI' CALL imntr(2,ma,ma,1) CALL imntri(2,idiv,0) END IF IF (ma(1)==munkno) THEN mb(1) = munkno mb(2) = 1 mb(3) = 0 mb(0) = nint(ndg2mx*alogm2) kflag = -4 GO TO 10 END IF CALL imdvir(ma,idiv,mb,irem) IF (mb(1)==munkno) THEN kflag = -4 namest(ncall) = 'IMDIVI' CALL fmwarn END IF 10 IF (ntrace/=0) CALL imntr(1,mb,mb,1) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imdivi SUBROUTINE imdivr(ma,mb,mc,md) ! MC = INT(MA / MB), MD = Remainder from the division. IMPLICIT NONE ! Scratch array usage during IMDIVR: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC abs, dble, dint, int, max, min, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, ma2p, macca, maccb, maxmwa, mb1, mb2, mb2p, mbm1, & mcarry, mda, mdab, mdb, mdr, mkt, mlmax, mqd REAL (KIND(0.0D0)) :: xb, xbase, xbr, xmwa INTEGER :: j, jb, jl, k, ka, kb, kl, kltflg, kptmwa, lcrrct, na1, nb1, & ndsave, nguard, nl, nmbwds, ntrsav ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmwarn, imadd, imargs, imeq, imi2m, imntr, imntrj, & imprnt, imsub ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMDIVR',2,ma,mb) ndsave = ndig IF (ntrace/=0) THEN namest(ncall) = 'IMDIVR' CALL imntr(2,ma,mb,2) END IF kflag = 0 ntrsav = ntrace ntrace = 0 IF (mblogs/=mbase) CALL fmcons ! Check for special cases. IF (mb(1)==1 .AND. ma(1)/=munkno) THEN IF (mb(2)==1) THEN CALL imeq(ma,mc) md(1) = 0 md(2) = 0 md(3) = 0 md(0) = nint(ndg2mx*alogm2) GO TO 260 ELSE IF (mb(2)==-1) THEN CALL imeq(ma,mc) IF (mc(1)/=munkno) mc(2) = -mc(2) md(1) = 0 md(2) = 0 md(3) = 0 md(0) = nint(ndg2mx*alogm2) GO TO 260 END IF END IF IF (ma(1)ndg2mx .OR. mb(1)>ndg2mx .OR. ma(1)<0 .OR. mb(1)<0 .OR. & mb(2)==0) THEN kflag = -4 IF (ma(1)/=munkno .AND. mb(1)/=munkno) THEN namest(ncall) = 'IMDIVR' CALL fmwarn END IF mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) md(1) = munkno md(2) = 1 md(3) = 0 md(0) = nint(ndg2mx*alogm2) GO TO 260 END IF IF (ma(1)<=2) THEN IF (mb(1)>2) GO TO 10 IF (mb(2)==0) GO TO 10 IF (ma(1)<=1) THEN mda = ma(2) ELSE IF (ma(2)<0) THEN mda = ma(2)*mbase - ma(3) ELSE mda = ma(2)*mbase + ma(3) END IF IF (mb(1)<=1) THEN mdb = mb(2) ELSE IF (mb(2)<0) THEN mdb = mb(2)*mbase - mb(3) ELSE mdb = mb(2)*mbase + mb(3) END IF mdab = dint(mda/mdb) mdr = mda - mdab*mdb IF (abs(mdab)ndg2mx) kl = 2 DO 20 j = 0, kl + 1 m01(j) = mb(j) 20 CONTINUE m01(2) = abs(m01(2)) IF (kl==1) m01(3) = 0 IF (ma(1)==m01(1) .AND. abs(ma(2))<=m01(2)) THEN ma(2) = abs(ma(2)) IF (imcomp(ma,'EQ',m01)) THEN kltflg = 2 ELSE IF (imcomp(ma,'LT',m01)) THEN kltflg = 1 END IF ma(2) = ma2 END IF IF (ma(1)=1) THEN IF (kltflg/=2) THEN CALL imeq(ma,md) md(2) = abs(md(2)) CALL imi2m(0,mc) ELSE CALL imi2m(1,mc) CALL imi2m(0,md) END IF GO TO 250 END IF ndig = int(ma(1)) IF (ndig<2) ndig = 2 macca = ma(0) maccb = mb(0) ! NGUARD is the number of guard digits used. nguard = 1 ma2p = abs(ma(2)) mb2p = abs(mb(2)) na1 = int(ma(1)) + 1 nb1 = int(mb(1)) + 1 ! Copy MA into the working array. DO 30 j = 3, na1 mwa(j+1) = ma(j) 30 CONTINUE mwa(1) = ma(1) - mb(1) + 1 mwa(2) = 0 nl = na1 + nguard + 3 DO 40 j = na1 + 2, nl mwa(j) = 0 40 CONTINUE ! Save the sign of MA and MB and then work only with ! positive numbers. ma2 = ma(2) mb1 = mb(1) mb2 = mb(2) ma(2) = ma2p mwa(3) = ma(2) mb(1) = 0 mb(2) = mb2p ! NMBWDS is the number of words of MB used to ! compute the estimated quotient digit MQD. nmbwds = 4 IF (mbase<100) nmbwds = 7 ! XB is an approximation of MB used in ! estimating the quotient digits. xbase = dble(mbase) xb = 0 jl = nmbwds IF (jl<=nb1) THEN DO 50 j = 2, jl xb = xb*xbase + dble(mb(j)) 50 CONTINUE ELSE DO 60 j = 2, jl IF (j<=nb1) THEN xb = xb*xbase + dble(mb(j)) ELSE xb = xb*xbase END IF 60 CONTINUE END IF IF (jl+1<=nb1) xb = xb + dble(mb(jl+1))/xbase xbr = 1.0D0/xb ! MLMAX determines when to normalize all of MWA. mbm1 = mbase - 1 mlmax = maxint/mbm1 mkt = intmax - mbase mlmax = min(mlmax,mkt) ! MAXMWA is an upper bound on the size of values in MWA ! divided by MBASE-1. It is used to determine whether ! normalization can be postponed. maxmwa = 0 ! KPTMWA points to the next digit in the quotient. kptmwa = 2 ! This is the start of the division loop. ! XMWA is an approximation of the active part of MWA ! used in estimating quotient digits. 70 kl = kptmwa + nmbwds - 1 IF (kl<=nl) THEN xmwa = ((dble(mwa(kptmwa))*xbase+dble(mwa(kptmwa+1)))*xbase+dble(mwa( & kptmwa+2)))*xbase + dble(mwa(kptmwa+3)) DO 80 j = kptmwa + 4, kl xmwa = xmwa*xbase + dble(mwa(j)) 80 CONTINUE ELSE xmwa = dble(mwa(kptmwa)) DO 90 j = kptmwa + 1, kl IF (j<=nl) THEN xmwa = xmwa*xbase + dble(mwa(j)) ELSE xmwa = xmwa*xbase END IF 90 CONTINUE END IF ! MQD is the estimated quotient digit. mqd = dint(xmwa*xbr) IF (mqd<0) mqd = mqd - 1 IF (mqd>0) THEN maxmwa = maxmwa + mqd ELSE maxmwa = maxmwa - mqd END IF ! See if MWA must be normalized. ka = kptmwa + 1 kb = ka + int(mb1) - 1 IF (maxmwa>=mlmax) THEN DO 100 j = kb, ka, -1 IF (mwa(j)<0) THEN mcarry = int((-mwa(j)-1)/mbase) + 1 mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry ELSE IF (mwa(j)>=mbase) THEN mcarry = -int(mwa(j)/mbase) mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry END IF 100 CONTINUE xmwa = 0 IF (kl<=nl) THEN DO 110 j = kptmwa, kl xmwa = xmwa*xbase + dble(mwa(j)) 110 CONTINUE ELSE DO 120 j = kptmwa, kl IF (j<=nl) THEN xmwa = xmwa*xbase + dble(mwa(j)) ELSE xmwa = xmwa*xbase END IF 120 CONTINUE END IF mqd = dint(xmwa*xbr) IF (mqd<0) mqd = mqd - 1 IF (mqd>0) THEN maxmwa = mqd ELSE maxmwa = -mqd END IF END IF ! Subtract MQD*MB from MWA. jb = ka - 2 IF (mqd/=0) THEN ! Major (Inner Loop) DO 130 j = ka, kb mwa(j) = mwa(j) - mqd*mb(j-jb) 130 CONTINUE END IF mwa(ka) = mwa(ka) + mwa(ka-1)*mbase mwa(kptmwa) = mqd kptmwa = kptmwa + 1 IF (kptmwa-2=mbase) THEN mcarry = -int(mwa(j)/mbase) mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry END IF 140 CONTINUE lcrrct = 0 150 DO 160 j = kptmwa + int(mb1), kptmwa + 2, -1 IF (mwa(j)<0) THEN mcarry = int((-mwa(j)-1)/mbase) + 1 mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry ELSE IF (mwa(j)>=mbase) THEN mcarry = -int(mwa(j)/mbase) mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry END IF 160 CONTINUE ! Due to rounding, the remainder may not be between ! 0 and ABS(MB) here. Correct if necessary. IF (mwa(ka)<0) THEN lcrrct = lcrrct - 1 DO 170 j = ka, kb mwa(j) = mwa(j) + mb(j-jb) 170 CONTINUE GO TO 150 ELSE IF (mwa(ka)>=mbase) THEN lcrrct = lcrrct + 1 DO 180 j = ka, kb mwa(j) = mwa(j) - mb(j-jb) 180 CONTINUE GO TO 150 END IF ma(2) = ma2 mb(1) = mb1 mb(2) = mb2 IF (mwa(2)/=0 .OR. kptmwa==2) THEN DO 190 j = 1, int(mwa(1)) + 1 mc(j) = mwa(j) 190 CONTINUE ELSE DO 200 j = 3, int(mwa(1)) + 1 mc(j-1) = mwa(j) 200 CONTINUE IF (mc(2)/=0) THEN mc(1) = mwa(1) - 1 ELSE mc(1) = 0 END IF END IF IF (mc(1)<=1) mc(3) = 0 mc(0) = min(macca,maccb) IF (mwa(kptmwa+1)/=0) THEN DO 210 j = 1, int(mb1) md(j+1) = mwa(kptmwa+j) 210 CONTINUE md(1) = mb1 ELSE DO 230 j = 1, int(mb1) IF (mwa(kptmwa+j)/=0) THEN DO 220 k = j, int(mb1) md(k-j+2) = mwa(kptmwa+k) 220 CONTINUE md(1) = mb1 + 1 - j GO TO 240 END IF 230 CONTINUE md(1) = 0 md(2) = 0 END IF 240 IF (md(1)<=1) md(3) = 0 md(0) = min(macca,maccb) ! If the remainder had to be corrected, make the ! corresponding adjustment in the quotient. IF (md(1)>m01(1) .OR. (md(1)==m01(1) .AND. abs(md(2))>=m01(2))) THEN IF (imcomp(md,'GE',m01)) THEN CALL imsub(md,m01,md) lcrrct = lcrrct + 1 END IF END IF IF (lcrrct/=0) THEN CALL imi2m(lcrrct,m02) CALL imadd(m02,mc,mc) END IF 250 IF (ma2<0 .AND. mb2>0) THEN IF (mc(1)/=munkno) mc(2) = -mc(2) IF (md(1)/=munkno) md(2) = -md(2) ELSE IF (ma2>0 .AND. mb2<0) THEN IF (mc(1)/=munkno) mc(2) = -mc(2) ELSE IF (ma2<0 .AND. mb2<0) THEN IF (md(1)/=munkno) md(2) = -md(2) END IF 260 ntrace = ntrsav IF (ntrace/=0) THEN CALL imntr(1,mc,mc,1) IF (abs(ntrace)>=1 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN ndig = max(2,int(md(1))) IF (ndig>ndg2mx) ndig = 2 IF (md(1)<=1) md(3) = 0 ntrsav = ntrace IF (ntrace<-2) ntrace = -2 CALL imntrj(md,ndig) ntrace = ntrsav ELSE CALL imprnt(md) END IF END IF END IF ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imdivr SUBROUTINE imdvir(ma,idiv,mb,irem) ! MB = INT(MA / IDIV), IREM = Remainder from the division. ! Division by a one word integer. The remainder is also a ! one word integer. IMPLICIT NONE ! Scratch array usage during IMDVIR: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: idiv, irem ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, mda, mdab, mdb, mdr, mkt, modint, mvalp INTEGER :: j, jdiv, ka, kl, kltflg, kpt, n1, ndsave, nmval, ntrsav, nv2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL fmwarn, imargs, imdivr, imeq, imi2m, imm2i, imntr, imntri ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMDVIR',1,ma,ma) kflag = 0 ndsave = ndig kltflg = 0 ntrsav = ntrace ntrace = 0 mkt = abs(idiv) IF (mktndg2mx .OR. idiv==0) THEN kflag = -4 IF (ma(1)/=munkno) THEN namest(ncall) = 'IMDVIR' CALL fmwarn END IF mb(1) = munkno mb(2) = 1 mb(3) = 0 mb(0) = nint(ndg2mx*alogm2) irem = iunkno GO TO 70 END IF IF (ma(1)<=2) THEN IF (ma(1)<=1) THEN mda = ma(2) ELSE IF (ma(2)<0) THEN mda = ma(2)*mbase - ma(3) ELSE mda = ma(2)*mbase + ma(3) END IF mdb = idiv mdab = dint(mda/mdb) mdr = mda - mdab*mdb IF (abs(mdab)=1) THEN IF (kltflg/=2) THEN CALL imm2i(ma,irem) irem = abs(irem) CALL imi2m(0,mb) ELSE CALL imi2m(1,mb) irem = 0 END IF GO TO 60 END IF END IF ndig = int(ma(1)) IF (ndig<2) ndig = 2 n1 = int(ma(1)) + 1 ! If ABS(IDIV).GE.MXBASE use IMDIVR. mvalp = abs(idiv) nmval = int(mvalp) nv2 = nmval - 1 IF (abs(idiv)>mxbase .OR. nmval/=abs(idiv) .OR. nv2/=abs(idiv)-1) THEN CALL imi2m(idiv,m03) CALL imdivr(ma,m03,mb,m03) CALL imm2i(m03,irem) GO TO 70 END IF ! Work with positive numbers. ma(2) = abs(ma(2)) ! Find the first significant digit of the quotient. mkt = ma(2) IF (mkt>=mvalp) THEN kpt = 2 GO TO 30 END IF DO 20 j = 3, n1 mkt = mkt*mbase + ma(j) IF (mkt>=mvalp) THEN kpt = j GO TO 30 END IF 20 CONTINUE CALL imm2i(ma,irem) CALL imi2m(0,mb) GO TO 70 ! Do the rest of the division. 30 ka = kpt + 1 mwa(1) = ma(1) + 2 - kpt mwa(2) = int(mkt/mvalp) modint = mkt - mwa(2)*mvalp IF (ka<=n1) THEN kl = 3 - ka ! (Inner Loop) DO 40 j = ka, n1 mkt = modint*mbase + ma(j) mwa(kl+j) = int(mkt/mvalp) modint = mkt - mwa(kl+j)*mvalp 40 CONTINUE END IF mb(0) = ma(0) DO 50 j = 1, int(mwa(1)) + 1 mb(j) = mwa(j) 50 CONTINUE irem = int(modint) 60 IF (ma2<0 .AND. idiv>0) THEN IF (mb(1)/=munkno) mb(2) = -mb(2) irem = -irem ELSE IF (ma2>0 .AND. idiv<0) THEN IF (mb(1)/=munkno) mb(2) = -mb(2) ELSE IF (ma2<0 .AND. idiv<0) THEN irem = -irem END IF 70 IF (ntrace/=0 .AND. ncall<=lvltrc) THEN CALL imntr(1,mb,mb,1) CALL imntri(1,irem,0) END IF ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imdvir SUBROUTINE imeq(ma,mb) ! MB = MA IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int, max ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, kdg ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kdg = max(2,int(ma(1))) + 1 IF (kdg>lunpck) kdg = 3 DO 10 j = 0, kdg mb(j) = ma(j) 10 CONTINUE RETURN END SUBROUTINE imeq SUBROUTINE imfm2i(ma,mb) ! MB = INT(MA) ! Convert from real (FM) format to integer (IM) format. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: ntrsav ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmint, fmwarn ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 kflag = 0 ntrsav = ntrace ntrace = 0 CALL fmeq(ma,mb) CALL fmint(mb,mb) IF (mb(1)>ndigmx) THEN IF (mb(1)<=ndg2mx .OR. ncall<=1) THEN mb(0) = nint(ndg2mx*alogm2) mb(1) = munkno mb(2) = 1 mb(3) = 0 kflag = -4 namest(ncall) = 'IMFM2I' CALL fmwarn END IF END IF ntrace = ntrsav ncall = ncall - 1 RETURN END SUBROUTINE imfm2i SUBROUTINE imform(form,ma,string) ! Convert an IM number (MA) to a character string base 10 (STRING) ! using character string FORM format. ! FORM can be one of these types: Iw, Fw.d, Ew.d, 1PEw.d ! for positive integers w,d. IMPLICIT NONE ! Scratch array usage during IMFORM: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: form, string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: ndsave ! .. ! .. External Subroutines .. EXTERNAL fmform, imargs ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMFORM',1,ma,ma) kflag = 0 namest(ncall) = 'IMFORM' ndsave = ndig ndig = int(ma(1)) IF (ndig<2 .OR. ndig>ndg2mx) ndig = 2 IF (ma(1)<=1) ma(3) = 0 CALL fmform(form,ma,string) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imform SUBROUTINE imfprt(form,ma) ! Print an IM number (MA) on unit KW using character ! string FORM format. ! FORM can be one of these types: Iw, Fw.d, Ew.d, 1PEw.d ! for positive integers w,d. IMPLICIT NONE ! Scratch array usage during IMFPRT: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: form ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: ndsave ! .. ! .. External Subroutines .. EXTERNAL fmfprt, imargs ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMFPRT',1,ma,ma) kflag = 0 namest(ncall) = 'IMFPRT' ndsave = ndig ndig = int(ma(1)) IF (ndig<2 .OR. ndig>ndg2mx) ndig = 2 IF (ma(1)<=1) ma(3) = 0 CALL fmfprt(form,ma) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imfprt SUBROUTINE imgcd(ma,mb,mc) ! MC is returned as the greatest common divisor of MA and MB. IMPLICIT NONE ! Scratch array usage during IMGCD: M01 - M05 ! .. Intrinsic Functions .. INTRINSIC abs, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: ndsave ! .. ! .. External Subroutines .. EXTERNAL fmwarn, imabs, imargs, imdivr, imeq, imi2m, immax, immin, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMGCD ',2,ma,mb) kflag = 0 ndsave = ndig IF (ntrace/=0) THEN namest(ncall) = 'IMGCD ' CALL imntr(2,ma,mb,2) END IF ! Check for special cases. IF (ma(1)==munkno .OR. mb(1)==munkno) THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 GO TO 20 ELSE IF (mb(2)==0) THEN CALL imabs(ma,mc) GO TO 20 ELSE IF (ma(2)==0) THEN CALL imabs(mb,mc) GO TO 20 ELSE IF (mb(1)==1 .AND. abs(mb(2))==1) THEN CALL imi2m(1,mc) GO TO 20 ELSE IF (ma(1)==1 .AND. abs(ma(2))==1) THEN CALL imi2m(1,mc) GO TO 20 ELSE IF (ma(1)>=ndg2mx .OR. mb(1)>=ndg2mx .OR. ma(1)<0 .OR. mb(1)<0) & THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 namest(ncall) = 'IMGCD ' CALL fmwarn GO TO 20 END IF CALL imabs(ma,m05) CALL imabs(mb,m04) CALL immax(m05,m04,m03) CALL immin(m05,m04,m04) 10 CALL imdivr(m03,m04,mc,m05) IF (m05(2)/=0) THEN CALL imeq(m04,m03) CALL imeq(m05,m04) GO TO 10 END IF CALL imeq(m04,mc) IF (mc(1)==munkno) THEN kflag = -4 namest(ncall) = 'IMGCD ' CALL fmwarn END IF 20 IF (ntrace/=0) CALL imntr(1,mc,mc,1) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imgcd SUBROUTINE imi2fm(ma,mb) ! MB = MA ! Convert from integer (IM) format to real (FM) format. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int, max, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kdg ! .. ! .. External Subroutines .. EXTERNAL fmequ, imargs ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMI2FM',1,ma,ma) kflag = 0 kdg = max(2,int(ma(1))) IF (kdg>ndg2mx) kdg = 2 IF (ma(1)<=1) ma(3) = 0 CALL fmequ(ma,mb,kdg,ndig) mb(0) = nint(ndg2mx*alogm2) ncall = ncall - 1 RETURN END SUBROUTINE imi2fm SUBROUTINE imi2m(ival,ma) ! MA = IVAL ! Convert a one word integer to IM format. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: ndsave ! .. ! .. External Subroutines .. EXTERNAL fmim, imntr, imntri ! .. ! .. 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 kflag = 0 ndsave = ndig IF (ntrace/=0) THEN namest(ncall) = 'IMI2M ' CALL imntri(2,ival,1) ndig = 4 CALL fmim(ival,ma) IF (ma(1)>4) THEN ndig = ndigmx CALL fmim(ival,ma) END IF CALL imntr(1,ma,ma,1) ELSE ndig = 4 CALL fmim(ival,ma) IF (ma(1)>4) THEN ndig = ndigmx CALL fmim(ival,ma) END IF END IF ndig = ndsave ncall = ncall - 1 RETURN END SUBROUTINE imi2m SUBROUTINE iminp(line,ma,la,lb) ! Convert an array of characters to multiple precision integer format. ! LINE is an A1 character array of length LB to be converted ! to IM format and returned in MA. ! LA is a pointer telling the routine where in the array to begin ! the conversion. ! LB is a pointer to the last character of the field for that number. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: la, lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) CHARACTER (1) :: line(lb) ! .. ! .. Local Scalars .. INTEGER :: kfsave, ndsave ! .. ! .. External Subroutines .. EXTERNAL fminp, fmint, fmwarn, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 kflag = 0 ndsave = ndig namest(ncall) = 'IMINP ' ndig = ndigmx CALL fminp(line,ma,la,lb) kfsave = kflag CALL fmint(ma,ma) kflag = kfsave IF (ma(1)>ndg2mx .AND. ma(1)mexpab) THEN CALL fmargs('IMM2DP',1,ma,ma,kreslt) END IF IF (ntrace/=0) CALL imntr(2,ma,ma,1) IF (kreslt/=0) THEN ! Here no valid result can be returned. Set X to some ! value that the user is likely to recognize as wrong. x = dble(runkno) kflag = -4 IF (ma(1)/=munkno) CALL fmwarn IF (ntrace/=0) CALL imntrr(1,x,1) ncall = ncall - 1 RETURN END IF ndsave = ndig ndig = max(2,int(ma(1))) IF (ndig>ndg2mx) ndig = 2 IF (ma(1)<=1) ma(3) = 0 CALL fmmd(ma,x) IF (ntrace/=0) CALL imntrr(1,x,1) ndig = ndsave ncall = ncall - 1 RETURN END SUBROUTINE imm2dp SUBROUTINE imm2i(ma,ival) ! IVAL = MA ! Convert an IM number to a one word integer. ! KFLAG = 0 is returned if the conversion is exact. ! = -4 is returned if MA is larger than INTMAX in magnitude. ! IVAL = IUNKNO is returned as an indication that IVAL ! could not be computed without integer overflow. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: ndsave ! .. ! .. External Subroutines .. EXTERNAL fmm2i, imargs, imntr, imntri ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMM2I ',1,ma,ma) ndsave = ndig IF (ntrace/=0) THEN namest(ncall) = 'IMM2I ' CALL imntr(2,ma,ma,1) END IF ndig = int(ma(1)) IF (ndig<2) ndig = 2 IF (ndig>ndg2mx) ndig = 2 IF (ma(1)<=1) ma(3) = 0 kflag = 0 CALL fmm2i(ma,ival) IF (abs(ntrace)>=1 .AND. ncall<=lvltrc) THEN CALL imntri(1,ival,1) END IF ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imm2i SUBROUTINE immax(ma,mb,mc) ! MC = MAX(MA,MB) IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwrnsv ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL imargs, imeq, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMMAX ',2,ma,mb) IF (ntrace/=0) THEN namest(ncall) = 'IMMAX ' CALL imntr(2,ma,mb,2) END IF kwrnsv = kwarn kwarn = 0 IF (ma(1)==munkno .OR. mb(1)==munkno) THEN mc(1) = munkno mc(2) = 1 mc(0) = nint(ndg2mx*alogm2) kflag = -4 ELSE IF (imcomp(ma,'LT',mb)) THEN CALL imeq(mb,mc) ELSE CALL imeq(ma,mc) END IF kwarn = kwrnsv IF (ntrace/=0) CALL imntr(1,mc,mc,1) ncall = ncall - 1 RETURN END SUBROUTINE immax SUBROUTINE immin(ma,mb,mc) ! MC = MIN(MA,MB) IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwrnsv ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL imargs, imeq, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMMIN ',2,ma,mb) IF (ntrace/=0) THEN namest(ncall) = 'IMMIN ' CALL imntr(2,ma,mb,2) END IF kwrnsv = kwarn kwarn = 0 IF (ma(1)==munkno .OR. mb(1)==munkno) THEN mc(1) = munkno mc(2) = 1 mc(0) = nint(ndg2mx*alogm2) kflag = -4 ELSE IF (imcomp(ma,'GT',mb)) THEN CALL imeq(mb,mc) ELSE CALL imeq(ma,mc) END IF kwarn = kwrnsv IF (ntrace/=0) CALL imntr(1,mc,mc,1) ncall = ncall - 1 RETURN END SUBROUTINE immin SUBROUTINE immod(ma,mb,mc) ! MC = MOD(MA,MB) ! Use IMDIVR if both INT(MA/MB) and MOD(MA,MB) are needed. IMPLICIT NONE ! Scratch array usage during IMMOD: M01 - M03 ! .. Intrinsic Functions .. INTRINSIC nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: ndsave ! .. ! .. External Subroutines .. EXTERNAL fmwarn, imargs, imdivr, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMMOD ',2,ma,mb) kflag = 0 ndsave = ndig IF (ntrace/=0) THEN namest(ncall) = 'IMMOD ' CALL imntr(2,ma,mb,2) END IF IF (ma(1)==munkno .OR. mb(1)==munkno) THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 GO TO 10 END IF CALL imdivr(ma,mb,m03,mc) IF (mc(1)==munkno) THEN kflag = -4 namest(ncall) = 'IMMOD ' CALL fmwarn END IF 10 IF (ntrace/=0) CALL imntr(1,mc,mc,1) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE immod SUBROUTINE immpy(ma,mb,mc) ! MC = MA * MB IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, min, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mdab INTEGER :: j, kovfl, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmmpy2, fmwarn, imargs, imeq, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMMPY ',2,ma,mb) kflag = 0 ndsave = ndig IF (ntrace/=0) THEN namest(ncall) = 'IMMPY ' CALL imntr(2,ma,mb,2) END IF IF (ma(1)<=1) THEN IF (mb(1)>1) GO TO 10 mdab = ma(2)*mb(2) IF (abs(mdab)ndg2mx) ndig = ndg2mx IF (ma(1)==mexpov .OR. mb(1)==mexpov) ndig = 2 DO 20 j = int(ma(1)) + 2, ndig + 1 ma(j) = 0 20 CONTINUE DO 30 j = int(mb(1)) + 2, ndig + 1 mb(j) = 0 30 CONTINUE CALL fmmpy2(ma,mb,mc) IF (ndig>ndigmx) ndig = 2 40 IF (mc(1)>ndigmx) THEN IF (ncall==1 .OR. mc(1)>ndg2mx) THEN mc(0) = nint(ndg2mx*alogm2) mc(1) = mexpov IF (mc(2)>0) THEN mc(2) = 1 ELSE mc(2) = -1 END IF mc(3) = 0 kflag = -5 namest(ncall) = 'IMMPY ' IF (kovfl/=1) CALL fmwarn END IF END IF 50 IF (ntrace/=0) CALL imntr(1,mc,mc,1) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE immpy SUBROUTINE immpy2(ma,mb) ! Internal multiplication of MA*MB. The result is returned in MWA. ! Both MA and MB are positive. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC dint, int, min ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maxmwa, mbj, mbm1, mkt, mmax INTEGER :: j, jm1, k, kb, kl, klma, klmb, n1 ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. n1 = ndig + 1 mwa(1) = ma(1) + mb(1) mwa(n1+1) = 0 ! The multiplication loop begins here. ! MAXMWA is an upper bound on the size of values in MWA ! divided by (MBASE-1). It is used to determine ! whether to normalize before the next digit is ! multiplied. mbm1 = mbase - 1 mmax = intmax - mbase mmax = min(dint(maxint/mbm1-mbm1),mmax) mbj = mb(2) mwa(2) = 0 klma = int(ma(1)) DO 10 k = klma + 3, n1 mwa(k) = 0 10 CONTINUE ! (Inner Loop) DO 20 k = 2, klma + 1 mwa(k+1) = ma(k)*mbj 20 CONTINUE maxmwa = mbj klmb = int(mb(1)) DO 50 j = 3, klmb + 1 mbj = mb(j) IF (mbj/=0) THEN maxmwa = maxmwa + mbj jm1 = j - 1 kl = klma + 1 ! Major (Inner Loop) DO 30 k = j + 1, j + klma mwa(k) = mwa(k) + ma(k-jm1)*mbj 30 CONTINUE END IF IF (maxmwa>mmax) THEN maxmwa = 0 ! Here normalization is only required for the ! range of digits currently changing in MWA. DO 40 kb = jm1 + kl, jm1 + 2, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase 40 CONTINUE END IF 50 CONTINUE ! Perform the final normalization. (Inner Loop) DO 60 kb = n1, 3, -1 mkt = int(mwa(kb)/mbase) mwa(kb-1) = mwa(kb-1) + mkt mwa(kb) = mwa(kb) - mkt*mbase 60 CONTINUE RETURN END SUBROUTINE immpy2 SUBROUTINE immpyi(ma,ival,mb) ! MB = MA * IVAL ! Multiplication by a one word integer. IMPLICIT NONE ! Scratch array usage during IMMPYI: M01 ! .. Intrinsic Functions .. INTRINSIC abs, dble, dint, int, log, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, mcarry, mdab, mkt, mval INTEGER :: j, ka, kb, kc, kovfl, kshift, n1, ndsave, nmval, ntrsav, nv2 ! .. ! .. External Subroutines .. EXTERNAL fmim, fmmpy2, fmwarn, imargs, imeq, imi2m, imntr, imntri ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMMPYI',1,ma,ma) kflag = 0 ndsave = ndig ntrsav = ntrace ntrace = 0 ntrace = ntrsav IF (ntrace/=0) THEN namest(ncall) = 'IMMPYI' CALL imntr(2,ma,ma,1) CALL imntri(2,ival,0) END IF ma2 = ma(2) IF (ma(1)<=1) THEN mdab = ma(2)*ival IF (abs(mdab)ndig .OR. mval>maxint/mbase .OR. nmval/=abs(ival) .OR. & nv2/=abs(ival)-1) THEN ma(2) = ma2 ndig = 4 CALL fmim(ival,m01) ndig = int(ma(1)+m01(1)) IF (ndig<2) ndig = 2 IF (ndig>ndg2mx) ndig = ndg2mx DO 10 j = int(ma(1)) + 2, ndig + 1 ma(j) = 0 10 CONTINUE IF (ndig>4) CALL fmim(ival,m01) CALL fmmpy2(ma,m01,mb) GO TO 90 END IF mwa(1) = ma(1) + kshift ka = 2 + kshift kb = n1 + kshift kc = ndig + 5 DO 20 j = kb, kc mwa(j) = 0 20 CONTINUE mcarry = 0 ! This is the main multiplication loop. DO 30 j = kb, ka, -1 mkt = ma(j-kshift)*mval + mcarry mcarry = int(mkt/mbase) mwa(j) = mkt - mcarry*mbase 30 CONTINUE ! Resolve the final carry. DO 40 j = ka - 1, 2, -1 mkt = int(mcarry/mbase) mwa(j) = mcarry - mkt*mbase mcarry = mkt 40 CONTINUE ! Now the first significant digit in the product is in ! MWA(2) or MWA(3). ma(2) = ma2 mb(0) = ma(0) IF (mwa(2)==0) THEN mb(1) = mwa(1) - 1 DO 50 j = 3, kb mb(j-1) = mwa(j) 50 CONTINUE ELSE mb(1) = mwa(1) DO 60 j = 2, kb mb(j) = mwa(j) 60 CONTINUE END IF ! Put the sign on the result. 70 IF ((ival>0 .AND. ma2<0) .OR. (ival<0 .AND. ma2>0)) mb(2) = -mb(2) 80 IF (mb(1)>ndigmx) THEN IF (ncall==1 .OR. mb(1)>ndg2mx) THEN mb(0) = nint(ndg2mx*alogm2) mb(1) = mexpov IF (mb(2)>0) THEN mb(2) = 1 ELSE mb(2) = -1 END IF mb(3) = 0 kflag = -5 namest(ncall) = 'IMMPYI' IF (kovfl/=1) CALL fmwarn END IF END IF 90 IF (ntrace/=0) CALL imntr(1,mb,mb,1) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE immpyi SUBROUTINE immpym(ma,mb,mc,md) ! MD = MA * MB mod MC ! This routine is slightly faster than calling IMMPY and IMMOD ! separately, and it works for cases where IMMPY would return ! OVERFLOW. IMPLICIT NONE ! Scratch array usage during IMMPYM: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC abs, dble, dint, int, max, min, mod, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, maxmwa, mb2, mbm1, mc1, mc2, mc2p, mcarry, mdab, mdc, & mkt, mlmax, mqd REAL (KIND(0.0D0)) :: xb, xbase, xbr, xmwa INTEGER :: j, jb, jl, k, ka, kb, kl, kltflg, kptmwa, n1, na1, nc1, & ndsave, nguard, nl, nmcwds, ntrsav ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL fmwarn, imargs, imi2m, immod, immpy2, imntr, imntrj, imprnt, & imsub ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMMPYM',2,ma,mb) ndsave = ndig kflag = 0 IF (ntrace/=0) THEN namest(ncall) = 'IMMPYM' CALL imntr(2,ma,mb,2) IF (abs(ntrace)>=2 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN ndig = max(2,int(mc(1))) IF (ndig>ndg2mx) ndig = 2 IF (mc(1)<=1) mc(3) = 0 ntrsav = ntrace IF (ntrace<-2) ntrace = -2 CALL imntrj(mc,ndig) ntrace = ntrsav ndig = ndsave ELSE CALL imprnt(mc) END IF END IF END IF IF (ma(1)<=1) THEN IF (mb(1)>1) GO TO 10 IF (ma(1)<0 .OR. mb(1)<0) GO TO 10 mdab = ma(2)*mb(2) IF (mc(1)<=2) THEN IF (mc(2)==0) GO TO 10 IF (mc(1)<=1) THEN mdc = mc(2) ELSE IF (mc(2)<0) THEN mdc = mc(2)*mbase - mc(3) ELSE mdc = mc(2)*mbase + mc(3) END IF mdab = mod(mdab,mdc) END IF IF (abs(mdab)ndg2mx .OR. mb(1)>ndg2mx .OR. mc(1)>ndg2mx) THEN kflag = -4 namest(ncall) = 'IMMPYM' CALL fmwarn md(1) = munkno md(2) = 1 md(3) = 0 md(0) = nint(ndg2mx*alogm2) GO TO 270 END IF ndig = int(ma(1)+mb(1)) IF (ndig<2) ndig = 2 IF (ndig>lmwa) ndig = lmwa ! Save the sign of MA and MB and then work only with ! positive numbers. ma2 = ma(2) mb2 = mb(2) ma(2) = abs(ma(2)) mb(2) = abs(mb(2)) n1 = ndig + 1 ! It is faster if the second argument is the one ! with fewer digits. IF (ma(1)lmwa) kl = 2 DO 30 j = 0, kl + 1 m01(j) = mc(j) 30 CONTINUE m01(2) = abs(m01(2)) IF (mwa(1)==m01(1) .AND. abs(mwa(3))<=m01(2)) THEN DO 40 j = 4, n1 m02(j-1) = mwa(j) 40 CONTINUE m02(2) = abs(mwa(3)) m02(1) = mwa(1) IF (imcomp(m02,'EQ',m01)) THEN kltflg = 2 ELSE IF (imcomp(m02,'LT',m01)) THEN kltflg = 1 END IF END IF IF (mwa(1)=1) THEN IF (kltflg/=2) THEN DO 50 j = 3, n1 + 1 md(j-1) = mwa(j) 50 CONTINUE md(1) = mwa(1) md(0) = min(ma(0),mb(0),mc(0)) ELSE CALL imi2m(0,md) END IF GO TO 250 END IF ndig = int(mwa(1)) IF (ndig<2) ndig = 2 ! NGUARD is the number of guard digits used. nguard = 1 mc2p = abs(mc(2)) na1 = int(mwa(1)) + 1 nc1 = int(mc(1)) + 1 mwa(1) = mwa(1) - mc(1) + 1 nl = na1 + nguard + 3 DO 60 j = na1 + 2, nl mwa(j) = 0 60 CONTINUE ! Work only with positive numbers. mc1 = mc(1) mc2 = mc(2) mc(1) = 0 mc(2) = mc2p ! NMCWDS is the number of words of MC used to ! compute the estimated quotient digit MQD. nmcwds = 4 IF (mbase<100) nmcwds = 7 ! XB is an approximation of MC used in ! estimating the quotient digits. xbase = dble(mbase) xb = 0 jl = nmcwds IF (jl<=nc1) THEN DO 70 j = 2, jl xb = xb*xbase + dble(mc(j)) 70 CONTINUE ELSE DO 80 j = 2, jl IF (j<=nc1) THEN xb = xb*xbase + dble(mc(j)) ELSE xb = xb*xbase END IF 80 CONTINUE END IF IF (jl+1<=nc1) xb = xb + dble(mc(jl+1))/xbase xbr = 1.0D0/xb ! MLMAX determines when to normalize all of MWA. mbm1 = mbase - 1 mlmax = maxint/mbm1 mkt = intmax - mbase mlmax = min(mlmax,mkt) ! MAXMWA is an upper bound on the size of values in MWA ! divided by MBASE-1. It is used to determine whether ! normalization can be postponed. maxmwa = 0 ! KPTMWA points to the next digit in the quotient. kptmwa = 2 ! This is the start of the division loop. ! XMWA is an approximation of the active part of MWA ! used in estimating quotient digits. 90 kl = kptmwa + nmcwds - 1 IF (kl<=nl) THEN xmwa = ((dble(mwa(kptmwa))*xbase+dble(mwa(kptmwa+1)))*xbase+dble(mwa( & kptmwa+2)))*xbase + dble(mwa(kptmwa+3)) DO 100 j = kptmwa + 4, kl xmwa = xmwa*xbase + dble(mwa(j)) 100 CONTINUE ELSE xmwa = dble(mwa(kptmwa)) DO 110 j = kptmwa + 1, kl IF (j<=nl) THEN xmwa = xmwa*xbase + dble(mwa(j)) ELSE xmwa = xmwa*xbase END IF 110 CONTINUE END IF ! MQD is the estimated quotient digit. mqd = dint(xmwa*xbr) IF (mqd<0) mqd = mqd - 1 IF (mqd>0) THEN maxmwa = maxmwa + mqd ELSE maxmwa = maxmwa - mqd END IF ! See if MWA must be normalized. ka = kptmwa + 1 kb = ka + int(mc1) - 1 IF (maxmwa>=mlmax) THEN DO 120 j = kb, ka, -1 IF (mwa(j)<0) THEN mcarry = int((-mwa(j)-1)/mbase) + 1 mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry ELSE IF (mwa(j)>=mbase) THEN mcarry = -int(mwa(j)/mbase) mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry END IF 120 CONTINUE xmwa = 0 IF (kl<=nl) THEN DO 130 j = kptmwa, kl xmwa = xmwa*xbase + dble(mwa(j)) 130 CONTINUE ELSE DO 140 j = kptmwa, kl IF (j<=nl) THEN xmwa = xmwa*xbase + dble(mwa(j)) ELSE xmwa = xmwa*xbase END IF 140 CONTINUE END IF mqd = dint(xmwa*xbr) IF (mqd<0) mqd = mqd - 1 IF (mqd>0) THEN maxmwa = mqd ELSE maxmwa = -mqd END IF END IF ! Subtract MQD*MC from MWA. jb = ka - 2 IF (mqd/=0) THEN ! Major (Inner Loop) DO 150 j = ka, kb mwa(j) = mwa(j) - mqd*mc(j-jb) 150 CONTINUE END IF mwa(ka) = mwa(ka) + mwa(ka-1)*mbase mwa(kptmwa) = mqd kptmwa = kptmwa + 1 IF (kptmwa-2=mbase) THEN mcarry = -int(mwa(j)/mbase) mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry END IF 160 CONTINUE 170 DO 180 j = kptmwa + int(mc1), kptmwa + 2, -1 IF (mwa(j)<0) THEN mcarry = int((-mwa(j)-1)/mbase) + 1 mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry ELSE IF (mwa(j)>=mbase) THEN mcarry = -int(mwa(j)/mbase) mwa(j) = mwa(j) + mcarry*mbase mwa(j-1) = mwa(j-1) - mcarry END IF 180 CONTINUE ! Due to rounding, the remainder may not be between ! 0 and ABS(MC) here. Correct if necessary. IF (mwa(ka)<0) THEN DO 190 j = ka, kb mwa(j) = mwa(j) + mc(j-jb) 190 CONTINUE GO TO 170 ELSE IF (mwa(ka)>=mbase) THEN DO 200 j = ka, kb mwa(j) = mwa(j) - mc(j-jb) 200 CONTINUE GO TO 170 END IF ma(2) = ma2 mb(2) = mb2 mc(1) = mc1 mc(2) = mc2 IF (mwa(kptmwa+1)/=0) THEN DO 210 j = 1, int(mc1) md(j+1) = mwa(kptmwa+j) 210 CONTINUE md(1) = mc1 ELSE DO 230 j = 1, int(mc1) IF (mwa(kptmwa+j)/=0) THEN DO 220 k = j, int(mc1) md(k-j+2) = mwa(kptmwa+k) 220 CONTINUE md(1) = mc1 + 1 - j GO TO 240 END IF 230 CONTINUE md(1) = 0 md(2) = 0 END IF 240 IF (md(1)<=1) md(3) = 0 md(0) = min(ma(0),mb(0),mc(0)) IF (md(1)>m01(1) .OR. (md(1)==m01(1) .AND. abs(md(2))>=m01(2))) THEN IF (imcomp(md,'GE',m01)) CALL imsub(md,m01,md) END IF 250 IF (ma2*mb2<0 .AND. mc2>0) THEN IF (md(1)/=munkno) md(2) = -md(2) ELSE IF (ma2*mb2<0 .AND. mc2<0) THEN IF (md(1)/=munkno) md(2) = -md(2) END IF IF (ndig>ndigmx) ndig = 2 260 IF (md(1)==munkno) THEN kflag = -4 namest(ncall) = 'IMMPYM' CALL fmwarn END IF 270 IF (ntrace/=0) CALL imntr(1,md,md,1) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE immpym SUBROUTINE imntr(ntr,ma,mb,narg) ! Print IM numbers in base 10 format. ! This is used for trace output from the IM routines. ! NTR = 1 if a result of an IM call is to be printed. ! = 2 to print input argument(s) to an IM call. ! MA - the IM number to be printed. ! MB - an optional second IM number to be printed. ! NARG - the number of arguments. NARG = 1 if only MA is to be ! printed, and NARG = 2 if both MA and MB are to be printed. IMPLICIT NONE ! Scratch array usage during IMNTR: M01 - M02 ! .. Intrinsic Functions .. INTRINSIC abs, int, max ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: narg, ntr ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: ndsave, ntrsav CHARACTER (6) :: name ! .. ! .. External Subroutines .. EXTERNAL imntrj, imprnt ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (ntrace==0) RETURN IF (ncall>lvltrc) RETURN IF (ntr==2 .AND. abs(ntrace)==1) RETURN IF (ntr==2) THEN name = namest(ncall) WRITE (kw,90000) name ELSE name = namest(ncall) IF (kflag==0) THEN WRITE (kw,90010) name, ncall, int(mbase) ELSE WRITE (kw,90020) name, ncall, int(mbase), kflag END IF END IF ndsave = ndig IF (ntrace<0) THEN ndig = max(2,int(ma(1))) IF (ndig>ndg2mx) ndig = 2 IF (ma(1)<=1) ma(3) = 0 ntrsav = ntrace IF (ntrace<-2) ntrace = -2 CALL imntrj(ma,ndig) IF (narg==2) THEN ndig = max(2,int(mb(1))) IF (ndig>ndg2mx) ndig = 2 IF (mb(1)<=1) mb(3) = 0 CALL imntrj(mb,ndig) END IF ntrace = ntrsav END IF IF (ntrace>0) THEN CALL imprnt(ma) IF (narg==2) CALL imprnt(mb) END IF ndig = ndsave RETURN 90000 FORMAT (' Input to ',A6) 90010 FORMAT (' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10) 90020 FORMAT (' ',A6,6X,'Call level =',I2,4X,'MBASE =',I10,4X,'KFLAG =',I3) END SUBROUTINE imntr SUBROUTINE imntri(ntr,n,knam) ! Internal routine for trace output of integer variables. ! NTR = 1 for output values ! 2 for input values ! N Integer to be printed. ! KNAM is positive if the routine name is to be printed. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: knam, n, ntr ! .. ! .. Local Scalars .. CHARACTER (6) :: name ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (ntrace==0) RETURN IF (ncall>lvltrc) RETURN IF (ntr==2 .AND. abs(ntrace)==1) RETURN IF (ntr==2 .AND. knam>0) THEN name = namest(ncall) WRITE (kw,90000) name END IF IF (ntr==1 .AND. knam>0) THEN name = namest(ncall) IF (kflag==0) THEN WRITE (kw,90010) name, ncall, int(mbase) ELSE WRITE (kw,90020) name, ncall, int(mbase), kflag END IF END IF WRITE (kw,90030) n RETURN 90000 FORMAT (' Input to ',A6) 90010 FORMAT (' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10) 90020 FORMAT (' ',A6,6X,'Call level =',I2,4X,'MBASE =',I10,4X,'KFLAG =',I3) 90030 FORMAT (1X,I18) END SUBROUTINE imntri SUBROUTINE imntrj(ma,nd) ! Print trace output in internal base MBASE format. The number to ! be printed is in MA. ! ND is the number of base MBASE digits to be printed. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC dble, int, log10 ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: nd ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, l, n, n1 CHARACTER (50) :: form ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. n1 = nd + 1 l = int(log10(dble(mbase-1))) + 2 n = (kswide-23)/l IF (n>10) n = 5*(n/5) IF (nd<=n) THEN WRITE (form,90000) l + 2, n - 1, l ELSE WRITE (form,90010) l + 2, n - 1, l, n, l END IF WRITE (kw,form) (int(ma(j)),j=1,n1) RETURN 90000 FORMAT (' (1X,I19,I',I2,',',I3,'I',I2,') ') 90010 FORMAT (' (1X,I19,I',I2,',',I3,'I',I2,'/(22X,',I3,'I',I2,')) ') END SUBROUTINE imntrj SUBROUTINE imntrr(ntr,x,knam) ! Internal routine for trace output of real variables. ! NTR - 1 for output values ! 2 for input values ! X - Double precision value to be printed if NX.EQ.1 ! KNAM - Positive if the routine name is to be printed. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: x INTEGER :: knam, ntr ! .. ! .. Local Scalars .. CHARACTER (6) :: name ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (ntrace==0) RETURN IF (ncall>lvltrc) RETURN IF (ntr==2 .AND. abs(ntrace)==1) RETURN IF (ntr==2 .AND. knam>0) THEN name = namest(ncall) WRITE (kw,90000) name END IF IF (ntr==1 .AND. knam>0) THEN name = namest(ncall) IF (kflag==0) THEN WRITE (kw,90010) name, ncall, int(mbase) ELSE WRITE (kw,90020) name, ncall, int(mbase), kflag END IF END IF WRITE (kw,90030) x RETURN 90000 FORMAT (' Input to ',A6) 90010 FORMAT (' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10) 90020 FORMAT (' ',A6,6X,'Call level =',I2,4X,'MBASE =',I10,4X,'KFLAG =',I3) 90030 FORMAT (1X,D30.20) END SUBROUTINE imntrr SUBROUTINE imout(ma,line,lb) ! Convert an integer multiple precision number to a character array ! for output. ! MA is an IM number to be converted to an A1 character ! array in base 10 format ! LINE is the CHARACTER*1 array in which the result is returned. ! LB is the length of LINE. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int, max ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) CHARACTER (1) :: line(lb) ! .. ! .. Local Scalars .. INTEGER :: jf1sav, jf2sav, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmout, imargs ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMOUT ',1,ma,ma) kflag = 0 ndsave = ndig namest(ncall) = 'IMOUT ' ndsave = ndig jf1sav = jform1 jf2sav = jform2 jform1 = 2 jform2 = 0 ndig = max(2,int(ma(1))) IF (ndig>ndg2mx) ndig = 2 IF (ma(1)<=1) ma(3) = 0 CALL fmout(ma,line,lb) ndig = ndsave jform1 = jf1sav jform2 = jf2sav ncall = ncall - 1 RETURN END SUBROUTINE imout SUBROUTINE impack(ma,mp) ! MA is packed two base NDIG digits per word and returned in MP. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int, mod ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mp(0:lpack) ! .. ! .. Local Scalars .. INTEGER :: j, kma1, kp ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kma1 = int(ma(1)) IF (kma1<=2 .OR. kma1>ndg2mx) kma1 = 2 kp = 2 mp(0) = ma(0) mp(1) = ma(1) mp(2) = abs(ma(2))*mbase + ma(3) IF (ma(2)<0) mp(2) = -mp(2) IF (kma1>=4) THEN DO 10 j = 4, kma1, 2 kp = kp + 1 mp(kp) = ma(j)*mbase + ma(j+1) 10 CONTINUE END IF IF (mod(kma1,2)==1) mp(kp+1) = ma(kma1+1)*mbase RETURN END SUBROUTINE impack SUBROUTINE impmod(ma,mb,mc,md) ! MD = MOD(MA**MB,MC) ! The binary multiplication method used requires an average of ! 1.5 * LOG2(MB) operations. IMPLICIT NONE ! Scratch array usage during IMPMOD: M01 - M06 ! .. Intrinsic Functions .. INTRINSIC abs, int, max, min, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck), md(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: macca, maccb, mb2 INTEGER :: irem, kwrnsv, ndsave, ntrsav ! .. ! .. External Subroutines .. EXTERNAL fmwarn, imabs, imargs, imdivr, imdvir, imeq, imi2m, immod, & immpym, imntr, imntrj, imprnt ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMPMOD',2,ma,mb) IF (kdebug==1) CALL imargs('IMPMOD',1,mc,mc) ndsave = ndig IF (ntrace/=0) THEN namest(ncall) = 'IMPMOD' CALL imntr(2,ma,mb,2) IF (abs(ntrace)>=2 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN ndig = max(2,int(mc(1))) IF (ndig>ndg2mx) ndig = 2 IF (mc(1)<=1) mc(3) = 0 ntrsav = ntrace IF (ntrace<-2) ntrace = -2 CALL imntrj(mc,ndig) ntrace = ntrsav ndig = ndsave ELSE CALL imprnt(mc) END IF END IF END IF mb2 = mb(2) macca = ma(0) maccb = mb(0) ! Check for special cases. IF (ma(1)==munkno .OR. mb(1)==munkno .OR. mc(1)==munkno .OR. & ma(1)==mexpov .OR. mb(1)==mexpov .OR. mc(1)==mexpov .OR. & ma(1)<0 .OR. mb(1)<0 .OR. mc(1)<0 .OR. (mb(2)<=0 .AND. ma( & 2)==0) .OR. mc(2)==0) THEN kflag = -4 IF (ma(1)/=munkno .AND. mb(1)/=munkno .AND. mc(1)/=munkno) THEN namest(ncall) = 'IMPMOD' CALL fmwarn END IF md(0) = nint(ndg2mx*alogm2) md(1) = munkno md(2) = 1 md(3) = 0 IF (ntrace/=0) CALL imntr(1,md,md,1) ncall = ncall - 1 RETURN END IF IF (mb2==0) THEN CALL imi2m(1,md) IF (ntrace/=0) CALL imntr(1,md,md,1) ncall = ncall - 1 RETURN END IF IF (mb(1)==1 .AND. abs(mb2)==1) THEN kwrnsv = kwarn kwarn = 0 IF (mb2==1) THEN CALL immod(ma,mc,md) ELSE CALL imi2m(1,m05) CALL imdivr(m05,ma,m04,m06) CALL immod(m04,mc,md) END IF IF (ntrace/=0) CALL imntr(1,md,md,1) ncall = ncall - 1 kwarn = kwrnsv RETURN END IF IF (ma(2)==0) THEN CALL imi2m(0,md) IF (ntrace/=0) CALL imntr(1,md,md,1) ncall = ncall - 1 RETURN END IF ! Initialize. kwrnsv = kwarn kwarn = 0 CALL imabs(mb,m06) CALL imdivr(ma,mc,m04,m05) CALL imeq(mc,m04) CALL imdvir(m06,2,md,irem) IF (irem==0) THEN CALL imi2m(1,md) ELSE CALL imeq(m05,md) END IF CALL imdvir(m06,2,m06,irem) ! This is the multiplication loop. 10 CALL imdvir(m06,2,m06,irem) CALL immpym(m05,m05,m04,m05) IF (irem==1) CALL immpym(m05,md,m04,md) IF (m06(2)>0 .AND. md(2)/=0) GO TO 10 IF (mb2<0) THEN CALL imi2m(1,m05) CALL imdivr(m05,md,md,m06) END IF kwarn = kwrnsv md(0) = min(macca,maccb) IF (kflag<0) THEN namest(ncall) = 'IMPMOD' CALL fmwarn END IF IF (ntrace/=0) CALL imntr(1,md,md,1) ncall = ncall - 1 RETURN END SUBROUTINE impmod SUBROUTINE imprnt(ma) ! Print MA in base 10 format. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int, max ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: jf1sav, jf2sav, ndsave ! .. ! .. External Subroutines .. EXTERNAL 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 ! .. ! .. 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 ! .. ndsave = ndig jf1sav = jform1 jf2sav = jform2 jform1 = 2 jform2 = 0 ndig = max(2,int(ma(1))) IF (ma(1)<=1) ma(3) = 0 IF (ndig>ndg2mx) ndig = 2 CALL fmprnt(ma) jform1 = jf1sav jform2 = jf2sav ndig = ndsave RETURN END SUBROUTINE imprnt SUBROUTINE impwr(ma,mb,mc) ! MC = MA ** MB ! The binary multiplication method used requires an average of ! 1.5 * LOG2(MB) multiplications. IMPLICIT NONE ! Scratch array usage during IMPWR: M01 - M06 ! .. Intrinsic Functions .. INTRINSIC abs, min, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, macca, maccb, mb2 INTEGER :: irem, iremb, jsign, kwrnsv ! .. ! .. External Subroutines .. EXTERNAL fmwarn, imabs, imargs, imdivr, imdvir, imeq, imi2m, immpy, & imntr, imsqr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mesav(0:lunpck), mlbsav(0:lunpck), & mln1(0:lunpck), mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), & mpisav(0:lunpck), mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMPWR ',2,ma,mb) IF (ntrace/=0) THEN namest(ncall) = 'IMPWR ' CALL imntr(2,ma,mb,2) END IF ma2 = ma(2) mb2 = mb(2) macca = ma(0) maccb = mb(0) kwrnsv = kwarn ! Check for special cases. IF (ma(1)==munkno .OR. mb(1)==munkno .OR. ma(1)<0 .OR. mb(1)<0 .OR. (mb( & 2)<=0 .AND. ma(2)==0)) THEN kflag = -4 IF (ma(1)/=munkno .AND. mb(1)/=munkno) THEN kwarn = kwrnsv namest(ncall) = 'IMPWR ' CALL fmwarn END IF mc(0) = nint(ndg2mx*alogm2) mc(1) = munkno mc(2) = 1 mc(3) = 0 GO TO 30 END IF IF (mb2==0) THEN CALL imi2m(1,mc) GO TO 30 END IF IF (ma(1)==1 .AND. abs(ma2)==1) THEN kwarn = 0 IF (ma2==1) THEN CALL imi2m(1,mc) ELSE CALL imi2m(2,m05) CALL imdivr(mb,m05,m05,m06) IF (m06(1)==munkno) THEN mc(0) = nint(ndg2mx*alogm2) mc(1) = munkno mc(2) = 1 mc(3) = 0 kflag = -4 kwarn = kwrnsv namest(ncall) = 'IMPWR ' CALL fmwarn ELSE IF (m06(2)==0) THEN CALL imi2m(1,mc) ELSE CALL imi2m(-1,mc) END IF END IF GO TO 30 END IF IF (mb(1)==1 .AND. abs(mb2)==1) THEN kwarn = 0 IF (mb2==1) THEN CALL imeq(ma,mc) ELSE CALL imi2m(1,m05) CALL imdivr(m05,ma,mc,m06) END IF GO TO 30 END IF IF (ma(2)==0) THEN CALL imi2m(0,mc) GO TO 30 END IF IF (mb(1)==mexpov) THEN IF (mb2<0) THEN CALL imi2m(0,mc) ELSE IF (ma2>0) THEN mc(0) = nint(ndg2mx*alogm2) mc(1) = mexpov mc(2) = 1 mc(3) = 0 kflag = -5 ELSE mc(0) = nint(ndg2mx*alogm2) mc(1) = munkno mc(2) = 1 mc(3) = 0 kflag = -4 kwarn = kwrnsv namest(ncall) = 'IMPWR ' CALL fmwarn END IF GO TO 30 END IF IF (ma(1)==mexpov) THEN jsign = 1 IF (ma(2)<0) jsign = -1 IF (mb2>0) THEN CALL imdvir(mb,2,mc,irem) mc(0) = nint(ndg2mx*alogm2) mc(1) = mexpov mc(2) = jsign**irem mc(3) = 0 kflag = -5 ELSE CALL imi2m(0,mc) END IF GO TO 30 END IF ! Initialize. kwarn = 0 CALL imabs(mb,m06) CALL imeq(ma,m05) CALL imdvir(mb,2,mc,iremb) IF (iremb==0) THEN CALL imi2m(1,mc) ELSE CALL imeq(m05,mc) END IF CALL imdvir(m06,2,m06,irem) ! This is the multiplication loop. 10 CALL imdvir(m06,2,m06,irem) CALL imsqr(m05,m05) IF (irem==1) CALL immpy(m05,mc,mc) IF (m05(1)==mexpov) THEN CALL imeq(m05,mc) IF (ma2<0 .AND. iremb==1) mc(2) = -1 GO TO 20 END IF IF (m06(2)>0) GO TO 10 20 IF (mb2<0) THEN CALL imi2m(1,m05) CALL imdivr(m05,mc,mc,m06) END IF mc(0) = min(macca,maccb) IF (mc(1)>ndigmx) THEN IF (ncall==1 .OR. mc(1)>ndg2mx) THEN mc(0) = nint(ndg2mx*alogm2) mc(1) = mexpov IF (mc(2)>0) THEN mc(2) = 1 ELSE mc(2) = -1 END IF mc(3) = 0 kflag = -5 kwarn = kwrnsv namest(ncall) = 'IMPWR ' CALL fmwarn END IF END IF 30 kwarn = kwrnsv IF (ntrace/=0) THEN namest(ncall) = 'IMPWR ' CALL imntr(1,mc,mc,1) END IF ncall = ncall - 1 RETURN END SUBROUTINE impwr SUBROUTINE imread(kread,ma) ! Read MA on unit KREAD. Multi-line numbers will have '&' as the ! last nonblank character on all but the last line. Only one ! number is allowed on the line(s). IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kread ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwrnsv, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmnint, fmread ! .. ! .. 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 ! .. ncall = ncall + 1 ndsave = ndig ndig = ndigmx CALL fmread(kread,ma) kwrnsv = kwarn kwarn = 0 CALL fmnint(ma,ma) kwarn = kwrnsv ndig = ndsave ncall = ncall - 1 RETURN END SUBROUTINE imread SUBROUTINE imsign(ma,mb,mc) ! MC = SIGN(MA,MB) ! MC is set to ABS(MA) if MB is positive or zero, ! or -ABS(MA) if MB is negative. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: kwrnsv, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmwarn, imargs, imeq, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kflag = 0 ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMSIGN',2,ma,mb) ndsave = ndig IF (ntrace/=0) THEN namest(ncall) = 'IMSIGN' CALL imntr(2,ma,mb,2) END IF ndig = int(ma(1)) IF (ndig<2) ndig = 2 IF (ndig>ndg2mx) ndig = 2 IF (ma(1)<=1) ma(3) = 0 kwrnsv = kwarn kwarn = 0 IF (ma(1)==munkno .OR. mb(1)==munkno) THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 ELSE IF (ma(1)<0 .OR. mb(1)<0) THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 namest(ncall) = 'IMSIGN' CALL fmwarn ELSE IF (mb(2)>=0) THEN CALL imeq(ma,mc) mc(2) = abs(mc(2)) ELSE CALL imeq(ma,mc) mc(2) = -abs(mc(2)) END IF kwarn = kwrnsv IF (ntrace/=0) CALL imntr(1,mc,mc,1) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imsign SUBROUTINE imsqr(ma,mb) ! MB = MA * MA IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mdab INTEGER :: j, kovfl, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmsqr2, fmwarn, imargs, imi2m, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMSQR ',1,ma,ma) kflag = 0 ndsave = ndig IF (ntrace/=0) THEN namest(ncall) = 'IMSQR ' CALL imntr(2,ma,ma,1) END IF IF (ma(1)<=1) THEN IF (ma(1)<0) GO TO 10 mdab = ma(2)*ma(2) IF (abs(mdab)ndg2mx) ndig = ndg2mx IF (ma(1)==mexpov .OR. mb(1)==mexpov) ndig = 2 DO 20 j = int(ma(1)) + 2, ndig + 1 ma(j) = 0 20 CONTINUE CALL fmsqr2(ma,mb) IF (ndig>ndigmx) ndig = 2 30 IF (mb(1)>ndigmx) THEN IF (ncall==1 .OR. mb(1)>ndg2mx) THEN mb(0) = nint(ndg2mx*alogm2) mb(1) = mexpov IF (mb(2)>0) THEN mb(2) = 1 ELSE mb(2) = -1 END IF mb(3) = 0 kflag = -5 namest(ncall) = 'IMSQR ' IF (kovfl/=1) CALL fmwarn END IF END IF 40 IF (ntrace/=0) CALL imntr(1,mb,mb,1) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imsqr SUBROUTINE imst2m(string,ma) ! MA = STRING ! Convert a character string to IM format. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC len ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, lb ! .. ! .. External Subroutines .. EXTERNAL fmcons, iminp ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (mblogs/=mbase) CALL fmcons ncall = ncall + 1 namest(ncall) = 'IMST2M' lb = len(string) DO 10 j = 1, lb cmbuff(j) = string(j:j) 10 CONTINUE CALL iminp(cmbuff,ma,1,lb) ncall = ncall - 1 RETURN END SUBROUTINE imst2m SUBROUTINE imsub(ma,mb,mc) ! MC = MA - MB IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, min, nint, sign ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mb(0:lunpck), mc(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mda, mdab, mdb INTEGER :: j, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd2, fmwarn, imargs, imntr ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMSUB ',2,ma,mb) kflag = 0 ndsave = ndig IF (ntrace/=0) THEN namest(ncall) = 'IMSUB ' CALL imntr(2,ma,mb,2) END IF IF (ma(1)<=2) THEN IF (mb(1)>2 .OR. ma(1)<0 .OR. mb(1)<0) GO TO 10 IF (ma(1)<=1) THEN mda = ma(2) ELSE IF (ma(2)<0) THEN mda = ma(2)*mbase - ma(3) ELSE mda = ma(2)*mbase + ma(3) END IF IF (mb(1)<=1) THEN mdb = mb(2) ELSE IF (mb(2)<0) THEN mdb = mb(2)*mbase - mb(3) ELSE mdb = mb(2)*mbase + mb(3) END IF mdab = mda - mdb IF (abs(mdab)ndg2mx .OR. mb(1)>ndg2mx .OR. ma(1)<0 .OR. mb(1)<0) THEN IF (ma(1)==munkno .OR. mb(1)==munkno) THEN mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 GO TO 50 END IF IF (ma(1)==mexpov) THEN mda = 1 IF ((sign(mda,ma(2))==sign(mda,-mb(2))) .OR. (mb(2)==0)) THEN mc(0) = ma(0) mc(1) = ma(1) mc(2) = ma(2) mc(3) = ma(3) kflag = -5 GO TO 50 ELSE mc(0) = nint(ndg2mx*alogm2) mc(1) = munkno mc(2) = 1 mc(3) = 0 kflag = -4 namest(ncall) = 'IMSUB ' CALL fmwarn GO TO 50 END IF END IF IF (mb(1)==mexpov) THEN mda = 1 IF ((sign(mda,-mb(2))==sign(mda,ma(2))) .OR. (ma(2)==0)) THEN mc(0) = mb(0) mc(1) = mb(1) mc(2) = -mb(2) mc(3) = mb(3) kflag = -5 GO TO 50 ELSE mc(0) = nint(ndg2mx*alogm2) mc(1) = munkno mc(2) = 1 mc(3) = 0 kflag = -4 namest(ncall) = 'IMSUB ' CALL fmwarn GO TO 50 END IF END IF mc(1) = munkno mc(2) = 1 mc(3) = 0 mc(0) = nint(ndg2mx*alogm2) kflag = -4 namest(ncall) = 'IMSUB ' CALL fmwarn GO TO 50 END IF IF (ma(1)>mb(1)) THEN ndig = int(ma(1)) + 1 IF (ndig<2 .OR. ndig>ndg2mx) ndig = 2 ma(ndig+1) = 0 DO 20 j = int(mb(1)) + 2, ndig + 1 mb(j) = 0 20 CONTINUE ELSE ndig = int(mb(1)) + 1 IF (ndig<2 .OR. ndig>ndg2mx) ndig = 2 mb(ndig+1) = 0 DO 30 j = int(ma(1)) + 2, ndig + 1 ma(j) = 0 30 CONTINUE END IF ! FMADD2 will negate MB and add. ksub = 1 CALL fmadd2(ma,mb,mc) ksub = 0 40 IF (mc(1)>ndigmx) THEN IF (ncall==1 .OR. mc(1)>ndg2mx) THEN mc(0) = nint(ndg2mx*alogm2) mc(1) = mexpov IF (mc(2)>0) THEN mc(2) = 1 ELSE mc(2) = -1 END IF mc(3) = 0 kflag = -5 namest(ncall) = 'IMSUB ' CALL fmwarn END IF END IF 50 IF (ntrace/=0) CALL imntr(1,mc,mc,1) ncall = ncall - 1 ndig = ndsave RETURN END SUBROUTINE imsub SUBROUTINE imunpk(mp,ma) ! MP is unpacked and the value returned in MA. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dint, int, mod ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck), mp(0:lpack) ! .. ! .. Local Scalars .. INTEGER :: j, kma1, kp ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. kma1 = int(mp(1)) IF (kma1<=2 .OR. kma1>ndg2mx) kma1 = 2 kp = 2 ma(0) = mp(0) ma(1) = mp(1) ma(2) = dint(abs(mp(2))/mbase) ma(3) = abs(mp(2)) - ma(2)*mbase IF (mp(2)<0) ma(2) = -ma(2) IF (kma1>=4) THEN DO 10 j = 4, kma1, 2 kp = kp + 1 ma(j) = dint(mp(kp)/mbase) ma(j+1) = mp(kp) - ma(j)*mbase 10 CONTINUE END IF IF (mod(kma1,2)==1) ma(kma1+1) = dint(mp(kp+1)/mbase) RETURN END SUBROUTINE imunpk SUBROUTINE imwrit(kwrite,ma) ! Write MA on unit KWRITE. Multi-line numbers will have '&' as the ! last nonblank character on all but the last line. These numbers can ! then be read easily using IMREAD. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int, log10, max, min, mod, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kwrite ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpck) ! .. ! .. Local Scalars .. INTEGER :: j, k, ksave, l, last, lb, nd, ndsave, nexp ! .. ! .. External Subroutines .. EXTERNAL imargs, imout ! .. ! .. Scalars in Common .. REAL :: alogm2, alogmb, alogmt, alogmx, runkno, spmax REAL (KIND(0.0D0)) :: dlogeb, dlogmb, dlogpi, dlogtn, dlogtp, & dlogtw, dpeps, dpmax, dppi REAL (KIND(0.0D0)) :: maxint, mbase, mblogs, mbse, mbslb, mbsli, & mbspi, mexpab, mexpov, mexpun, munkno, mxbase, mxexp, mxexp2 INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ndige, ndiglb, ndigli, ndigpi, ngrd21, ngrd22, ngrd52, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mesav(0:lunpck), mlbsav(0:lunpck), mln1(0:lunpck), & mln2(0:lunpck), mln3(0:lunpck), mln4(0:lunpck), mpisav(0:lunpck), & mwa(lmwa) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmsave/ndigpi, ndige, ndiglb, ndigli, mbspi, mbse, mbslb, mbsli, & mpisav, mesav, mlbsav, mln1, mln2, mln3, mln4, mblogs, mexpab, alogmb, & alogm2, alogmx, alogmt, dlogmb, dlogtn, dlogtw, dlogtp, dlogpi, dppi, & dpeps, dlogeb, khasht, khashv, ngrd21, ngrd52, ngrd22 COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 IF (kdebug==1) CALL imargs('IMWRIT',1,ma,ma) namest(ncall) = 'IMWRIT' ndsave = ndig ndig = max(2,int(ma(1))) IF (ndig>ndg2mx) ndig = 2 ksave = kflag nd = int(real(ndig)*log10(real(mbase))) + 1 IF (nd<2) nd = 2 nexp = int(2.0*log10(real(mxbase))) + 6 lb = min(nd+nexp,lmbuff) CALL imout(ma,cmbuff,lb) kflag = ksave ndig = ndsave last = lb + 1 DO 10 j = 1, lb IF (cmbuff(last-j)/=' ' .OR. j==lb) THEN l = last - j IF (mod(l,73)/=0) THEN WRITE (kwrite,90000) (cmbuff(k),k=1,l) ELSE IF (l>73) WRITE (kwrite,90000) (cmbuff(k),k=1,l-73) WRITE (kwrite,90010) (cmbuff(k),k=l-72,l) END IF ncall = ncall - 1 RETURN END IF 10 CONTINUE ncall = ncall - 1 RETURN 90000 FORMAT (4X,73A1,' &') 90010 FORMAT (4X,73A1) END SUBROUTINE imwrit ! These versions of the IM routines use packed IM numbers. SUBROUTINE ipabs(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imabs, impack, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imabs(mx,my) CALL impack(my,mb) RETURN END SUBROUTINE ipabs SUBROUTINE ipadd(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imadd, impack, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imunpk(mb,my) CALL imadd(mx,my,mx) CALL impack(mx,mc) RETURN END SUBROUTINE ipadd SUBROUTINE ipbig(ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imbig, impack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imbig(my) CALL impack(my,ma) RETURN END SUBROUTINE ipbig FUNCTION ipcomp(ma,lrel,mb) IMPLICIT NONE ! .. Function Return Value .. LOGICAL :: ipcomp ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (2) :: lrel ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imunpk(mb,my) ipcomp = imcomp(mx,lrel,my) RETURN END FUNCTION ipcomp SUBROUTINE ipdim(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imdim, impack, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imunpk(mb,my) CALL imdim(mx,my,mx) CALL impack(mx,mc) RETURN END SUBROUTINE ipdim SUBROUTINE ipdiv(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imdiv, impack, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imunpk(mb,my) CALL imdiv(mx,my,mx) CALL impack(mx,mc) RETURN END SUBROUTINE ipdiv SUBROUTINE ipdivi(ma,ival,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imdivi, impack, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imdivi(mx,ival,mx) CALL impack(mx,mb) RETURN END SUBROUTINE ipdivi SUBROUTINE ipdivr(ma,mb,mc,md) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack), md(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imdivr, impack, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imunpk(mb,my) CALL imdivr(mx,my,mx,my) CALL impack(mx,mc) CALL impack(my,md) RETURN END SUBROUTINE ipdivr SUBROUTINE ipdvir(ma,ival,mb,irem) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: irem, ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imdvir, impack, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imdvir(mx,ival,mx,irem) CALL impack(mx,mb) RETURN END SUBROUTINE ipdvir SUBROUTINE ipeq(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imeq, impack, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imeq(mx,my) CALL impack(my,mb) RETURN END SUBROUTINE ipeq SUBROUTINE ipfm2i(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmunpk, imfm2i, impack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL fmunpk(ma,mx) CALL imfm2i(mx,mx) CALL impack(mx,mb) RETURN END SUBROUTINE ipfm2i SUBROUTINE ipform(form,ma,string) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: form, string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imform, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imform(form,mx,string) RETURN END SUBROUTINE ipform SUBROUTINE ipfprt(form,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: form ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imfprt, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imfprt(form,mx) RETURN END SUBROUTINE ipfprt SUBROUTINE ipgcd(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imgcd, impack, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imunpk(mb,my) CALL imgcd(mx,my,mx) CALL impack(mx,mc) RETURN END SUBROUTINE ipgcd SUBROUTINE ipi2fm(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, imi2fm, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imi2fm(mx,mx) CALL fmpack(mx,mb) RETURN END SUBROUTINE ipi2fm SUBROUTINE ipi2m(ival,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imi2m, impack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imi2m(ival,mx) CALL impack(mx,ma) RETURN END SUBROUTINE ipi2m SUBROUTINE ipinp(line,ma,la,lb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: la, lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) CHARACTER (1) :: line(lb) ! .. ! .. External Subroutines .. EXTERNAL iminp, impack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL iminp(line,mx,la,lb) CALL impack(mx,ma) RETURN END SUBROUTINE ipinp SUBROUTINE ipm2dp(ma,dval) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. REAL (KIND(0.0D0)) :: dval ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imm2dp, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imm2dp(mx,dval) RETURN END SUBROUTINE ipm2dp SUBROUTINE ipm2i(ma,ival) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imm2i, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imm2i(mx,ival) RETURN END SUBROUTINE ipm2i SUBROUTINE ipmax(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL immax, impack, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imunpk(mb,my) CALL immax(mx,my,mx) CALL impack(mx,mc) RETURN END SUBROUTINE ipmax SUBROUTINE ipmin(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL immin, impack, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imunpk(mb,my) CALL immin(mx,my,mx) CALL impack(mx,mc) RETURN END SUBROUTINE ipmin SUBROUTINE ipmod(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL immod, impack, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imunpk(mb,my) CALL immod(mx,my,mx) CALL impack(mx,mc) RETURN END SUBROUTINE ipmod SUBROUTINE ipmpy(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL immpy, impack, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imunpk(mb,my) CALL immpy(mx,my,mx) CALL impack(mx,mc) RETURN END SUBROUTINE ipmpy SUBROUTINE ipmpyi(ma,ival,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL immpyi, impack, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL immpyi(mx,ival,mx) CALL impack(mx,mb) RETURN END SUBROUTINE ipmpyi SUBROUTINE ipmpym(ma,mb,mc,md) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack), md(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL immpym, impack, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imunpk(mb,my) CALL imunpk(mc,mz) CALL immpym(mx,my,mz,mz) CALL impack(mz,md) RETURN END SUBROUTINE ipmpym SUBROUTINE ipout(ma,line,lb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) CHARACTER (1) :: line(lb) ! .. ! .. External Subroutines .. EXTERNAL imout, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imout(mx,line,lb) RETURN END SUBROUTINE ipout SUBROUTINE ippmod(ma,mb,mc,md) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack), md(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL impack, impmod, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imunpk(mb,my) CALL imunpk(mc,mz) CALL impmod(mx,my,mz,mx) CALL impack(mx,md) RETURN END SUBROUTINE ippmod SUBROUTINE ipprnt(ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imprnt, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imprnt(mx) RETURN END SUBROUTINE ipprnt SUBROUTINE ippwr(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL impack, impwr, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imunpk(mb,my) CALL impwr(mx,my,mx) CALL impack(mx,mc) RETURN END SUBROUTINE ippwr SUBROUTINE ipread(kread,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kread ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL impack, imread ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imread(kread,mx) CALL impack(mx,ma) RETURN END SUBROUTINE ipread SUBROUTINE ipsign(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL impack, imsign, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imunpk(mb,my) CALL imsign(mx,my,mx) CALL impack(mx,mc) RETURN END SUBROUTINE ipsign SUBROUTINE ipsqr(ma,mb) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL impack, imsqr, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imsqr(mx,my) CALL impack(my,mb) RETURN END SUBROUTINE ipsqr SUBROUTINE ipst2m(string,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. CHARACTER (*) :: string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL impack, imst2m ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imst2m(string,mx) CALL impack(mx,ma) RETURN END SUBROUTINE ipst2m SUBROUTINE ipsub(ma,mb,mc) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack), mb(0:lpack), mc(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL impack, imsub, imunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imunpk(mb,my) CALL imsub(mx,my,mx) CALL impack(mx,mc) RETURN END SUBROUTINE ipsub SUBROUTINE ipwrit(kwrite,ma) IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: lunpck = (6*ndigmx)/5 + 20 INTEGER, PARAMETER :: ljsums = 8*(lunpck+2) INTEGER, PARAMETER :: lmbuff = ((lunpck+3)*(nbits-1)*301)/2000 + 6 INTEGER, PARAMETER :: lmwa = 2*lunpck ! .. ! .. Scalar Arguments .. INTEGER :: kwrite ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL imunpk, imwrit ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpck), my(0:lunpck), mz(0:lunpck) ! .. ! .. Common Blocks .. COMMON /fmpck/mx, my, mz ! .. CALL imunpk(ma,mx) CALL imwrit(kwrite,mx) RETURN ! End of the FM package. END SUBROUTINE ipwrit SHAR_EOF fi # end of overwriting check if test -f 'fmzm90.f90' then echo shar: will not over-write existing file "'fmzm90.f90'" else cat << SHAR_EOF > 'fmzm90.f90' MODULE fmzm ! FMZM 1.1 David M. Smith 3-23-97 ! This module extends the definition of Fortran-90 arithmetic and ! function operations so they also apply to multiple precision ! numbers, using version 1.1 of FMLIB and ZMLIB. ! 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 FMSET or ZMSET) 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., .LE., ! +, -, *, /, and **, the interface module defines all mixed mode ! variations involving one of the three multiple precision derived ! types and another argument having one of the types: ! { integer, real, double, complex, complex double, FM, IM, ZM }. ! So mixed mode expressions such as ! MAFM = 12 ! MAFM = MAFM + 1 ! IF (ABS(MAFM).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 ! These abbreviations are used for operations ! on the various data types. ! I Integer ! R Real ! D Double Precision ! Z Complex ! C Complex Double Precision ! FM Multiple precision real ! IM Multiple precision integer ! ZM Multiple precision complex ! For example, the "=" procedure FMEQ_FMD is for statements like ! X = A, where X is type FM and A is type Double Precision. ! .. Use Statements .. USE fmzmcommon ! .. ! .. Generic Interface Blocks .. INTERFACE ASSIGNMENT (=) MODULE PROCEDURE fmeq_ifm MODULE PROCEDURE fmeq_iim MODULE PROCEDURE fmeq_izm MODULE PROCEDURE fmeq_rfm MODULE PROCEDURE fmeq_rim MODULE PROCEDURE fmeq_rzm MODULE PROCEDURE fmeq_dfm MODULE PROCEDURE fmeq_dim MODULE PROCEDURE fmeq_dzm MODULE PROCEDURE fmeq_zfm MODULE PROCEDURE fmeq_zim MODULE PROCEDURE fmeq_zzm MODULE PROCEDURE fmeq_cfm MODULE PROCEDURE fmeq_cim MODULE PROCEDURE fmeq_czm MODULE PROCEDURE fmeq_fmi MODULE PROCEDURE fmeq_fmr MODULE PROCEDURE fmeq_fmd MODULE PROCEDURE fmeq_fmz MODULE PROCEDURE fmeq_fmc MODULE PROCEDURE fmeq_fmfm MODULE PROCEDURE fmeq_fmim MODULE PROCEDURE fmeq_fmzm MODULE PROCEDURE fmeq_imi MODULE PROCEDURE fmeq_imr MODULE PROCEDURE fmeq_imd MODULE PROCEDURE fmeq_imz MODULE PROCEDURE fmeq_imc MODULE PROCEDURE fmeq_imfm MODULE PROCEDURE fmeq_imim MODULE PROCEDURE fmeq_imzm MODULE PROCEDURE fmeq_zmi MODULE PROCEDURE fmeq_zmr MODULE PROCEDURE fmeq_zmd MODULE PROCEDURE fmeq_zmz MODULE PROCEDURE fmeq_zmc MODULE PROCEDURE fmeq_zmfm MODULE PROCEDURE fmeq_zmim MODULE PROCEDURE fmeq_zmzm END INTERFACE INTERFACE OPERATOR (==) MODULE PROCEDURE fmleq_ifm MODULE PROCEDURE fmleq_iim MODULE PROCEDURE fmleq_izm MODULE PROCEDURE fmleq_rfm MODULE PROCEDURE fmleq_rim MODULE PROCEDURE fmleq_rzm MODULE PROCEDURE fmleq_dfm MODULE PROCEDURE fmleq_dim MODULE PROCEDURE fmleq_dzm MODULE PROCEDURE fmleq_zfm MODULE PROCEDURE fmleq_zim MODULE PROCEDURE fmleq_zzm MODULE PROCEDURE fmleq_cfm MODULE PROCEDURE fmleq_cim MODULE PROCEDURE fmleq_czm MODULE PROCEDURE fmleq_fmi MODULE PROCEDURE fmleq_fmr MODULE PROCEDURE fmleq_fmd MODULE PROCEDURE fmleq_fmz MODULE PROCEDURE fmleq_fmc MODULE PROCEDURE fmleq_fmfm MODULE PROCEDURE fmleq_fmim MODULE PROCEDURE fmleq_fmzm MODULE PROCEDURE fmleq_imi MODULE PROCEDURE fmleq_imr MODULE PROCEDURE fmleq_imd MODULE PROCEDURE fmleq_imz MODULE PROCEDURE fmleq_imc MODULE PROCEDURE fmleq_imfm MODULE PROCEDURE fmleq_imim MODULE PROCEDURE fmleq_imzm MODULE PROCEDURE fmleq_zmi MODULE PROCEDURE fmleq_zmr MODULE PROCEDURE fmleq_zmd MODULE PROCEDURE fmleq_zmz MODULE PROCEDURE fmleq_zmc MODULE PROCEDURE fmleq_zmfm MODULE PROCEDURE fmleq_zmim MODULE PROCEDURE fmleq_zmzm END INTERFACE INTERFACE OPERATOR (/=) MODULE PROCEDURE fmlne_ifm MODULE PROCEDURE fmlne_iim MODULE PROCEDURE fmlne_izm MODULE PROCEDURE fmlne_rfm MODULE PROCEDURE fmlne_rim MODULE PROCEDURE fmlne_rzm MODULE PROCEDURE fmlne_dfm MODULE PROCEDURE fmlne_dim MODULE PROCEDURE fmlne_dzm MODULE PROCEDURE fmlne_zfm MODULE PROCEDURE fmlne_zim MODULE PROCEDURE fmlne_zzm MODULE PROCEDURE fmlne_cfm MODULE PROCEDURE fmlne_cim MODULE PROCEDURE fmlne_czm MODULE PROCEDURE fmlne_fmi MODULE PROCEDURE fmlne_fmr MODULE PROCEDURE fmlne_fmd MODULE PROCEDURE fmlne_fmz MODULE PROCEDURE fmlne_fmc MODULE PROCEDURE fmlne_fmfm MODULE PROCEDURE fmlne_fmim MODULE PROCEDURE fmlne_fmzm MODULE PROCEDURE fmlne_imi MODULE PROCEDURE fmlne_imr MODULE PROCEDURE fmlne_imd MODULE PROCEDURE fmlne_imz MODULE PROCEDURE fmlne_imc MODULE PROCEDURE fmlne_imfm MODULE PROCEDURE fmlne_imim MODULE PROCEDURE fmlne_imzm MODULE PROCEDURE fmlne_zmi MODULE PROCEDURE fmlne_zmr MODULE PROCEDURE fmlne_zmd MODULE PROCEDURE fmlne_zmz MODULE PROCEDURE fmlne_zmc MODULE PROCEDURE fmlne_zmfm MODULE PROCEDURE fmlne_zmim MODULE PROCEDURE fmlne_zmzm END INTERFACE INTERFACE OPERATOR (>) MODULE PROCEDURE fmlgt_ifm MODULE PROCEDURE fmlgt_iim MODULE PROCEDURE fmlgt_rfm MODULE PROCEDURE fmlgt_rim MODULE PROCEDURE fmlgt_dfm MODULE PROCEDURE fmlgt_dim MODULE PROCEDURE fmlgt_fmi MODULE PROCEDURE fmlgt_fmr MODULE PROCEDURE fmlgt_fmd MODULE PROCEDURE fmlgt_fmfm MODULE PROCEDURE fmlgt_fmim MODULE PROCEDURE fmlgt_imi MODULE PROCEDURE fmlgt_imr MODULE PROCEDURE fmlgt_imd MODULE PROCEDURE fmlgt_imfm MODULE PROCEDURE fmlgt_imim END INTERFACE INTERFACE OPERATOR (>=) MODULE PROCEDURE fmlge_ifm MODULE PROCEDURE fmlge_iim MODULE PROCEDURE fmlge_rfm MODULE PROCEDURE fmlge_rim MODULE PROCEDURE fmlge_dfm MODULE PROCEDURE fmlge_dim MODULE PROCEDURE fmlge_fmi MODULE PROCEDURE fmlge_fmr MODULE PROCEDURE fmlge_fmd MODULE PROCEDURE fmlge_fmfm MODULE PROCEDURE fmlge_fmim MODULE PROCEDURE fmlge_imi MODULE PROCEDURE fmlge_imr MODULE PROCEDURE fmlge_imd MODULE PROCEDURE fmlge_imfm MODULE PROCEDURE fmlge_imim END INTERFACE INTERFACE OPERATOR (<) MODULE PROCEDURE fmllt_ifm MODULE PROCEDURE fmllt_iim MODULE PROCEDURE fmllt_rfm MODULE PROCEDURE fmllt_rim MODULE PROCEDURE fmllt_dfm MODULE PROCEDURE fmllt_dim MODULE PROCEDURE fmllt_fmi MODULE PROCEDURE fmllt_fmr MODULE PROCEDURE fmllt_fmd MODULE PROCEDURE fmllt_fmfm MODULE PROCEDURE fmllt_fmim MODULE PROCEDURE fmllt_imi MODULE PROCEDURE fmllt_imr MODULE PROCEDURE fmllt_imd MODULE PROCEDURE fmllt_imfm MODULE PROCEDURE fmllt_imim END INTERFACE INTERFACE OPERATOR (<=) MODULE PROCEDURE fmlle_ifm MODULE PROCEDURE fmlle_iim MODULE PROCEDURE fmlle_rfm MODULE PROCEDURE fmlle_rim MODULE PROCEDURE fmlle_dfm MODULE PROCEDURE fmlle_dim MODULE PROCEDURE fmlle_fmi MODULE PROCEDURE fmlle_fmr MODULE PROCEDURE fmlle_fmd MODULE PROCEDURE fmlle_fmfm MODULE PROCEDURE fmlle_fmim MODULE PROCEDURE fmlle_imi MODULE PROCEDURE fmlle_imr MODULE PROCEDURE fmlle_imd MODULE PROCEDURE fmlle_imfm MODULE PROCEDURE fmlle_imim END INTERFACE INTERFACE OPERATOR (+) MODULE PROCEDURE fmadd_ifm MODULE PROCEDURE fmadd_iim MODULE PROCEDURE fmadd_izm MODULE PROCEDURE fmadd_rfm MODULE PROCEDURE fmadd_rim MODULE PROCEDURE fmadd_rzm MODULE PROCEDURE fmadd_dfm MODULE PROCEDURE fmadd_dim MODULE PROCEDURE fmadd_dzm MODULE PROCEDURE fmadd_zfm MODULE PROCEDURE fmadd_zim MODULE PROCEDURE fmadd_zzm MODULE PROCEDURE fmadd_cfm MODULE PROCEDURE fmadd_cim MODULE PROCEDURE fmadd_czm MODULE PROCEDURE fmadd_fmi MODULE PROCEDURE fmadd_fmr MODULE PROCEDURE fmadd_fmd MODULE PROCEDURE fmadd_fmz MODULE PROCEDURE fmadd_fmc MODULE PROCEDURE fmadd_fmfm MODULE PROCEDURE fmadd_fmim MODULE PROCEDURE fmadd_fmzm MODULE PROCEDURE fmadd_imi MODULE PROCEDURE fmadd_imr MODULE PROCEDURE fmadd_imd MODULE PROCEDURE fmadd_imz MODULE PROCEDURE fmadd_imc MODULE PROCEDURE fmadd_imfm MODULE PROCEDURE fmadd_imim MODULE PROCEDURE fmadd_imzm MODULE PROCEDURE fmadd_zmi MODULE PROCEDURE fmadd_zmr MODULE PROCEDURE fmadd_zmd MODULE PROCEDURE fmadd_zmz MODULE PROCEDURE fmadd_zmc MODULE PROCEDURE fmadd_zmfm MODULE PROCEDURE fmadd_zmim MODULE PROCEDURE fmadd_zmzm MODULE PROCEDURE fmadd_fm MODULE PROCEDURE fmadd_im MODULE PROCEDURE fmadd_zm END INTERFACE INTERFACE OPERATOR (-) MODULE PROCEDURE fmsub_ifm MODULE PROCEDURE fmsub_iim MODULE PROCEDURE fmsub_izm MODULE PROCEDURE fmsub_rfm MODULE PROCEDURE fmsub_rim MODULE PROCEDURE fmsub_rzm MODULE PROCEDURE fmsub_dfm MODULE PROCEDURE fmsub_dim MODULE PROCEDURE fmsub_dzm MODULE PROCEDURE fmsub_zfm MODULE PROCEDURE fmsub_zim MODULE PROCEDURE fmsub_zzm MODULE PROCEDURE fmsub_cfm MODULE PROCEDURE fmsub_cim MODULE PROCEDURE fmsub_czm MODULE PROCEDURE fmsub_fmi MODULE PROCEDURE fmsub_fmr MODULE PROCEDURE fmsub_fmd MODULE PROCEDURE fmsub_fmz MODULE PROCEDURE fmsub_fmc MODULE PROCEDURE fmsub_fmfm MODULE PROCEDURE fmsub_fmim MODULE PROCEDURE fmsub_fmzm MODULE PROCEDURE fmsub_imi MODULE PROCEDURE fmsub_imr MODULE PROCEDURE fmsub_imd MODULE PROCEDURE fmsub_imz MODULE PROCEDURE fmsub_imc MODULE PROCEDURE fmsub_imfm MODULE PROCEDURE fmsub_imim MODULE PROCEDURE fmsub_imzm MODULE PROCEDURE fmsub_zmi MODULE PROCEDURE fmsub_zmr MODULE PROCEDURE fmsub_zmd MODULE PROCEDURE fmsub_zmz MODULE PROCEDURE fmsub_zmc MODULE PROCEDURE fmsub_zmfm MODULE PROCEDURE fmsub_zmim MODULE PROCEDURE fmsub_zmzm MODULE PROCEDURE fmsub_fm MODULE PROCEDURE fmsub_im MODULE PROCEDURE fmsub_zm END INTERFACE INTERFACE OPERATOR (*) MODULE PROCEDURE fmmpy_ifm MODULE PROCEDURE fmmpy_iim MODULE PROCEDURE fmmpy_izm MODULE PROCEDURE fmmpy_rfm MODULE PROCEDURE fmmpy_rim MODULE PROCEDURE fmmpy_rzm MODULE PROCEDURE fmmpy_dfm MODULE PROCEDURE fmmpy_dim MODULE PROCEDURE fmmpy_dzm MODULE PROCEDURE fmmpy_zfm MODULE PROCEDURE fmmpy_zim MODULE PROCEDURE fmmpy_zzm MODULE PROCEDURE fmmpy_cfm MODULE PROCEDURE fmmpy_cim MODULE PROCEDURE fmmpy_czm MODULE PROCEDURE fmmpy_fmi MODULE PROCEDURE fmmpy_fmr MODULE PROCEDURE fmmpy_fmd MODULE PROCEDURE fmmpy_fmz MODULE PROCEDURE fmmpy_fmc MODULE PROCEDURE fmmpy_fmfm MODULE PROCEDURE fmmpy_fmim MODULE PROCEDURE fmmpy_fmzm MODULE PROCEDURE fmmpy_imi MODULE PROCEDURE fmmpy_imr MODULE PROCEDURE fmmpy_imd MODULE PROCEDURE fmmpy_imz MODULE PROCEDURE fmmpy_imc MODULE PROCEDURE fmmpy_imfm MODULE PROCEDURE fmmpy_imim MODULE PROCEDURE fmmpy_imzm MODULE PROCEDURE fmmpy_zmi MODULE PROCEDURE fmmpy_zmr MODULE PROCEDURE fmmpy_zmd MODULE PROCEDURE fmmpy_zmz MODULE PROCEDURE fmmpy_zmc MODULE PROCEDURE fmmpy_zmfm MODULE PROCEDURE fmmpy_zmim MODULE PROCEDURE fmmpy_zmzm END INTERFACE INTERFACE OPERATOR (/) MODULE PROCEDURE fmdiv_ifm MODULE PROCEDURE fmdiv_iim MODULE PROCEDURE fmdiv_izm MODULE PROCEDURE fmdiv_rfm MODULE PROCEDURE fmdiv_rim MODULE PROCEDURE fmdiv_rzm MODULE PROCEDURE fmdiv_dfm MODULE PROCEDURE fmdiv_dim MODULE PROCEDURE fmdiv_dzm MODULE PROCEDURE fmdiv_zfm MODULE PROCEDURE fmdiv_zim MODULE PROCEDURE fmdiv_zzm MODULE PROCEDURE fmdiv_cfm MODULE PROCEDURE fmdiv_cim MODULE PROCEDURE fmdiv_czm MODULE PROCEDURE fmdiv_fmi MODULE PROCEDURE fmdiv_fmr MODULE PROCEDURE fmdiv_fmd MODULE PROCEDURE fmdiv_fmz MODULE PROCEDURE fmdiv_fmc MODULE PROCEDURE fmdiv_fmfm MODULE PROCEDURE fmdiv_fmim MODULE PROCEDURE fmdiv_fmzm MODULE PROCEDURE fmdiv_imi MODULE PROCEDURE fmdiv_imr MODULE PROCEDURE fmdiv_imd MODULE PROCEDURE fmdiv_imz MODULE PROCEDURE fmdiv_imc MODULE PROCEDURE fmdiv_imfm MODULE PROCEDURE fmdiv_imim MODULE PROCEDURE fmdiv_imzm MODULE PROCEDURE fmdiv_zmi MODULE PROCEDURE fmdiv_zmr MODULE PROCEDURE fmdiv_zmd MODULE PROCEDURE fmdiv_zmz MODULE PROCEDURE fmdiv_zmc MODULE PROCEDURE fmdiv_zmfm MODULE PROCEDURE fmdiv_zmim MODULE PROCEDURE fmdiv_zmzm END INTERFACE INTERFACE OPERATOR (**) MODULE PROCEDURE fmpwr_ifm MODULE PROCEDURE fmpwr_iim MODULE PROCEDURE fmpwr_izm MODULE PROCEDURE fmpwr_rfm MODULE PROCEDURE fmpwr_rim MODULE PROCEDURE fmpwr_rzm MODULE PROCEDURE fmpwr_dfm MODULE PROCEDURE fmpwr_dim MODULE PROCEDURE fmpwr_dzm MODULE PROCEDURE fmpwr_zfm MODULE PROCEDURE fmpwr_zim MODULE PROCEDURE fmpwr_zzm MODULE PROCEDURE fmpwr_cfm MODULE PROCEDURE fmpwr_cim MODULE PROCEDURE fmpwr_czm MODULE PROCEDURE fmpwr_fmi MODULE PROCEDURE fmpwr_fmr MODULE PROCEDURE fmpwr_fmd MODULE PROCEDURE fmpwr_fmz MODULE PROCEDURE fmpwr_fmc MODULE PROCEDURE fmpwr_fmfm MODULE PROCEDURE fmpwr_fmim MODULE PROCEDURE fmpwr_fmzm MODULE PROCEDURE fmpwr_imi MODULE PROCEDURE fmpwr_imr MODULE PROCEDURE fmpwr_imd MODULE PROCEDURE fmpwr_imz MODULE PROCEDURE fmpwr_imc MODULE PROCEDURE fmpwr_imfm MODULE PROCEDURE fmpwr_imim MODULE PROCEDURE fmpwr_imzm MODULE PROCEDURE fmpwr_zmi MODULE PROCEDURE fmpwr_zmr MODULE PROCEDURE fmpwr_zmd MODULE PROCEDURE fmpwr_zmz MODULE PROCEDURE fmpwr_zmc MODULE PROCEDURE fmpwr_zmfm MODULE PROCEDURE fmpwr_zmim MODULE PROCEDURE fmpwr_zmzm END INTERFACE INTERFACE abs MODULE PROCEDURE fmabs_fm MODULE PROCEDURE fmabs_im MODULE PROCEDURE fmabs_zm END INTERFACE INTERFACE acos MODULE PROCEDURE fmacos_fm MODULE PROCEDURE fmacos_zm END INTERFACE INTERFACE aimag MODULE PROCEDURE fmaimag_zm END INTERFACE INTERFACE aint MODULE PROCEDURE fmaint_fm MODULE PROCEDURE fmaint_zm END INTERFACE INTERFACE anint MODULE PROCEDURE fmanint_fm MODULE PROCEDURE fmanint_zm END INTERFACE INTERFACE asin MODULE PROCEDURE fmasin_fm MODULE PROCEDURE fmasin_zm END INTERFACE INTERFACE atan MODULE PROCEDURE fmatan_fm MODULE PROCEDURE fmatan_zm END INTERFACE INTERFACE atan2 MODULE PROCEDURE fmatan2_fm END INTERFACE INTERFACE btest MODULE PROCEDURE fmbtest_im END INTERFACE INTERFACE ceiling MODULE PROCEDURE fmceiling_fm MODULE PROCEDURE fmceiling_zm END INTERFACE INTERFACE cmplx MODULE PROCEDURE fmcmplx_fm MODULE PROCEDURE fmcmplx_im END INTERFACE INTERFACE conjg MODULE PROCEDURE fmconjg_zm END INTERFACE INTERFACE cos MODULE PROCEDURE fmcos_fm MODULE PROCEDURE fmcos_zm END INTERFACE INTERFACE cosh MODULE PROCEDURE fmcosh_fm MODULE PROCEDURE fmcosh_zm END INTERFACE INTERFACE dble MODULE PROCEDURE fmdble_fm MODULE PROCEDURE fmdble_im MODULE PROCEDURE fmdble_zm END INTERFACE INTERFACE digits MODULE PROCEDURE fmdigits_fm MODULE PROCEDURE fmdigits_im MODULE PROCEDURE fmdigits_zm END INTERFACE INTERFACE dim MODULE PROCEDURE fmdim_fm MODULE PROCEDURE fmdim_im END INTERFACE INTERFACE dint MODULE PROCEDURE fmdint_fm MODULE PROCEDURE fmdint_zm END INTERFACE INTERFACE dotproduct MODULE PROCEDURE fmdotproduct_fm MODULE PROCEDURE fmdotproduct_im MODULE PROCEDURE fmdotproduct_zm END INTERFACE INTERFACE epsilon MODULE PROCEDURE fmepsilon_fm END INTERFACE INTERFACE exp MODULE PROCEDURE fmexp_fm MODULE PROCEDURE fmexp_zm END INTERFACE INTERFACE exponent MODULE PROCEDURE fmexponent_fm END INTERFACE INTERFACE floor MODULE PROCEDURE fmfloor_fm MODULE PROCEDURE fmfloor_im MODULE PROCEDURE fmfloor_zm END INTERFACE INTERFACE fraction MODULE PROCEDURE fmfraction_fm MODULE PROCEDURE fmfraction_zm END INTERFACE INTERFACE huge MODULE PROCEDURE fmhuge_fm MODULE PROCEDURE fmhuge_im MODULE PROCEDURE fmhuge_zm END INTERFACE INTERFACE int MODULE PROCEDURE fmint_fm MODULE PROCEDURE fmint_im MODULE PROCEDURE fmint_zm END INTERFACE INTERFACE log MODULE PROCEDURE fmlog_fm MODULE PROCEDURE fmlog_zm END INTERFACE INTERFACE log10 MODULE PROCEDURE fmlog10_fm MODULE PROCEDURE fmlog10_zm END INTERFACE INTERFACE matmul MODULE PROCEDURE fmmatmul_fm MODULE PROCEDURE fmmatmul_im MODULE PROCEDURE fmmatmul_zm END INTERFACE INTERFACE max MODULE PROCEDURE fmmax_fm MODULE PROCEDURE fmmax_im END INTERFACE INTERFACE maxexponent MODULE PROCEDURE fmmaxexponent_fm END INTERFACE INTERFACE min MODULE PROCEDURE fmmin_fm MODULE PROCEDURE fmmin_im END INTERFACE INTERFACE minexponent MODULE PROCEDURE fmminexponent_fm END INTERFACE INTERFACE mod MODULE PROCEDURE fmmod_fm MODULE PROCEDURE fmmod_im END INTERFACE INTERFACE modulo MODULE PROCEDURE fmmodulo_fm MODULE PROCEDURE fmmodulo_im END INTERFACE INTERFACE nearest MODULE PROCEDURE fmnearest_fm END INTERFACE INTERFACE nint MODULE PROCEDURE fmnint_fm MODULE PROCEDURE fmnint_im MODULE PROCEDURE fmnint_zm END INTERFACE INTERFACE precision MODULE PROCEDURE fmprecision_fm MODULE PROCEDURE fmprecision_zm END INTERFACE INTERFACE radix MODULE PROCEDURE fmradix_fm MODULE PROCEDURE fmradix_im MODULE PROCEDURE fmradix_zm END INTERFACE INTERFACE range MODULE PROCEDURE fmrange_fm MODULE PROCEDURE fmrange_im MODULE PROCEDURE fmrange_zm END INTERFACE INTERFACE real MODULE PROCEDURE fmreal_fm MODULE PROCEDURE fmreal_im MODULE PROCEDURE fmreal_zm END INTERFACE INTERFACE rrspacing MODULE PROCEDURE fmrrspacing_fm END INTERFACE INTERFACE scale MODULE PROCEDURE fmscale_fm MODULE PROCEDURE fmscale_zm END INTERFACE INTERFACE setexponent MODULE PROCEDURE fmsetexponent_fm END INTERFACE INTERFACE sign MODULE PROCEDURE fmsign_fm MODULE PROCEDURE fmsign_im END INTERFACE INTERFACE sin MODULE PROCEDURE fmsin_fm MODULE PROCEDURE fmsin_zm END INTERFACE INTERFACE sinh MODULE PROCEDURE fmsinh_fm MODULE PROCEDURE fmsinh_zm END INTERFACE INTERFACE spacing MODULE PROCEDURE fmspacing_fm END INTERFACE INTERFACE sqrt MODULE PROCEDURE fmsqrt_fm MODULE PROCEDURE fmsqrt_zm END INTERFACE INTERFACE tan MODULE PROCEDURE fmtan_fm MODULE PROCEDURE fmtan_zm END INTERFACE INTERFACE tanh MODULE PROCEDURE fmtanh_fm MODULE PROCEDURE fmtanh_zm END INTERFACE INTERFACE tiny MODULE PROCEDURE fmtiny_fm MODULE PROCEDURE fmtiny_im MODULE PROCEDURE fmtiny_zm END INTERFACE INTERFACE to_fm MODULE PROCEDURE fm_i MODULE PROCEDURE fm_r MODULE PROCEDURE fm_d MODULE PROCEDURE fm_z MODULE PROCEDURE fm_c MODULE PROCEDURE fm_fm MODULE PROCEDURE fm_im MODULE PROCEDURE fm_zm MODULE PROCEDURE fm_st END INTERFACE INTERFACE to_im MODULE PROCEDURE im_i MODULE PROCEDURE im_r MODULE PROCEDURE im_d MODULE PROCEDURE im_z MODULE PROCEDURE im_c MODULE PROCEDURE im_fm MODULE PROCEDURE im_im MODULE PROCEDURE im_zm MODULE PROCEDURE im_st END INTERFACE INTERFACE to_zm MODULE PROCEDURE zm_i MODULE PROCEDURE zm_r MODULE PROCEDURE zm_d MODULE PROCEDURE zm_z MODULE PROCEDURE zm_c MODULE PROCEDURE zm_fm MODULE PROCEDURE zm_im MODULE PROCEDURE zm_zm MODULE PROCEDURE zm_st END INTERFACE INTERFACE to_int MODULE PROCEDURE fm_2int MODULE PROCEDURE im_2int MODULE PROCEDURE zm_2int END INTERFACE INTERFACE to_sp MODULE PROCEDURE fm_2sp MODULE PROCEDURE im_2sp MODULE PROCEDURE zm_2sp END INTERFACE INTERFACE to_dp MODULE PROCEDURE fm_2dp MODULE PROCEDURE im_2dp MODULE PROCEDURE zm_2dp END INTERFACE INTERFACE to_spz MODULE PROCEDURE fm_2spz MODULE PROCEDURE im_2spz MODULE PROCEDURE zm_2spz END INTERFACE INTERFACE to_dpz MODULE PROCEDURE fm_2dpz MODULE PROCEDURE im_2dpz MODULE PROCEDURE zm_2dpz END INTERFACE ! .. ! .. Derived Type Declarations .. TYPE :: fm SEQUENCE REAL (kind(0.0D0)) :: mfm(0:lunpck) END TYPE fm TYPE :: im SEQUENCE REAL (kind(0.0D0)) :: mim(0:lunpck) END TYPE im TYPE :: zm SEQUENCE REAL (kind(0.0D0)) :: mzm(0:lunpkz) END TYPE zm ! .. ! .. Local Structures .. TYPE (fm), PRIVATE :: mtfm, mufm TYPE (im), PRIVATE :: mtim, muim TYPE (zm), PRIVATE :: mtzm, muzm ! .. CONTAINS ! = SUBROUTINE fmeq_ifm(ival,ma) ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (INOUT) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmm2i ! .. CALL fmm2i(ma%mfm,ival) END SUBROUTINE fmeq_ifm SUBROUTINE fmeq_iim(ival,ma) ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (INOUT) :: ival ! .. ! .. External Subroutines .. EXTERNAL imm2i ! .. CALL imm2i(ma%mim,ival) END SUBROUTINE fmeq_iim SUBROUTINE fmeq_izm(ival,ma) ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (INOUT) :: ival ! .. ! .. External Subroutines .. EXTERNAL zmm2i ! .. CALL zmm2i(ma%mzm,ival) END SUBROUTINE fmeq_izm SUBROUTINE fmeq_rfm(r,ma) ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (INOUT) :: r ! .. ! .. External Subroutines .. EXTERNAL fmm2sp ! .. CALL fmm2sp(ma%mfm,r) END SUBROUTINE fmeq_rfm SUBROUTINE fmeq_rim(r,ma) ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (INOUT) :: r ! .. ! .. External Subroutines .. EXTERNAL fmm2sp, imi2fm ! .. CALL imi2fm(ma%mim,mtfm%mfm) CALL fmm2sp(mtfm%mfm,r) END SUBROUTINE fmeq_rim SUBROUTINE fmeq_rzm(r,ma) ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (INOUT) :: r ! .. ! .. External Subroutines .. EXTERNAL fmm2sp, zmreal ! .. CALL zmreal(ma%mzm,mtfm%mfm) CALL fmm2sp(mtfm%mfm,r) END SUBROUTINE fmeq_rzm SUBROUTINE fmeq_dfm(d,ma) ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (INOUT) :: d ! .. ! .. External Subroutines .. EXTERNAL fmm2dp ! .. CALL fmm2dp(ma%mfm,d) END SUBROUTINE fmeq_dfm SUBROUTINE fmeq_dim(d,ma) ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (INOUT) :: d ! .. ! .. External Subroutines .. EXTERNAL imm2dp ! .. CALL imm2dp(ma%mim,d) END SUBROUTINE fmeq_dim SUBROUTINE fmeq_dzm(d,ma) ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (INOUT) :: d ! .. ! .. External Subroutines .. EXTERNAL fmm2dp, zmreal ! .. CALL zmreal(ma%mzm,mtfm%mfm) CALL fmm2dp(mtfm%mfm,d) END SUBROUTINE fmeq_dzm SUBROUTINE fmeq_zfm(z,ma) ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (INOUT) :: z ! .. ! .. Local Scalars .. REAL :: r ! .. ! .. External Subroutines .. EXTERNAL fmm2sp ! .. CALL fmm2sp(ma%mfm,r) z = cmplx(r,0.0) END SUBROUTINE fmeq_zfm SUBROUTINE fmeq_zim(z,ma) ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (INOUT) :: z ! .. ! .. Local Scalars .. REAL (kind(0.0D0)) :: d ! .. ! .. External Subroutines .. EXTERNAL imm2dp ! .. CALL imm2dp(ma%mim,d) z = cmplx(real(d),0.0) END SUBROUTINE fmeq_zim SUBROUTINE fmeq_zzm(z,ma) ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (INOUT) :: z ! .. ! .. External Subroutines .. EXTERNAL zmm2z ! .. CALL zmm2z(ma%mzm,z) END SUBROUTINE fmeq_zzm SUBROUTINE fmeq_cfm(c,ma) ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (INOUT) :: c ! .. ! .. Local Scalars .. REAL (kind(0.0D0)) :: d ! .. ! .. External Subroutines .. EXTERNAL fmm2dp ! .. CALL fmm2dp(ma%mfm,d) c = cmplx(d,0.0D0,kind(0.0D0)) END SUBROUTINE fmeq_cfm SUBROUTINE fmeq_cim(c,ma) ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (INOUT) :: c ! .. ! .. Local Scalars .. REAL (kind(0.0D0)) :: d ! .. ! .. External Subroutines .. EXTERNAL imm2dp ! .. CALL imm2dp(ma%mim,d) c = cmplx(d,0.0D0,kind(0.0D0)) END SUBROUTINE fmeq_cim SUBROUTINE fmeq_czm(c,ma) ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (INOUT) :: c ! .. ! .. Local Scalars .. REAL (kind(0.0D0)) :: d1, d2 ! .. ! .. External Subroutines .. EXTERNAL fmm2dp, zmimag, zmreal ! .. CALL zmreal(ma%mzm,mtfm%mfm) CALL fmm2dp(mtfm%mfm,d1) CALL zmimag(ma%mzm,mtfm%mfm) CALL fmm2dp(mtfm%mfm,d2) c = cmplx(d1,d2,kind(0.0D0)) END SUBROUTINE fmeq_czm SUBROUTINE fmeq_fmi(ma,ival) ! .. Structure Arguments .. TYPE (fm), INTENT (INOUT) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmi2m ! .. CALL fmi2m(ival,ma%mfm) END SUBROUTINE fmeq_fmi SUBROUTINE fmeq_fmr(ma,r) ! .. Structure Arguments .. TYPE (fm), INTENT (INOUT) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(r,ma%mfm) END SUBROUTINE fmeq_fmr SUBROUTINE fmeq_fmd(ma,d) ! .. Structure Arguments .. TYPE (fm), INTENT (INOUT) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(d,ma%mfm) END SUBROUTINE fmeq_fmd SUBROUTINE fmeq_fmz(ma,z) ! .. Structure Arguments .. TYPE (fm), INTENT (INOUT) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. Local Scalars .. REAL :: r ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. r = real(z) CALL fmsp2m(r,ma%mfm) END SUBROUTINE fmeq_fmz SUBROUTINE fmeq_fmc(ma,c) ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (INOUT) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. Local Scalars .. REAL (kind(0.0D0)) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. d = real(c,kind(0.0D0)) CALL fmdp2m(d,ma%mfm) END SUBROUTINE fmeq_fmc SUBROUTINE fmeq_fmfm(ma,mb) ! .. Structure Arguments .. TYPE (fm), INTENT (INOUT) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmeq ! .. CALL fmeq(mb%mfm,ma%mfm) END SUBROUTINE fmeq_fmfm SUBROUTINE fmeq_fmim(ma,mb) ! .. Structure Arguments .. TYPE (fm), INTENT (INOUT) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL imi2fm ! .. CALL imi2fm(mb%mim,ma%mfm) END SUBROUTINE fmeq_fmim SUBROUTINE fmeq_fmzm(ma,mb) ! .. Structure Arguments .. TYPE (fm), INTENT (INOUT) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL zmreal ! .. CALL zmreal(mb%mzm,ma%mfm) END SUBROUTINE fmeq_fmzm SUBROUTINE fmeq_imi(ma,ival) ! .. Structure Arguments .. TYPE (im), INTENT (INOUT) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL imi2m ! .. CALL imi2m(ival,ma%mim) END SUBROUTINE fmeq_imi SUBROUTINE fmeq_imr(ma,r) ! .. Structure Arguments .. TYPE (im), INTENT (INOUT) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. INTEGER :: ival ! .. ! .. External Subroutines .. EXTERNAL imi2m ! .. ival = int(r) CALL imi2m(ival,ma%mim) END SUBROUTINE fmeq_imr SUBROUTINE fmeq_imd(ma,d) ! .. Structure Arguments .. TYPE (im), INTENT (INOUT) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. INTEGER :: ival ! .. ! .. External Subroutines .. EXTERNAL imi2m ! .. ival = int(d) CALL imi2m(ival,ma%mim) END SUBROUTINE fmeq_imd SUBROUTINE fmeq_imz(ma,z) ! .. Structure Arguments .. TYPE (im), INTENT (INOUT) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imfm2i ! .. CALL fmsp2m(real(z),mtfm%mfm) CALL imfm2i(mtfm%mfm,ma%mim) END SUBROUTINE fmeq_imz SUBROUTINE fmeq_imc(ma,c) ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (INOUT) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imfm2i ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL imfm2i(mtfm%mfm,ma%mim) END SUBROUTINE fmeq_imc SUBROUTINE fmeq_imfm(ma,mb) ! .. Structure Arguments .. TYPE (im), INTENT (INOUT) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL imfm2i ! .. CALL imfm2i(mb%mfm,ma%mim) END SUBROUTINE fmeq_imfm SUBROUTINE fmeq_imim(ma,mb) ! .. Structure Arguments .. TYPE (im), INTENT (INOUT) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL imeq ! .. CALL imeq(mb%mim,ma%mim) END SUBROUTINE fmeq_imim SUBROUTINE fmeq_imzm(ma,mb) ! .. Structure Arguments .. TYPE (im), INTENT (INOUT) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL imfm2i, zmreal ! .. CALL zmreal(mb%mzm,mtfm%mfm) CALL imfm2i(mtfm%mfm,ma%mim) END SUBROUTINE fmeq_imzm SUBROUTINE fmeq_zmi(ma,ival) ! .. Structure Arguments .. TYPE (zm), INTENT (INOUT) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL zmi2m ! .. CALL zmi2m(ival,ma%mzm) END SUBROUTINE fmeq_zmi SUBROUTINE fmeq_zmr(ma,r) ! .. Structure Arguments .. TYPE (zm), INTENT (INOUT) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. COMPLEX :: z ! .. ! .. External Subroutines .. EXTERNAL zmz2m ! .. z = cmplx(r,0.0) CALL zmz2m(z,ma%mzm) END SUBROUTINE fmeq_zmr SUBROUTINE fmeq_zmd(ma,d) ! .. Structure Arguments .. TYPE (zm), INTENT (INOUT) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmcmpx ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmdp2m(0.0D0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,ma%mzm) END SUBROUTINE fmeq_zmd SUBROUTINE fmeq_zmz(ma,z) ! .. Structure Arguments .. TYPE (zm), INTENT (INOUT) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL zmz2m ! .. CALL zmz2m(z,ma%mzm) END SUBROUTINE fmeq_zmz SUBROUTINE fmeq_zmc(ma,c) ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (INOUT) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. Local Scalars .. REAL (kind(0.0D0)) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmcmpx ! .. d = real(c,kind(0.0D0)) CALL fmdp2m(d,mtfm%mfm) d = aimag(c) CALL fmdp2m(d,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,ma%mzm) END SUBROUTINE fmeq_zmc SUBROUTINE fmeq_zmfm(ma,mb) ! .. Structure Arguments .. TYPE (zm), INTENT (INOUT) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx ! .. CALL fmi2m(0,mtfm%mfm) CALL zmcmpx(mb%mfm,mtfm%mfm,ma%mzm) END SUBROUTINE fmeq_zmfm SUBROUTINE fmeq_zmim(ma,mb) ! .. Structure Arguments .. TYPE (zm), INTENT (INOUT) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx ! .. CALL imi2fm(mb%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,ma%mzm) END SUBROUTINE fmeq_zmim SUBROUTINE fmeq_zmzm(ma,mb) ! .. Structure Arguments .. TYPE (zm), INTENT (INOUT) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL zmeq ! .. CALL zmeq(mb%mzm,ma%mzm) END SUBROUTINE fmeq_zmzm ! Reference: The 39 Steps, John Buchan, 1915, Curtis Publishers. ! .EQ. FUNCTION fmleq_ifm(ival,ma) ! .. Function Return Value .. LOGICAL :: fmleq_ifm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m ! .. CALL fmi2m(ival,mtfm%mfm) fmleq_ifm = fmcomp(mtfm%mfm,'EQ',ma%mfm) END FUNCTION fmleq_ifm FUNCTION fmleq_iim(ival,ma) ! .. Function Return Value .. LOGICAL :: fmleq_iim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL imi2m ! .. CALL imi2m(ival,mtim%mim) fmleq_iim = imcomp(mtim%mim,'EQ',ma%mim) END FUNCTION fmleq_iim FUNCTION fmleq_izm(ival,ma) ! .. Function Return Value .. LOGICAL :: fmleq_izm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmimag, zmreal ! .. CALL fmi2m(ival,mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) CALL fmi2m(0,mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) fmleq_izm = l1 .AND. l2 END FUNCTION fmleq_izm FUNCTION fmleq_rfm(r,ma) ! .. Function Return Value .. LOGICAL :: fmleq_rfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) fmleq_rfm = fmcomp(mtfm%mfm,'EQ',ma%mfm) END FUNCTION fmleq_rfm FUNCTION fmleq_rim(r,ma) ! .. Function Return Value .. LOGICAL :: fmleq_rim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmleq_rim = fmcomp(mtfm%mfm,'EQ',mufm%mfm) ndig = ndsave END FUNCTION fmleq_rim FUNCTION fmleq_rzm(r,ma) ! .. Function Return Value .. LOGICAL :: fmleq_rzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsp2m, zmimag, zmreal ! .. CALL fmsp2m(r,mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) CALL fmi2m(0,mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) fmleq_rzm = l1 .AND. l2 END FUNCTION fmleq_rzm FUNCTION fmleq_dfm(d,ma) ! .. Function Return Value .. LOGICAL :: fmleq_dfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) fmleq_dfm = fmcomp(mtfm%mfm,'EQ',ma%mfm) END FUNCTION fmleq_dfm FUNCTION fmleq_dim(d,ma) ! .. Function Return Value .. LOGICAL :: fmleq_dim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmleq_dim = fmcomp(mtfm%mfm,'EQ',mufm%mfm) ndig = ndsave END FUNCTION fmleq_dim FUNCTION fmleq_dzm(d,ma) ! .. Function Return Value .. LOGICAL :: fmleq_dzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmimag, zmreal ! .. CALL fmdp2m(d,mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) CALL fmi2m(0,mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) fmleq_dzm = l1 .AND. l2 END FUNCTION fmleq_dzm FUNCTION fmleq_zfm(z,ma) ! .. Function Return Value .. LOGICAL :: fmleq_zfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(real(z),mtfm%mfm) l1 = fmcomp(mtfm%mfm,'EQ',ma%mfm) l2 = .TRUE. IF (aimag(z)/=0.0) l2 = .FALSE. fmleq_zfm = l1 .AND. l2 END FUNCTION fmleq_zfm FUNCTION fmleq_zim(z,ma) ! .. Function Return Value .. LOGICAL :: fmleq_zim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(real(z),mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) l1 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) ndig = ndsave l2 = .TRUE. IF (aimag(z)/=0.0) l2 = .FALSE. fmleq_zim = l1 .AND. l2 END FUNCTION fmleq_zim FUNCTION fmleq_zzm(z,ma) ! .. Function Return Value .. LOGICAL :: fmleq_zzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, zmimag, zmreal ! .. CALL fmsp2m(real(z),mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) CALL fmsp2m(aimag(z),mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) fmleq_zzm = l1 .AND. l2 END FUNCTION fmleq_zzm FUNCTION fmleq_cfm(c,ma) ! .. Function Return Value .. LOGICAL :: fmleq_cfm ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) l1 = fmcomp(mtfm%mfm,'EQ',ma%mfm) l2 = .TRUE. IF (aimag(c)/=0.0) l2 = .FALSE. fmleq_cfm = l1 .AND. l2 END FUNCTION fmleq_cfm FUNCTION fmleq_cim(c,ma) ! .. Function Return Value .. LOGICAL :: fmleq_cim ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) l1 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) ndig = ndsave l2 = .TRUE. IF (aimag(c)/=0.0) l2 = .FALSE. fmleq_cim = l1 .AND. l2 END FUNCTION fmleq_cim FUNCTION fmleq_czm(c,ma) ! .. Function Return Value .. LOGICAL :: fmleq_czm ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmimag, zmreal ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) CALL fmdp2m(aimag(c),mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) fmleq_czm = l1 .AND. l2 END FUNCTION fmleq_czm FUNCTION fmleq_fmi(ma,ival) ! .. Function Return Value .. LOGICAL :: fmleq_fmi ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m ! .. CALL fmi2m(ival,mtfm%mfm) fmleq_fmi = fmcomp(ma%mfm,'EQ',mtfm%mfm) END FUNCTION fmleq_fmi FUNCTION fmleq_fmr(ma,r) ! .. Function Return Value .. LOGICAL :: fmleq_fmr ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) fmleq_fmr = fmcomp(ma%mfm,'EQ',mtfm%mfm) END FUNCTION fmleq_fmr FUNCTION fmleq_fmd(ma,d) ! .. Function Return Value .. LOGICAL :: fmleq_fmd ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) fmleq_fmd = fmcomp(ma%mfm,'EQ',mtfm%mfm) END FUNCTION fmleq_fmd FUNCTION fmleq_fmz(ma,z) ! .. Function Return Value .. LOGICAL :: fmleq_fmz ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(real(z),mtfm%mfm) l1 = fmcomp(ma%mfm,'EQ',mtfm%mfm) l2 = .TRUE. IF (aimag(z)/=0.0) l2 = .FALSE. fmleq_fmz = l1 .AND. l2 END FUNCTION fmleq_fmz FUNCTION fmleq_fmc(ma,c) ! .. Function Return Value .. LOGICAL :: fmleq_fmc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) l1 = fmcomp(ma%mfm,'EQ',mtfm%mfm) l2 = .TRUE. IF (aimag(c)/=0.0) l2 = .FALSE. fmleq_fmc = l1 .AND. l2 END FUNCTION fmleq_fmc FUNCTION fmleq_fmfm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmleq_fmfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. fmleq_fmfm = fmcomp(ma%mfm,'EQ',mb%mfm) END FUNCTION fmleq_fmfm FUNCTION fmleq_fmim(ma,mb) ! .. Function Return Value .. LOGICAL :: fmleq_fmim ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmint, imi2fm ! .. CALL fmint(ma%mfm,mtfm%mfm) IF (fmcomp(ma%mfm,'EQ',mtfm%mfm)) THEN CALL imi2fm(mb%mim,mtfm%mfm) fmleq_fmim = fmcomp(ma%mfm,'EQ',mtfm%mfm) ELSE fmleq_fmim = .FALSE. END IF END FUNCTION fmleq_fmim FUNCTION fmleq_fmzm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmleq_fmzm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL zmreal ! .. CALL zmreal(mb%mzm,mtfm%mfm) l1 = fmcomp(ma%mfm,'EQ',mtfm%mfm) l2 = .TRUE. IF (mb%mzm(kptimu+2)/=0) l2 = .FALSE. fmleq_fmzm = l1 .AND. l2 END FUNCTION fmleq_fmzm FUNCTION fmleq_imi(ma,ival) ! .. Function Return Value .. LOGICAL :: fmleq_imi ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL imi2m ! .. CALL imi2m(ival,mtim%mim) fmleq_imi = imcomp(ma%mim,'EQ',mtim%mim) END FUNCTION fmleq_imi FUNCTION fmleq_imr(ma,r) ! .. Function Return Value .. LOGICAL :: fmleq_imr ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmleq_imr = fmcomp(mufm%mfm,'EQ',mtfm%mfm) ndig = ndsave END FUNCTION fmleq_imr FUNCTION fmleq_imd(ma,d) ! .. Function Return Value .. LOGICAL :: fmleq_imd ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmleq_imd = fmcomp(mufm%mfm,'EQ',mtfm%mfm) ndig = ndsave END FUNCTION fmleq_imd FUNCTION fmleq_imz(ma,z) ! .. Function Return Value .. LOGICAL :: fmleq_imz ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(real(z),mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) l1 = fmcomp(mufm%mfm,'EQ',mtfm%mfm) ndig = ndsave l2 = .TRUE. IF (aimag(z)/=0.0) l2 = .FALSE. fmleq_imz = l1 .AND. l2 END FUNCTION fmleq_imz FUNCTION fmleq_imc(ma,c) ! .. Function Return Value .. LOGICAL :: fmleq_imc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) l1 = fmcomp(mufm%mfm,'EQ',mtfm%mfm) ndig = ndsave l2 = .TRUE. IF (aimag(c)/=0.0) l2 = .FALSE. fmleq_imc = l1 .AND. l2 END FUNCTION fmleq_imc FUNCTION fmleq_imfm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmleq_imfm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmint, imi2fm ! .. CALL fmint(mb%mfm,mtfm%mfm) IF (fmcomp(mb%mfm,'EQ',mtfm%mfm)) THEN CALL imi2fm(ma%mim,mtfm%mfm) fmleq_imfm = fmcomp(mb%mfm,'EQ',mtfm%mfm) ELSE fmleq_imfm = .FALSE. END IF END FUNCTION fmleq_imfm FUNCTION fmleq_imim(ma,mb) ! .. Function Return Value .. LOGICAL :: fmleq_imim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. fmleq_imim = imcomp(ma%mim,'EQ',mb%mim) END FUNCTION fmleq_imim FUNCTION fmleq_imzm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmleq_imzm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmint, imi2fm, zmreal ! .. CALL zmreal(mb%mzm,mtfm%mfm) CALL fmint(mtfm%mfm,mufm%mfm) IF (fmcomp(mufm%mfm,'EQ',mtfm%mfm) .AND. mb%mzm(kptimu+2)==0) THEN CALL imi2fm(ma%mim,mufm%mfm) fmleq_imzm = fmcomp(mufm%mfm,'EQ',mtfm%mfm) ELSE fmleq_imzm = .FALSE. END IF END FUNCTION fmleq_imzm FUNCTION fmleq_zmi(ma,ival) ! .. Function Return Value .. LOGICAL :: fmleq_zmi ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmint, zmreal ! .. CALL zmreal(ma%mzm,mtfm%mfm) CALL fmint(mtfm%mfm,mufm%mfm) IF (fmcomp(mufm%mfm,'EQ',mtfm%mfm) .AND. ma%mzm(kptimu+2)==0) THEN CALL fmi2m(ival,mufm%mfm) fmleq_zmi = fmcomp(mtfm%mfm,'EQ',mufm%mfm) ELSE fmleq_zmi = .FALSE. END IF END FUNCTION fmleq_zmi FUNCTION fmleq_zmr(ma,r) ! .. Function Return Value .. LOGICAL :: fmleq_zmr ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsp2m, zmimag, zmreal ! .. CALL fmsp2m(r,mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) CALL fmi2m(0,mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) fmleq_zmr = l1 .AND. l2 END FUNCTION fmleq_zmr FUNCTION fmleq_zmd(ma,d) ! .. Function Return Value .. LOGICAL :: fmleq_zmd ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmimag, zmreal ! .. CALL fmdp2m(d,mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) CALL fmi2m(0,mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) fmleq_zmd = l1 .AND. l2 END FUNCTION fmleq_zmd FUNCTION fmleq_zmz(ma,z) ! .. Function Return Value .. LOGICAL :: fmleq_zmz ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, zmimag, zmreal ! .. CALL fmsp2m(real(z),mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) CALL fmsp2m(aimag(z),mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) fmleq_zmz = l1 .AND. l2 END FUNCTION fmleq_zmz FUNCTION fmleq_zmc(ma,c) ! .. Function Return Value .. LOGICAL :: fmleq_zmc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmimag, zmreal ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) CALL fmdp2m(aimag(c),mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) fmleq_zmc = l1 .AND. l2 END FUNCTION fmleq_zmc FUNCTION fmleq_zmfm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmleq_zmfm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL zmreal ! .. CALL zmreal(ma%mzm,mtfm%mfm) l1 = fmcomp(mb%mfm,'EQ',mtfm%mfm) l2 = .TRUE. IF (ma%mzm(kptimu+2)/=0) l2 = .FALSE. fmleq_zmfm = l1 .AND. l2 END FUNCTION fmleq_zmfm FUNCTION fmleq_zmim(ma,mb) ! .. Function Return Value .. LOGICAL :: fmleq_zmim ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmint, imi2fm, zmreal ! .. CALL zmreal(ma%mzm,mtfm%mfm) CALL fmint(mtfm%mfm,mufm%mfm) IF (fmcomp(mufm%mfm,'EQ',mtfm%mfm) .AND. ma%mzm(kptimu+2)==0) THEN CALL imi2fm(mb%mim,mufm%mfm) fmleq_zmim = fmcomp(mufm%mfm,'EQ',mtfm%mfm) ELSE fmleq_zmim = .FALSE. END IF END FUNCTION fmleq_zmim FUNCTION fmleq_zmzm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmleq_zmzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma, mb ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL zmimag, zmreal ! .. CALL zmreal(ma%mzm,mtfm%mfm) CALL zmreal(mb%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) CALL zmimag(ma%mzm,mtfm%mfm) CALL zmimag(mb%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'EQ',mufm%mfm) fmleq_zmzm = l1 .AND. l2 END FUNCTION fmleq_zmzm ! .NE. FUNCTION fmlne_ifm(ival,ma) ! .. Function Return Value .. LOGICAL :: fmlne_ifm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m ! .. CALL fmi2m(ival,mtfm%mfm) fmlne_ifm = fmcomp(mtfm%mfm,'NE',ma%mfm) END FUNCTION fmlne_ifm FUNCTION fmlne_iim(ival,ma) ! .. Function Return Value .. LOGICAL :: fmlne_iim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL imi2m ! .. CALL imi2m(ival,mtim%mim) fmlne_iim = imcomp(mtim%mim,'NE',ma%mim) END FUNCTION fmlne_iim FUNCTION fmlne_izm(ival,ma) ! .. Function Return Value .. LOGICAL :: fmlne_izm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmimag, zmreal ! .. CALL fmi2m(ival,mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'NE',mufm%mfm) CALL fmi2m(0,mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'NE',mufm%mfm) fmlne_izm = l1 .OR. l2 END FUNCTION fmlne_izm FUNCTION fmlne_rfm(r,ma) ! .. Function Return Value .. LOGICAL :: fmlne_rfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) fmlne_rfm = fmcomp(mtfm%mfm,'NE',ma%mfm) END FUNCTION fmlne_rfm FUNCTION fmlne_rim(r,ma) ! .. Function Return Value .. LOGICAL :: fmlne_rim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlne_rim = fmcomp(mtfm%mfm,'NE',mufm%mfm) ndig = ndsave END FUNCTION fmlne_rim FUNCTION fmlne_rzm(r,ma) ! .. Function Return Value .. LOGICAL :: fmlne_rzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsp2m, zmimag, zmreal ! .. CALL fmsp2m(r,mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'NE',mufm%mfm) CALL fmi2m(0,mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'NE',mufm%mfm) fmlne_rzm = l1 .OR. l2 END FUNCTION fmlne_rzm FUNCTION fmlne_dfm(d,ma) ! .. Function Return Value .. LOGICAL :: fmlne_dfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) fmlne_dfm = fmcomp(mtfm%mfm,'NE',ma%mfm) END FUNCTION fmlne_dfm FUNCTION fmlne_dim(d,ma) ! .. Function Return Value .. LOGICAL :: fmlne_dim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlne_dim = fmcomp(mtfm%mfm,'NE',mufm%mfm) ndig = ndsave END FUNCTION fmlne_dim FUNCTION fmlne_dzm(d,ma) ! .. Function Return Value .. LOGICAL :: fmlne_dzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmimag, zmreal ! .. CALL fmdp2m(d,mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'NE',mufm%mfm) CALL fmi2m(0,mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'NE',mufm%mfm) fmlne_dzm = l1 .OR. l2 END FUNCTION fmlne_dzm FUNCTION fmlne_zfm(z,ma) ! .. Function Return Value .. LOGICAL :: fmlne_zfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(real(z),mtfm%mfm) l1 = fmcomp(mtfm%mfm,'NE',ma%mfm) l2 = .FALSE. IF (aimag(z)/=0.0) l2 = .TRUE. fmlne_zfm = l1 .OR. l2 END FUNCTION fmlne_zfm FUNCTION fmlne_zim(z,ma) ! .. Function Return Value .. LOGICAL :: fmlne_zim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(real(z),mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) l1 = fmcomp(mtfm%mfm,'NE',mufm%mfm) ndig = ndsave l2 = .FALSE. IF (aimag(z)/=0.0) l2 = .TRUE. fmlne_zim = l1 .OR. l2 END FUNCTION fmlne_zim FUNCTION fmlne_zzm(z,ma) ! .. Function Return Value .. LOGICAL :: fmlne_zzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, zmimag, zmreal ! .. CALL fmsp2m(real(z),mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'NE',mufm%mfm) CALL fmsp2m(aimag(z),mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'NE',mufm%mfm) fmlne_zzm = l1 .OR. l2 END FUNCTION fmlne_zzm FUNCTION fmlne_cfm(c,ma) ! .. Function Return Value .. LOGICAL :: fmlne_cfm ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) l1 = fmcomp(mtfm%mfm,'NE',ma%mfm) l2 = .FALSE. IF (aimag(c)/=0.0) l2 = .TRUE. fmlne_cfm = l1 .OR. l2 END FUNCTION fmlne_cfm FUNCTION fmlne_cim(c,ma) ! .. Function Return Value .. LOGICAL :: fmlne_cim ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) l1 = fmcomp(mtfm%mfm,'NE',mufm%mfm) ndig = ndsave l2 = .FALSE. IF (aimag(c)/=0.0) l2 = .TRUE. fmlne_cim = l1 .OR. l2 END FUNCTION fmlne_cim FUNCTION fmlne_czm(c,ma) ! .. Function Return Value .. LOGICAL :: fmlne_czm ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmimag, zmreal ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'NE',mufm%mfm) CALL fmdp2m(aimag(c),mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'NE',mufm%mfm) fmlne_czm = l1 .OR. l2 END FUNCTION fmlne_czm FUNCTION fmlne_fmi(ma,ival) ! .. Function Return Value .. LOGICAL :: fmlne_fmi ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m ! .. CALL fmi2m(ival,mtfm%mfm) fmlne_fmi = fmcomp(ma%mfm,'NE',mtfm%mfm) END FUNCTION fmlne_fmi FUNCTION fmlne_fmr(ma,r) ! .. Function Return Value .. LOGICAL :: fmlne_fmr ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) fmlne_fmr = fmcomp(ma%mfm,'NE',mtfm%mfm) END FUNCTION fmlne_fmr FUNCTION fmlne_fmd(ma,d) ! .. Function Return Value .. LOGICAL :: fmlne_fmd ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) fmlne_fmd = fmcomp(ma%mfm,'NE',mtfm%mfm) END FUNCTION fmlne_fmd FUNCTION fmlne_fmz(ma,z) ! .. Function Return Value .. LOGICAL :: fmlne_fmz ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(real(z),mtfm%mfm) l1 = fmcomp(ma%mfm,'NE',mtfm%mfm) l2 = .FALSE. IF (aimag(z)/=0.0) l2 = .TRUE. fmlne_fmz = l1 .OR. l2 END FUNCTION fmlne_fmz FUNCTION fmlne_fmc(ma,c) ! .. Function Return Value .. LOGICAL :: fmlne_fmc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) l1 = fmcomp(ma%mfm,'NE',mtfm%mfm) l2 = .FALSE. IF (aimag(c)/=0.0) l2 = .TRUE. fmlne_fmc = l1 .OR. l2 END FUNCTION fmlne_fmc FUNCTION fmlne_fmfm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlne_fmfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. fmlne_fmfm = fmcomp(ma%mfm,'NE',mb%mfm) END FUNCTION fmlne_fmfm FUNCTION fmlne_fmim(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlne_fmim ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmint, imi2fm ! .. CALL fmint(ma%mfm,mtfm%mfm) IF (fmcomp(ma%mfm,'EQ',mtfm%mfm)) THEN CALL imi2fm(mb%mim,mtfm%mfm) fmlne_fmim = fmcomp(ma%mfm,'NE',mtfm%mfm) ELSE fmlne_fmim = .TRUE. END IF END FUNCTION fmlne_fmim FUNCTION fmlne_fmzm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlne_fmzm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL zmreal ! .. CALL zmreal(mb%mzm,mtfm%mfm) l1 = fmcomp(ma%mfm,'NE',mtfm%mfm) l2 = .FALSE. IF (mb%mzm(kptimu+2)/=0) l2 = .TRUE. fmlne_fmzm = l1 .OR. l2 END FUNCTION fmlne_fmzm FUNCTION fmlne_imi(ma,ival) ! .. Function Return Value .. LOGICAL :: fmlne_imi ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL imi2m ! .. CALL imi2m(ival,mtim%mim) fmlne_imi = imcomp(ma%mim,'NE',mtim%mim) END FUNCTION fmlne_imi FUNCTION fmlne_imr(ma,r) ! .. Function Return Value .. LOGICAL :: fmlne_imr ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlne_imr = fmcomp(mufm%mfm,'NE',mtfm%mfm) ndig = ndsave END FUNCTION fmlne_imr FUNCTION fmlne_imd(ma,d) ! .. Function Return Value .. LOGICAL :: fmlne_imd ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlne_imd = fmcomp(mufm%mfm,'NE',mtfm%mfm) ndig = ndsave END FUNCTION fmlne_imd FUNCTION fmlne_imz(ma,z) ! .. Function Return Value .. LOGICAL :: fmlne_imz ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(real(z),mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) l1 = fmcomp(mufm%mfm,'NE',mtfm%mfm) ndig = ndsave l2 = .FALSE. IF (aimag(z)/=0.0) l2 = .TRUE. fmlne_imz = l1 .OR. l2 END FUNCTION fmlne_imz FUNCTION fmlne_imc(ma,c) ! .. Function Return Value .. LOGICAL :: fmlne_imc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) l1 = fmcomp(mufm%mfm,'NE',mtfm%mfm) ndig = ndsave l2 = .FALSE. IF (aimag(c)/=0.0) l2 = .TRUE. fmlne_imc = l1 .OR. l2 END FUNCTION fmlne_imc FUNCTION fmlne_imfm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlne_imfm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmint, imi2fm ! .. CALL fmint(mb%mfm,mtfm%mfm) IF (fmcomp(mb%mfm,'EQ',mtfm%mfm)) THEN CALL imi2fm(ma%mim,mtfm%mfm) fmlne_imfm = fmcomp(mb%mfm,'NE',mtfm%mfm) ELSE fmlne_imfm = .TRUE. END IF END FUNCTION fmlne_imfm FUNCTION fmlne_imim(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlne_imim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. fmlne_imim = imcomp(ma%mim,'NE',mb%mim) END FUNCTION fmlne_imim FUNCTION fmlne_imzm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlne_imzm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmint, imi2fm, zmreal ! .. CALL zmreal(mb%mzm,mtfm%mfm) CALL fmint(mtfm%mfm,mufm%mfm) IF (fmcomp(mufm%mfm,'EQ',mtfm%mfm) .AND. mb%mzm(kptimu+2)==0) THEN CALL imi2fm(ma%mim,mufm%mfm) fmlne_imzm = fmcomp(mufm%mfm,'NE',mtfm%mfm) ELSE fmlne_imzm = .TRUE. END IF END FUNCTION fmlne_imzm FUNCTION fmlne_zmi(ma,ival) ! .. Function Return Value .. LOGICAL :: fmlne_zmi ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmint, zmreal ! .. CALL zmreal(ma%mzm,mtfm%mfm) CALL fmint(mtfm%mfm,mufm%mfm) IF (fmcomp(mufm%mfm,'EQ',mtfm%mfm) .AND. ma%mzm(kptimu+2)==0) THEN CALL fmi2m(ival,mufm%mfm) fmlne_zmi = fmcomp(mtfm%mfm,'NE',mufm%mfm) ELSE fmlne_zmi = .TRUE. END IF END FUNCTION fmlne_zmi FUNCTION fmlne_zmr(ma,r) ! .. Function Return Value .. LOGICAL :: fmlne_zmr ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsp2m, zmimag, zmreal ! .. CALL fmsp2m(r,mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'NE',mufm%mfm) CALL fmi2m(0,mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'NE',mufm%mfm) fmlne_zmr = l1 .OR. l2 END FUNCTION fmlne_zmr FUNCTION fmlne_zmd(ma,d) ! .. Function Return Value .. LOGICAL :: fmlne_zmd ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmimag, zmreal ! .. CALL fmdp2m(d,mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'NE',mufm%mfm) CALL fmi2m(0,mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'NE',mufm%mfm) fmlne_zmd = l1 .OR. l2 END FUNCTION fmlne_zmd FUNCTION fmlne_zmz(ma,z) ! .. Function Return Value .. LOGICAL :: fmlne_zmz ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, zmimag, zmreal ! .. CALL fmsp2m(real(z),mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'NE',mufm%mfm) CALL fmsp2m(aimag(z),mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'NE',mufm%mfm) fmlne_zmz = l1 .OR. l2 END FUNCTION fmlne_zmz FUNCTION fmlne_zmc(ma,c) ! .. Function Return Value .. LOGICAL :: fmlne_zmc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmimag, zmreal ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL zmreal(ma%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'NE',mufm%mfm) CALL fmdp2m(aimag(c),mtfm%mfm) CALL zmimag(ma%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'NE',mufm%mfm) fmlne_zmc = l1 .OR. l2 END FUNCTION fmlne_zmc FUNCTION fmlne_zmfm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlne_zmfm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL zmreal ! .. CALL zmreal(ma%mzm,mtfm%mfm) l1 = fmcomp(mb%mfm,'NE',mtfm%mfm) l2 = .FALSE. IF (ma%mzm(kptimu+2)/=0) l2 = .TRUE. fmlne_zmfm = l1 .OR. l2 END FUNCTION fmlne_zmfm FUNCTION fmlne_zmim(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlne_zmim ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmint, imi2fm, zmreal ! .. CALL zmreal(ma%mzm,mtfm%mfm) CALL fmint(mtfm%mfm,mufm%mfm) IF (fmcomp(mufm%mfm,'EQ',mtfm%mfm) .AND. ma%mzm(kptimu+2)==0) THEN CALL imi2fm(mb%mim,mufm%mfm) fmlne_zmim = fmcomp(mufm%mfm,'NE',mtfm%mfm) ELSE fmlne_zmim = .TRUE. END IF END FUNCTION fmlne_zmim FUNCTION fmlne_zmzm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlne_zmzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma, mb ! .. ! .. Local Scalars .. LOGICAL :: l1, l2 ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL zmimag, zmreal ! .. CALL zmreal(ma%mzm,mtfm%mfm) CALL zmreal(mb%mzm,mufm%mfm) l1 = fmcomp(mtfm%mfm,'NE',mufm%mfm) CALL zmimag(ma%mzm,mtfm%mfm) CALL zmimag(mb%mzm,mufm%mfm) l2 = fmcomp(mtfm%mfm,'NE',mufm%mfm) fmlne_zmzm = l1 .OR. l2 END FUNCTION fmlne_zmzm ! .GT. FUNCTION fmlgt_ifm(ival,ma) ! .. Function Return Value .. LOGICAL :: fmlgt_ifm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m ! .. CALL fmi2m(ival,mtfm%mfm) fmlgt_ifm = fmcomp(mtfm%mfm,'GT',ma%mfm) END FUNCTION fmlgt_ifm FUNCTION fmlgt_iim(ival,ma) ! .. Function Return Value .. LOGICAL :: fmlgt_iim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL imi2m ! .. CALL imi2m(ival,mtim%mim) fmlgt_iim = imcomp(mtim%mim,'GT',ma%mim) END FUNCTION fmlgt_iim FUNCTION fmlgt_rfm(r,ma) ! .. Function Return Value .. LOGICAL :: fmlgt_rfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) fmlgt_rfm = fmcomp(mtfm%mfm,'GT',ma%mfm) END FUNCTION fmlgt_rfm FUNCTION fmlgt_rim(r,ma) ! .. Function Return Value .. LOGICAL :: fmlgt_rim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlgt_rim = fmcomp(mtfm%mfm,'GT',mufm%mfm) ndig = ndsave END FUNCTION fmlgt_rim FUNCTION fmlgt_dfm(d,ma) ! .. Function Return Value .. LOGICAL :: fmlgt_dfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) fmlgt_dfm = fmcomp(mtfm%mfm,'GT',ma%mfm) END FUNCTION fmlgt_dfm FUNCTION fmlgt_dim(d,ma) ! .. Function Return Value .. LOGICAL :: fmlgt_dim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlgt_dim = fmcomp(mtfm%mfm,'GT',mufm%mfm) ndig = ndsave END FUNCTION fmlgt_dim FUNCTION fmlgt_fmi(ma,ival) ! .. Function Return Value .. LOGICAL :: fmlgt_fmi ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m ! .. CALL fmi2m(ival,mtfm%mfm) fmlgt_fmi = fmcomp(ma%mfm,'GT',mtfm%mfm) END FUNCTION fmlgt_fmi FUNCTION fmlgt_fmr(ma,r) ! .. Function Return Value .. LOGICAL :: fmlgt_fmr ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) fmlgt_fmr = fmcomp(ma%mfm,'GT',mtfm%mfm) END FUNCTION fmlgt_fmr FUNCTION fmlgt_fmd(ma,d) ! .. Function Return Value .. LOGICAL :: fmlgt_fmd ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) fmlgt_fmd = fmcomp(ma%mfm,'GT',mtfm%mfm) END FUNCTION fmlgt_fmd FUNCTION fmlgt_fmfm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlgt_fmfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. fmlgt_fmfm = fmcomp(ma%mfm,'GT',mb%mfm) END FUNCTION fmlgt_fmfm FUNCTION fmlgt_fmim(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlgt_fmim ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL imi2fm ! .. ndsave = ndig ka = mb%mim(1) ndig = max(ka+ngrd52,ndig) CALL imi2fm(mb%mim,mtfm%mfm) fmlgt_fmim = fmcomp(ma%mfm,'GT',mtfm%mfm) ndig = ndsave END FUNCTION fmlgt_fmim FUNCTION fmlgt_imi(ma,ival) ! .. Function Return Value .. LOGICAL :: fmlgt_imi ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL imi2m ! .. CALL imi2m(ival,mtim%mim) fmlgt_imi = imcomp(ma%mim,'GT',mtim%mim) END FUNCTION fmlgt_imi FUNCTION fmlgt_imr(ma,r) ! .. Function Return Value .. LOGICAL :: fmlgt_imr ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlgt_imr = fmcomp(mufm%mfm,'GT',mtfm%mfm) ndig = ndsave END FUNCTION fmlgt_imr FUNCTION fmlgt_imd(ma,d) ! .. Function Return Value .. LOGICAL :: fmlgt_imd ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlgt_imd = fmcomp(mufm%mfm,'GT',mtfm%mfm) ndig = ndsave END FUNCTION fmlgt_imd FUNCTION fmlgt_imfm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlgt_imfm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL imi2fm(ma%mim,mtfm%mfm) fmlgt_imfm = fmcomp(mtfm%mfm,'GT',mb%mfm) ndig = ndsave END FUNCTION fmlgt_imfm FUNCTION fmlgt_imim(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlgt_imim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. fmlgt_imim = imcomp(ma%mim,'GT',mb%mim) END FUNCTION fmlgt_imim ! .GE. FUNCTION fmlge_ifm(ival,ma) ! .. Function Return Value .. LOGICAL :: fmlge_ifm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m ! .. CALL fmi2m(ival,mtfm%mfm) fmlge_ifm = fmcomp(mtfm%mfm,'GE',ma%mfm) END FUNCTION fmlge_ifm FUNCTION fmlge_iim(ival,ma) ! .. Function Return Value .. LOGICAL :: fmlge_iim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL imi2m ! .. CALL imi2m(ival,mtim%mim) fmlge_iim = imcomp(mtim%mim,'GE',ma%mim) END FUNCTION fmlge_iim FUNCTION fmlge_rfm(r,ma) ! .. Function Return Value .. LOGICAL :: fmlge_rfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) fmlge_rfm = fmcomp(mtfm%mfm,'GE',ma%mfm) END FUNCTION fmlge_rfm FUNCTION fmlge_rim(r,ma) ! .. Function Return Value .. LOGICAL :: fmlge_rim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlge_rim = fmcomp(mtfm%mfm,'GE',mufm%mfm) ndig = ndsave END FUNCTION fmlge_rim FUNCTION fmlge_dfm(d,ma) ! .. Function Return Value .. LOGICAL :: fmlge_dfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) fmlge_dfm = fmcomp(mtfm%mfm,'GE',ma%mfm) END FUNCTION fmlge_dfm FUNCTION fmlge_dim(d,ma) ! .. Function Return Value .. LOGICAL :: fmlge_dim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlge_dim = fmcomp(mtfm%mfm,'GE',mufm%mfm) ndig = ndsave END FUNCTION fmlge_dim FUNCTION fmlge_fmi(ma,ival) ! .. Function Return Value .. LOGICAL :: fmlge_fmi ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m ! .. CALL fmi2m(ival,mtfm%mfm) fmlge_fmi = fmcomp(ma%mfm,'GE',mtfm%mfm) END FUNCTION fmlge_fmi FUNCTION fmlge_fmr(ma,r) ! .. Function Return Value .. LOGICAL :: fmlge_fmr ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) fmlge_fmr = fmcomp(ma%mfm,'GE',mtfm%mfm) END FUNCTION fmlge_fmr FUNCTION fmlge_fmd(ma,d) ! .. Function Return Value .. LOGICAL :: fmlge_fmd ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) fmlge_fmd = fmcomp(ma%mfm,'GE',mtfm%mfm) END FUNCTION fmlge_fmd FUNCTION fmlge_fmfm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlge_fmfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. fmlge_fmfm = fmcomp(ma%mfm,'GE',mb%mfm) END FUNCTION fmlge_fmfm FUNCTION fmlge_fmim(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlge_fmim ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL imi2fm ! .. ndsave = ndig ka = mb%mim(1) ndig = max(ka+ngrd52,ndig) CALL imi2fm(mb%mim,mtfm%mfm) fmlge_fmim = fmcomp(ma%mfm,'GE',mtfm%mfm) ndig = ndsave END FUNCTION fmlge_fmim FUNCTION fmlge_imi(ma,ival) ! .. Function Return Value .. LOGICAL :: fmlge_imi ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL imi2m ! .. CALL imi2m(ival,mtim%mim) fmlge_imi = imcomp(ma%mim,'GE',mtim%mim) END FUNCTION fmlge_imi FUNCTION fmlge_imr(ma,r) ! .. Function Return Value .. LOGICAL :: fmlge_imr ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlge_imr = fmcomp(mufm%mfm,'GE',mtfm%mfm) ndig = ndsave END FUNCTION fmlge_imr FUNCTION fmlge_imd(ma,d) ! .. Function Return Value .. LOGICAL :: fmlge_imd ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlge_imd = fmcomp(mufm%mfm,'GE',mtfm%mfm) ndig = ndsave END FUNCTION fmlge_imd FUNCTION fmlge_imfm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlge_imfm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL imi2fm(ma%mim,mtfm%mfm) fmlge_imfm = fmcomp(mtfm%mfm,'GE',mb%mfm) ndig = ndsave END FUNCTION fmlge_imfm FUNCTION fmlge_imim(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlge_imim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. fmlge_imim = imcomp(ma%mim,'GE',mb%mim) END FUNCTION fmlge_imim ! .LT. FUNCTION fmllt_ifm(ival,ma) ! .. Function Return Value .. LOGICAL :: fmllt_ifm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m ! .. CALL fmi2m(ival,mtfm%mfm) fmllt_ifm = fmcomp(mtfm%mfm,'LT',ma%mfm) END FUNCTION fmllt_ifm FUNCTION fmllt_iim(ival,ma) ! .. Function Return Value .. LOGICAL :: fmllt_iim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL imi2m ! .. CALL imi2m(ival,mtim%mim) fmllt_iim = imcomp(mtim%mim,'LT',ma%mim) END FUNCTION fmllt_iim FUNCTION fmllt_rfm(r,ma) ! .. Function Return Value .. LOGICAL :: fmllt_rfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) fmllt_rfm = fmcomp(mtfm%mfm,'LT',ma%mfm) END FUNCTION fmllt_rfm FUNCTION fmllt_rim(r,ma) ! .. Function Return Value .. LOGICAL :: fmllt_rim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmllt_rim = fmcomp(mtfm%mfm,'LT',mufm%mfm) ndig = ndsave END FUNCTION fmllt_rim FUNCTION fmllt_dfm(d,ma) ! .. Function Return Value .. LOGICAL :: fmllt_dfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) fmllt_dfm = fmcomp(mtfm%mfm,'LT',ma%mfm) END FUNCTION fmllt_dfm FUNCTION fmllt_dim(d,ma) ! .. Function Return Value .. LOGICAL :: fmllt_dim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmllt_dim = fmcomp(mtfm%mfm,'LT',mufm%mfm) ndig = ndsave END FUNCTION fmllt_dim FUNCTION fmllt_fmi(ma,ival) ! .. Function Return Value .. LOGICAL :: fmllt_fmi ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m ! .. CALL fmi2m(ival,mtfm%mfm) fmllt_fmi = fmcomp(ma%mfm,'LT',mtfm%mfm) END FUNCTION fmllt_fmi FUNCTION fmllt_fmr(ma,r) ! .. Function Return Value .. LOGICAL :: fmllt_fmr ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) fmllt_fmr = fmcomp(ma%mfm,'LT',mtfm%mfm) END FUNCTION fmllt_fmr FUNCTION fmllt_fmd(ma,d) ! .. Function Return Value .. LOGICAL :: fmllt_fmd ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) fmllt_fmd = fmcomp(ma%mfm,'LT',mtfm%mfm) END FUNCTION fmllt_fmd FUNCTION fmllt_fmfm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmllt_fmfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. fmllt_fmfm = fmcomp(ma%mfm,'LT',mb%mfm) END FUNCTION fmllt_fmfm FUNCTION fmllt_fmim(ma,mb) ! .. Function Return Value .. LOGICAL :: fmllt_fmim ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL imi2fm ! .. ndsave = ndig ka = mb%mim(1) ndig = max(ka+ngrd52,ndig) CALL imi2fm(mb%mim,mtfm%mfm) fmllt_fmim = fmcomp(ma%mfm,'LT',mtfm%mfm) ndig = ndsave END FUNCTION fmllt_fmim FUNCTION fmllt_imi(ma,ival) ! .. Function Return Value .. LOGICAL :: fmllt_imi ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL imi2m ! .. CALL imi2m(ival,mtim%mim) fmllt_imi = imcomp(ma%mim,'LT',mtim%mim) END FUNCTION fmllt_imi FUNCTION fmllt_imr(ma,r) ! .. Function Return Value .. LOGICAL :: fmllt_imr ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmllt_imr = fmcomp(mufm%mfm,'LT',mtfm%mfm) ndig = ndsave END FUNCTION fmllt_imr FUNCTION fmllt_imd(ma,d) ! .. Function Return Value .. LOGICAL :: fmllt_imd ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmllt_imd = fmcomp(mufm%mfm,'LT',mtfm%mfm) ndig = ndsave END FUNCTION fmllt_imd FUNCTION fmllt_imfm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmllt_imfm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL imi2fm(ma%mim,mtfm%mfm) fmllt_imfm = fmcomp(mtfm%mfm,'LT',mb%mfm) ndig = ndsave END FUNCTION fmllt_imfm FUNCTION fmllt_imim(ma,mb) ! .. Function Return Value .. LOGICAL :: fmllt_imim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. fmllt_imim = imcomp(ma%mim,'LT',mb%mim) END FUNCTION fmllt_imim ! .LE. FUNCTION fmlle_ifm(ival,ma) ! .. Function Return Value .. LOGICAL :: fmlle_ifm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m ! .. CALL fmi2m(ival,mtfm%mfm) fmlle_ifm = fmcomp(mtfm%mfm,'LE',ma%mfm) END FUNCTION fmlle_ifm FUNCTION fmlle_iim(ival,ma) ! .. Function Return Value .. LOGICAL :: fmlle_iim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL imi2m ! .. CALL imi2m(ival,mtim%mim) fmlle_iim = imcomp(mtim%mim,'LE',ma%mim) END FUNCTION fmlle_iim FUNCTION fmlle_rfm(r,ma) ! .. Function Return Value .. LOGICAL :: fmlle_rfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) fmlle_rfm = fmcomp(mtfm%mfm,'LE',ma%mfm) END FUNCTION fmlle_rfm FUNCTION fmlle_rim(r,ma) ! .. Function Return Value .. LOGICAL :: fmlle_rim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlle_rim = fmcomp(mtfm%mfm,'LE',mufm%mfm) ndig = ndsave END FUNCTION fmlle_rim FUNCTION fmlle_dfm(d,ma) ! .. Function Return Value .. LOGICAL :: fmlle_dfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) fmlle_dfm = fmcomp(mtfm%mfm,'LE',ma%mfm) END FUNCTION fmlle_dfm FUNCTION fmlle_dim(d,ma) ! .. Function Return Value .. LOGICAL :: fmlle_dim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlle_dim = fmcomp(mtfm%mfm,'LE',mufm%mfm) ndig = ndsave END FUNCTION fmlle_dim FUNCTION fmlle_fmi(ma,ival) ! .. Function Return Value .. LOGICAL :: fmlle_fmi ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmi2m ! .. CALL fmi2m(ival,mtfm%mfm) fmlle_fmi = fmcomp(ma%mfm,'LE',mtfm%mfm) END FUNCTION fmlle_fmi FUNCTION fmlle_fmr(ma,r) ! .. Function Return Value .. LOGICAL :: fmlle_fmr ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) fmlle_fmr = fmcomp(ma%mfm,'LE',mtfm%mfm) END FUNCTION fmlle_fmr FUNCTION fmlle_fmd(ma,d) ! .. Function Return Value .. LOGICAL :: fmlle_fmd ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) fmlle_fmd = fmcomp(ma%mfm,'LE',mtfm%mfm) END FUNCTION fmlle_fmd FUNCTION fmlle_fmfm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlle_fmfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. fmlle_fmfm = fmcomp(ma%mfm,'LE',mb%mfm) END FUNCTION fmlle_fmfm FUNCTION fmlle_fmim(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlle_fmim ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL imi2fm ! .. ndsave = ndig ka = mb%mim(1) ndig = max(ka+ngrd52,ndig) CALL imi2fm(mb%mim,mtfm%mfm) fmlle_fmim = fmcomp(ma%mfm,'LE',mtfm%mfm) ndig = ndsave END FUNCTION fmlle_fmim FUNCTION fmlle_imi(ma,ival) ! .. Function Return Value .. LOGICAL :: fmlle_imi ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. ! .. External Subroutines .. EXTERNAL imi2m ! .. CALL imi2m(ival,mtim%mim) fmlle_imi = imcomp(ma%mim,'LE',mtim%mim) END FUNCTION fmlle_imi FUNCTION fmlle_imr(ma,r) ! .. Function Return Value .. LOGICAL :: fmlle_imr ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlle_imr = fmcomp(mufm%mfm,'LE',mtfm%mfm) ndig = ndsave END FUNCTION fmlle_imr FUNCTION fmlle_imd(ma,d) ! .. Function Return Value .. LOGICAL :: fmlle_imd ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) fmlle_imd = fmcomp(mufm%mfm,'LE',mtfm%mfm) ndig = ndsave END FUNCTION fmlle_imd FUNCTION fmlle_imfm(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlle_imfm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. Local Scalars .. INTEGER :: ka, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL imi2fm ! .. ndsave = ndig ka = ma%mim(1) ndig = max(ka+ngrd52,ndig) CALL imi2fm(ma%mim,mtfm%mfm) fmlle_imfm = fmcomp(mtfm%mfm,'LE',mb%mfm) ndig = ndsave END FUNCTION fmlle_imfm FUNCTION fmlle_imim(ma,mb) ! .. Function Return Value .. LOGICAL :: fmlle_imim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: imcomp ! .. fmlle_imim = imcomp(ma%mim,'LE',mb%mim) END FUNCTION fmlle_imim ! + FUNCTION fmadd_ifm(ival,ma) ! .. Function Return Value .. TYPE (fm) :: fmadd_ifm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmi2m ! .. CALL fmi2m(ival,mtfm%mfm) CALL fmadd(mtfm%mfm,ma%mfm,fmadd_ifm%mfm) END FUNCTION fmadd_ifm FUNCTION fmadd_iim(ival,ma) ! .. Function Return Value .. TYPE (im) :: fmadd_iim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL imadd, imi2m ! .. CALL imi2m(ival,mtim%mim) CALL imadd(mtim%mim,ma%mim,fmadd_iim%mim) END FUNCTION fmadd_iim FUNCTION fmadd_izm(ival,ma) ! .. Function Return Value .. TYPE (zm) :: fmadd_izm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmadd, zmcmpx ! .. CALL fmi2m(ival,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmadd(mtzm%mzm,ma%mzm,fmadd_izm%mzm) END FUNCTION fmadd_izm FUNCTION fmadd_rfm(r,ma) ! .. Function Return Value .. TYPE (fm) :: fmadd_rfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmadd(mtfm%mfm,ma%mfm,fmadd_rfm%mfm) END FUNCTION fmadd_rfm FUNCTION fmadd_rim(r,ma) ! .. Function Return Value .. TYPE (fm) :: fmadd_rim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmsp2m, imi2fm ! .. CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmadd(mtfm%mfm,mufm%mfm,fmadd_rim%mfm) END FUNCTION fmadd_rim FUNCTION fmadd_rzm(r,ma) ! .. Function Return Value .. TYPE (zm) :: fmadd_rzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsp2m, zmadd, zmcmpx ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmadd(mtzm%mzm,ma%mzm,fmadd_rzm%mzm) END FUNCTION fmadd_rzm FUNCTION fmadd_dfm(d,ma) ! .. Function Return Value .. TYPE (fm) :: fmadd_dfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmadd(mtfm%mfm,ma%mfm,fmadd_dfm%mfm) END FUNCTION fmadd_dfm FUNCTION fmadd_dim(d,ma) ! .. Function Return Value .. TYPE (fm) :: fmadd_dim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmdp2m, imi2fm ! .. CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmadd(mtfm%mfm,mufm%mfm,fmadd_dim%mfm) END FUNCTION fmadd_dim FUNCTION fmadd_dzm(d,ma) ! .. Function Return Value .. TYPE (zm) :: fmadd_dzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmadd, zmcmpx ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmadd(mtzm%mzm,ma%mzm,fmadd_dzm%mzm) END FUNCTION fmadd_dzm FUNCTION fmadd_zfm(z,ma) ! .. Function Return Value .. TYPE (zm) :: fmadd_zfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmadd, zmcmpx, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmadd(mtzm%mzm,muzm%mzm,fmadd_zfm%mzm) END FUNCTION fmadd_zfm FUNCTION fmadd_zim(z,ma) ! .. Function Return Value .. TYPE (zm) :: fmadd_zim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmadd, zmcmpx, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmadd(mtzm%mzm,muzm%mzm,fmadd_zim%mzm) END FUNCTION fmadd_zim FUNCTION fmadd_zzm(z,ma) ! .. Function Return Value .. TYPE (zm) :: fmadd_zzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL zmadd, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL zmadd(mtzm%mzm,ma%mzm,fmadd_zzm%mzm) END FUNCTION fmadd_zzm FUNCTION fmadd_cfm(c,ma) ! .. Function Return Value .. TYPE (zm) :: fmadd_cfm ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmadd, zmcmpx ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmadd(mtzm%mzm,muzm%mzm,fmadd_cfm%mzm) END FUNCTION fmadd_cfm FUNCTION fmadd_cim(c,ma) ! .. Function Return Value .. TYPE (zm) :: fmadd_cim ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, imi2fm, zmadd, zmcmpx ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmadd(mtzm%mzm,muzm%mzm,fmadd_cim%mzm) END FUNCTION fmadd_cim FUNCTION fmadd_czm(c,ma) ! .. Function Return Value .. TYPE (zm) :: fmadd_czm ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmadd, zmcmpx ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmadd(mtzm%mzm,ma%mzm,fmadd_czm%mzm) END FUNCTION fmadd_czm FUNCTION fmadd_fmi(ma,ival) ! .. Function Return Value .. TYPE (fm) :: fmadd_fmi ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmi2m ! .. CALL fmi2m(ival,mtfm%mfm) CALL fmadd(ma%mfm,mtfm%mfm,fmadd_fmi%mfm) END FUNCTION fmadd_fmi FUNCTION fmadd_fmr(ma,r) ! .. Function Return Value .. TYPE (fm) :: fmadd_fmr ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmadd(ma%mfm,mtfm%mfm,fmadd_fmr%mfm) END FUNCTION fmadd_fmr FUNCTION fmadd_fmd(ma,d) ! .. Function Return Value .. TYPE (fm) :: fmadd_fmd ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmadd(ma%mfm,mtfm%mfm,fmadd_fmd%mfm) END FUNCTION fmadd_fmd FUNCTION fmadd_fmz(ma,z) ! .. Function Return Value .. TYPE (zm) :: fmadd_fmz ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmadd, zmcmpx, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmadd(muzm%mzm,mtzm%mzm,fmadd_fmz%mzm) END FUNCTION fmadd_fmz FUNCTION fmadd_fmc(ma,c) ! .. Function Return Value .. TYPE (zm) :: fmadd_fmc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmadd, zmcmpx ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmadd(muzm%mzm,mtzm%mzm,fmadd_fmc%mzm) END FUNCTION fmadd_fmc FUNCTION fmadd_fmfm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmadd_fmfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL fmadd ! .. CALL fmadd(ma%mfm,mb%mfm,fmadd_fmfm%mfm) END FUNCTION fmadd_fmfm FUNCTION fmadd_fmim(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmadd_fmim ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmadd, imi2fm ! .. CALL imi2fm(mb%mim,mtfm%mfm) CALL fmadd(ma%mfm,mtfm%mfm,fmadd_fmim%mfm) END FUNCTION fmadd_fmim FUNCTION fmadd_fmzm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmadd_fmzm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmadd, zmcmpx ! .. CALL fmi2m(0,mtfm%mfm) CALL zmcmpx(ma%mfm,mtfm%mfm,mtzm%mzm) CALL zmadd(mtzm%mzm,mb%mzm,fmadd_fmzm%mzm) END FUNCTION fmadd_fmzm FUNCTION fmadd_imi(ma,ival) ! .. Function Return Value .. TYPE (im) :: fmadd_imi ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL imadd, imi2m ! .. CALL imi2m(ival,mtim%mim) CALL imadd(ma%mim,mtim%mim,fmadd_imi%mim) END FUNCTION fmadd_imi FUNCTION fmadd_imr(ma,r) ! .. Function Return Value .. TYPE (fm) :: fmadd_imr ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmsp2m, imi2fm ! .. CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmadd(mufm%mfm,mtfm%mfm,fmadd_imr%mfm) END FUNCTION fmadd_imr FUNCTION fmadd_imd(ma,d) ! .. Function Return Value .. TYPE (fm) :: fmadd_imd ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmdp2m, imi2fm ! .. CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmadd(mufm%mfm,mtfm%mfm,fmadd_imd%mfm) END FUNCTION fmadd_imd FUNCTION fmadd_imz(ma,z) ! .. Function Return Value .. TYPE (zm) :: fmadd_imz ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmadd, zmcmpx, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmadd(muzm%mzm,mtzm%mzm,fmadd_imz%mzm) END FUNCTION fmadd_imz FUNCTION fmadd_imc(ma,c) ! .. Function Return Value .. TYPE (zm) :: fmadd_imc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, imi2fm, zmadd, zmcmpx ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmadd(muzm%mzm,mtzm%mzm,fmadd_imc%mzm) END FUNCTION fmadd_imc FUNCTION fmadd_imfm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmadd_imfm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmadd, imi2fm ! .. CALL imi2fm(ma%mim,mtfm%mfm) CALL fmadd(mtfm%mfm,mb%mfm,fmadd_imfm%mfm) END FUNCTION fmadd_imfm FUNCTION fmadd_imim(ma,mb) ! .. Function Return Value .. TYPE (im) :: fmadd_imim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL imadd ! .. CALL imadd(ma%mim,mb%mim,fmadd_imim%mim) END FUNCTION fmadd_imim FUNCTION fmadd_imzm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmadd_imzm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmadd, zmcmpx ! .. CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmadd(muzm%mzm,mb%mzm,fmadd_imzm%mzm) END FUNCTION fmadd_imzm FUNCTION fmadd_zmi(ma,ival) ! .. Function Return Value .. TYPE (zm) :: fmadd_zmi ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmadd, zmcmpx ! .. CALL fmi2m(ival,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmadd(ma%mzm,mtzm%mzm,fmadd_zmi%mzm) END FUNCTION fmadd_zmi FUNCTION fmadd_zmr(ma,r) ! .. Function Return Value .. TYPE (zm) :: fmadd_zmr ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsp2m, zmadd, zmcmpx ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmadd(ma%mzm,mtzm%mzm,fmadd_zmr%mzm) END FUNCTION fmadd_zmr FUNCTION fmadd_zmd(ma,d) ! .. Function Return Value .. TYPE (zm) :: fmadd_zmd ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmadd, zmcmpx ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmadd(ma%mzm,mtzm%mzm,fmadd_zmd%mzm) END FUNCTION fmadd_zmd FUNCTION fmadd_zmz(ma,z) ! .. Function Return Value .. TYPE (zm) :: fmadd_zmz ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL zmadd, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL zmadd(ma%mzm,mtzm%mzm,fmadd_zmz%mzm) END FUNCTION fmadd_zmz FUNCTION fmadd_zmc(ma,c) ! .. Function Return Value .. TYPE (zm) :: fmadd_zmc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmadd, zmcmpx ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmadd(ma%mzm,mtzm%mzm,fmadd_zmc%mzm) END FUNCTION fmadd_zmc FUNCTION fmadd_zmfm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmadd_zmfm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmadd, zmcmpx ! .. CALL fmi2m(0,mtfm%mfm) CALL zmcmpx(mb%mfm,mtfm%mfm,mtzm%mzm) CALL zmadd(ma%mzm,mtzm%mzm,fmadd_zmfm%mzm) END FUNCTION fmadd_zmfm FUNCTION fmadd_zmim(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmadd_zmim ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmadd, zmcmpx ! .. CALL imi2fm(mb%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmadd(ma%mzm,muzm%mzm,fmadd_zmim%mzm) END FUNCTION fmadd_zmim FUNCTION fmadd_zmzm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmadd_zmzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL zmadd ! .. CALL zmadd(ma%mzm,mb%mzm,fmadd_zmzm%mzm) END FUNCTION fmadd_zmzm FUNCTION fmadd_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmadd_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmeq ! .. CALL fmeq(ma%mfm,fmadd_fm%mfm) END FUNCTION fmadd_fm FUNCTION fmadd_im(ma) ! .. Function Return Value .. TYPE (im) :: fmadd_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL imeq ! .. CALL imeq(ma%mim,fmadd_im%mim) END FUNCTION fmadd_im FUNCTION fmadd_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmadd_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmeq ! .. CALL zmeq(ma%mzm,fmadd_zm%mzm) END FUNCTION fmadd_zm ! - FUNCTION fmsub_ifm(ival,ma) ! .. Function Return Value .. TYPE (fm) :: fmsub_ifm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsub ! .. CALL fmi2m(ival,mtfm%mfm) CALL fmsub(mtfm%mfm,ma%mfm,fmsub_ifm%mfm) END FUNCTION fmsub_ifm FUNCTION fmsub_iim(ival,ma) ! .. Function Return Value .. TYPE (im) :: fmsub_iim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL imi2m, imsub ! .. CALL imi2m(ival,mtim%mim) CALL imsub(mtim%mim,ma%mim,fmsub_iim%mim) END FUNCTION fmsub_iim FUNCTION fmsub_izm(ival,ma) ! .. Function Return Value .. TYPE (zm) :: fmsub_izm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmsub ! .. CALL fmi2m(ival,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmsub(mtzm%mzm,ma%mzm,fmsub_izm%mzm) END FUNCTION fmsub_izm FUNCTION fmsub_rfm(r,ma) ! .. Function Return Value .. TYPE (fm) :: fmsub_rfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, fmsub ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmsub(mtfm%mfm,ma%mfm,fmsub_rfm%mfm) END FUNCTION fmsub_rfm FUNCTION fmsub_rim(r,ma) ! .. Function Return Value .. TYPE (fm) :: fmsub_rim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, fmsub, imi2fm ! .. CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmsub(mtfm%mfm,mufm%mfm,fmsub_rim%mfm) END FUNCTION fmsub_rim FUNCTION fmsub_rzm(r,ma) ! .. Function Return Value .. TYPE (zm) :: fmsub_rzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsp2m, zmcmpx, zmsub ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmsub(mtzm%mzm,ma%mzm,fmsub_rzm%mzm) END FUNCTION fmsub_rzm FUNCTION fmsub_dfm(d,ma) ! .. Function Return Value .. TYPE (fm) :: fmsub_dfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmsub ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmsub(mtfm%mfm,ma%mfm,fmsub_dfm%mfm) END FUNCTION fmsub_dfm FUNCTION fmsub_dim(d,ma) ! .. Function Return Value .. TYPE (fm) :: fmsub_dim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmsub, imi2fm ! .. CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmsub(mtfm%mfm,mufm%mfm,fmsub_dim%mfm) END FUNCTION fmsub_dim FUNCTION fmsub_dzm(d,ma) ! .. Function Return Value .. TYPE (zm) :: fmsub_dzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmsub ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmsub(mtzm%mzm,ma%mzm,fmsub_dzm%mzm) END FUNCTION fmsub_dzm FUNCTION fmsub_zfm(z,ma) ! .. Function Return Value .. TYPE (zm) :: fmsub_zfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmsub, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmsub(mtzm%mzm,muzm%mzm,fmsub_zfm%mzm) END FUNCTION fmsub_zfm FUNCTION fmsub_zim(z,ma) ! .. Function Return Value .. TYPE (zm) :: fmsub_zim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmsub, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmsub(mtzm%mzm,muzm%mzm,fmsub_zim%mzm) END FUNCTION fmsub_zim FUNCTION fmsub_zzm(z,ma) ! .. Function Return Value .. TYPE (zm) :: fmsub_zzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL zmsub, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL zmsub(mtzm%mzm,ma%mzm,fmsub_zzm%mzm) END FUNCTION fmsub_zzm FUNCTION fmsub_cfm(c,ma) ! .. Function Return Value .. TYPE (zm) :: fmsub_cfm ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmsub ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmsub(mtzm%mzm,muzm%mzm,fmsub_cfm%mzm) END FUNCTION fmsub_cfm FUNCTION fmsub_cim(c,ma) ! .. Function Return Value .. TYPE (zm) :: fmsub_cim ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, imi2fm, zmcmpx, zmsub ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmsub(mtzm%mzm,muzm%mzm,fmsub_cim%mzm) END FUNCTION fmsub_cim FUNCTION fmsub_czm(c,ma) ! .. Function Return Value .. TYPE (zm) :: fmsub_czm ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmcmpx, zmsub ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmsub(mtzm%mzm,ma%mzm,fmsub_czm%mzm) END FUNCTION fmsub_czm FUNCTION fmsub_fmi(ma,ival) ! .. Function Return Value .. TYPE (fm) :: fmsub_fmi ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsub ! .. CALL fmi2m(ival,mtfm%mfm) CALL fmsub(ma%mfm,mtfm%mfm,fmsub_fmi%mfm) END FUNCTION fmsub_fmi FUNCTION fmsub_fmr(ma,r) ! .. Function Return Value .. TYPE (fm) :: fmsub_fmr ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, fmsub ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmsub(ma%mfm,mtfm%mfm,fmsub_fmr%mfm) END FUNCTION fmsub_fmr FUNCTION fmsub_fmd(ma,d) ! .. Function Return Value .. TYPE (fm) :: fmsub_fmd ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmsub ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmsub(ma%mfm,mtfm%mfm,fmsub_fmd%mfm) END FUNCTION fmsub_fmd FUNCTION fmsub_fmz(ma,z) ! .. Function Return Value .. TYPE (zm) :: fmsub_fmz ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmsub, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmsub(muzm%mzm,mtzm%mzm,fmsub_fmz%mzm) END FUNCTION fmsub_fmz FUNCTION fmsub_fmc(ma,c) ! .. Function Return Value .. TYPE (zm) :: fmsub_fmc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmsub ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmsub(muzm%mzm,mtzm%mzm,fmsub_fmc%mzm) END FUNCTION fmsub_fmc FUNCTION fmsub_fmfm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmsub_fmfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL fmsub ! .. CALL fmsub(ma%mfm,mb%mfm,fmsub_fmfm%mfm) END FUNCTION fmsub_fmfm FUNCTION fmsub_fmim(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmsub_fmim ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmsub, imi2fm ! .. CALL imi2fm(mb%mim,mtfm%mfm) CALL fmsub(ma%mfm,mtfm%mfm,fmsub_fmim%mfm) END FUNCTION fmsub_fmim FUNCTION fmsub_fmzm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmsub_fmzm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmsub ! .. CALL fmi2m(0,mtfm%mfm) CALL zmcmpx(ma%mfm,mtfm%mfm,mtzm%mzm) CALL zmsub(mtzm%mzm,mb%mzm,fmsub_fmzm%mzm) END FUNCTION fmsub_fmzm FUNCTION fmsub_imi(ma,ival) ! .. Function Return Value .. TYPE (im) :: fmsub_imi ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL imi2m, imsub ! .. CALL imi2m(ival,mtim%mim) CALL imsub(ma%mim,mtim%mim,fmsub_imi%mim) END FUNCTION fmsub_imi FUNCTION fmsub_imr(ma,r) ! .. Function Return Value .. TYPE (fm) :: fmsub_imr ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmsp2m, fmsub, imi2fm ! .. CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmsub(mufm%mfm,mtfm%mfm,fmsub_imr%mfm) END FUNCTION fmsub_imr FUNCTION fmsub_imd(ma,d) ! .. Function Return Value .. TYPE (fm) :: fmsub_imd ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmsub, imi2fm ! .. CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmsub(mufm%mfm,mtfm%mfm,fmsub_imd%mfm) END FUNCTION fmsub_imd FUNCTION fmsub_imz(ma,z) ! .. Function Return Value .. TYPE (zm) :: fmsub_imz ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmsub, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmsub(muzm%mzm,mtzm%mzm,fmsub_imz%mzm) END FUNCTION fmsub_imz FUNCTION fmsub_imc(ma,c) ! .. Function Return Value .. TYPE (zm) :: fmsub_imc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, imi2fm, zmcmpx, zmsub ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmsub(muzm%mzm,mtzm%mzm,fmsub_imc%mzm) END FUNCTION fmsub_imc FUNCTION fmsub_imfm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmsub_imfm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmsub, imi2fm ! .. CALL imi2fm(ma%mim,mtfm%mfm) CALL fmsub(mtfm%mfm,mb%mfm,fmsub_imfm%mfm) END FUNCTION fmsub_imfm FUNCTION fmsub_imim(ma,mb) ! .. Function Return Value .. TYPE (im) :: fmsub_imim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL imsub ! .. CALL imsub(ma%mim,mb%mim,fmsub_imim%mim) END FUNCTION fmsub_imim FUNCTION fmsub_imzm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmsub_imzm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmsub ! .. CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmsub(muzm%mzm,mb%mzm,fmsub_imzm%mzm) END FUNCTION fmsub_imzm FUNCTION fmsub_zmi(ma,ival) ! .. Function Return Value .. TYPE (zm) :: fmsub_zmi ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmsub ! .. CALL fmi2m(ival,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmsub(ma%mzm,mtzm%mzm,fmsub_zmi%mzm) END FUNCTION fmsub_zmi FUNCTION fmsub_zmr(ma,r) ! .. Function Return Value .. TYPE (zm) :: fmsub_zmr ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsp2m, zmcmpx, zmsub ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmsub(ma%mzm,mtzm%mzm,fmsub_zmr%mzm) END FUNCTION fmsub_zmr FUNCTION fmsub_zmd(ma,d) ! .. Function Return Value .. TYPE (zm) :: fmsub_zmd ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmsub ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmsub(ma%mzm,mtzm%mzm,fmsub_zmd%mzm) END FUNCTION fmsub_zmd FUNCTION fmsub_zmz(ma,z) ! .. Function Return Value .. TYPE (zm) :: fmsub_zmz ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL zmsub, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL zmsub(ma%mzm,mtzm%mzm,fmsub_zmz%mzm) END FUNCTION fmsub_zmz FUNCTION fmsub_zmc(ma,c) ! .. Function Return Value .. TYPE (zm) :: fmsub_zmc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmcmpx, zmsub ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmsub(ma%mzm,mtzm%mzm,fmsub_zmc%mzm) END FUNCTION fmsub_zmc FUNCTION fmsub_zmfm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmsub_zmfm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmsub ! .. CALL fmi2m(0,mtfm%mfm) CALL zmcmpx(mb%mfm,mtfm%mfm,mtzm%mzm) CALL zmsub(ma%mzm,mtzm%mzm,fmsub_zmfm%mzm) END FUNCTION fmsub_zmfm FUNCTION fmsub_zmim(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmsub_zmim ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmsub ! .. CALL imi2fm(mb%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmsub(ma%mzm,muzm%mzm,fmsub_zmim%mzm) END FUNCTION fmsub_zmim FUNCTION fmsub_zmzm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmsub_zmzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL zmsub ! .. CALL zmsub(ma%mzm,mb%mzm,fmsub_zmzm%mzm) END FUNCTION fmsub_zmzm FUNCTION fmsub_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmsub_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmeq ! .. CALL fmeq(ma%mfm,mtfm%mfm) IF (mtfm%mfm(1)/=munkno) mtfm%mfm(2) = -mtfm%mfm(2) CALL fmeq(mtfm%mfm,fmsub_fm%mfm) END FUNCTION fmsub_fm FUNCTION fmsub_im(ma) ! .. Function Return Value .. TYPE (im) :: fmsub_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL imeq ! .. CALL imeq(ma%mim,mtim%mim) IF (mtim%mim(1)/=munkno) mtim%mim(2) = -mtim%mim(2) CALL imeq(mtim%mim,fmsub_im%mim) END FUNCTION fmsub_im FUNCTION fmsub_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmsub_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmeq ! .. CALL zmeq(ma%mzm,mtzm%mzm) IF (mtzm%mzm(1)/=munkno) mtzm%mzm(2) = -mtzm%mzm(2) IF (mtzm%mzm(kptimu+1)/=munkno) THEN mtzm%mzm(kptimu+2) = -mtzm%mzm(kptimu+2) END IF CALL zmeq(mtzm%mzm,fmsub_zm%mzm) END FUNCTION fmsub_zm ! * FUNCTION fmmpy_ifm(ival,ma) ! .. Function Return Value .. TYPE (fm) :: fmmpy_ifm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmmpyi ! .. CALL fmmpyi(ma%mfm,ival,fmmpy_ifm%mfm) END FUNCTION fmmpy_ifm FUNCTION fmmpy_iim(ival,ma) ! .. Function Return Value .. TYPE (im) :: fmmpy_iim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL immpyi ! .. CALL immpyi(ma%mim,ival,fmmpy_iim%mim) END FUNCTION fmmpy_iim FUNCTION fmmpy_izm(ival,ma) ! .. Function Return Value .. TYPE (zm) :: fmmpy_izm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL zmmpyi ! .. CALL zmmpyi(ma%mzm,ival,fmmpy_izm%mzm) END FUNCTION fmmpy_izm FUNCTION fmmpy_rfm(r,ma) ! .. Function Return Value .. TYPE (fm) :: fmmpy_rfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmmpy, fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmmpy(mtfm%mfm,ma%mfm,fmmpy_rfm%mfm) END FUNCTION fmmpy_rfm FUNCTION fmmpy_rim(r,ma) ! .. Function Return Value .. TYPE (fm) :: fmmpy_rim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmmpy, fmsp2m, imi2fm ! .. CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmmpy(mtfm%mfm,mufm%mfm,fmmpy_rim%mfm) END FUNCTION fmmpy_rim FUNCTION fmmpy_rzm(r,ma) ! .. Function Return Value .. TYPE (zm) :: fmmpy_rzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsp2m, zmcmpx, zmmpy ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmmpy(mtzm%mzm,ma%mzm,fmmpy_rzm%mzm) END FUNCTION fmmpy_rzm FUNCTION fmmpy_dfm(d,ma) ! .. Function Return Value .. TYPE (fm) :: fmmpy_dfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmmpy ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmmpy(mtfm%mfm,ma%mfm,fmmpy_dfm%mfm) END FUNCTION fmmpy_dfm FUNCTION fmmpy_dim(d,ma) ! .. Function Return Value .. TYPE (fm) :: fmmpy_dim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmmpy, imi2fm ! .. CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmmpy(mtfm%mfm,mufm%mfm,fmmpy_dim%mfm) END FUNCTION fmmpy_dim FUNCTION fmmpy_dzm(d,ma) ! .. Function Return Value .. TYPE (zm) :: fmmpy_dzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmmpy ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmmpy(mtzm%mzm,ma%mzm,fmmpy_dzm%mzm) END FUNCTION fmmpy_dzm FUNCTION fmmpy_zfm(z,ma) ! .. Function Return Value .. TYPE (zm) :: fmmpy_zfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmmpy, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmmpy(mtzm%mzm,muzm%mzm,fmmpy_zfm%mzm) END FUNCTION fmmpy_zfm FUNCTION fmmpy_zim(z,ma) ! .. Function Return Value .. TYPE (zm) :: fmmpy_zim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmmpy, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmmpy(mtzm%mzm,muzm%mzm,fmmpy_zim%mzm) END FUNCTION fmmpy_zim FUNCTION fmmpy_zzm(z,ma) ! .. Function Return Value .. TYPE (zm) :: fmmpy_zzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL zmmpy, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL zmmpy(mtzm%mzm,ma%mzm,fmmpy_zzm%mzm) END FUNCTION fmmpy_zzm FUNCTION fmmpy_cfm(c,ma) ! .. Function Return Value .. TYPE (zm) :: fmmpy_cfm ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmmpy ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmmpy(mtzm%mzm,muzm%mzm,fmmpy_cfm%mzm) END FUNCTION fmmpy_cfm FUNCTION fmmpy_cim(c,ma) ! .. Function Return Value .. TYPE (zm) :: fmmpy_cim ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, imi2fm, zmcmpx, zmmpy ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmmpy(mtzm%mzm,muzm%mzm,fmmpy_cim%mzm) END FUNCTION fmmpy_cim FUNCTION fmmpy_czm(c,ma) ! .. Function Return Value .. TYPE (zm) :: fmmpy_czm ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmcmpx, zmmpy ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmmpy(mtzm%mzm,ma%mzm,fmmpy_czm%mzm) END FUNCTION fmmpy_czm FUNCTION fmmpy_fmi(ma,ival) ! .. Function Return Value .. TYPE (fm) :: fmmpy_fmi ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmmpyi ! .. CALL fmmpyi(ma%mfm,ival,fmmpy_fmi%mfm) END FUNCTION fmmpy_fmi FUNCTION fmmpy_fmr(ma,r) ! .. Function Return Value .. TYPE (fm) :: fmmpy_fmr ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmmpy, fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmmpy(ma%mfm,mtfm%mfm,fmmpy_fmr%mfm) END FUNCTION fmmpy_fmr FUNCTION fmmpy_fmd(ma,d) ! .. Function Return Value .. TYPE (fm) :: fmmpy_fmd ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmmpy ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmmpy(ma%mfm,mtfm%mfm,fmmpy_fmd%mfm) END FUNCTION fmmpy_fmd FUNCTION fmmpy_fmz(ma,z) ! .. Function Return Value .. TYPE (zm) :: fmmpy_fmz ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmmpy, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmmpy(muzm%mzm,mtzm%mzm,fmmpy_fmz%mzm) END FUNCTION fmmpy_fmz FUNCTION fmmpy_fmc(ma,c) ! .. Function Return Value .. TYPE (zm) :: fmmpy_fmc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmmpy ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmmpy(muzm%mzm,mtzm%mzm,fmmpy_fmc%mzm) END FUNCTION fmmpy_fmc FUNCTION fmmpy_fmfm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmmpy_fmfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL fmmpy ! .. CALL fmmpy(ma%mfm,mb%mfm,fmmpy_fmfm%mfm) END FUNCTION fmmpy_fmfm FUNCTION fmmpy_fmim(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmmpy_fmim ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmmpy, imi2fm ! .. CALL imi2fm(mb%mim,mtfm%mfm) CALL fmmpy(ma%mfm,mtfm%mfm,fmmpy_fmim%mfm) END FUNCTION fmmpy_fmim FUNCTION fmmpy_fmzm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmmpy_fmzm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmmpy ! .. CALL fmi2m(0,mtfm%mfm) CALL zmcmpx(ma%mfm,mtfm%mfm,mtzm%mzm) CALL zmmpy(mtzm%mzm,mb%mzm,fmmpy_fmzm%mzm) END FUNCTION fmmpy_fmzm FUNCTION fmmpy_imi(ma,ival) ! .. Function Return Value .. TYPE (im) :: fmmpy_imi ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL immpyi ! .. CALL immpyi(ma%mim,ival,fmmpy_imi%mim) END FUNCTION fmmpy_imi FUNCTION fmmpy_imr(ma,r) ! .. Function Return Value .. TYPE (fm) :: fmmpy_imr ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmmpy, fmsp2m, imi2fm ! .. CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmmpy(mufm%mfm,mtfm%mfm,fmmpy_imr%mfm) END FUNCTION fmmpy_imr FUNCTION fmmpy_imd(ma,d) ! .. Function Return Value .. TYPE (fm) :: fmmpy_imd ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmmpy, imi2fm ! .. CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmmpy(mufm%mfm,mtfm%mfm,fmmpy_imd%mfm) END FUNCTION fmmpy_imd FUNCTION fmmpy_imz(ma,z) ! .. Function Return Value .. TYPE (zm) :: fmmpy_imz ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmmpy, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmmpy(muzm%mzm,mtzm%mzm,fmmpy_imz%mzm) END FUNCTION fmmpy_imz FUNCTION fmmpy_imc(ma,c) ! .. Function Return Value .. TYPE (zm) :: fmmpy_imc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, imi2fm, zmcmpx, zmmpy ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmmpy(muzm%mzm,mtzm%mzm,fmmpy_imc%mzm) END FUNCTION fmmpy_imc FUNCTION fmmpy_imfm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmmpy_imfm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmmpy, imi2fm ! .. CALL imi2fm(ma%mim,mtfm%mfm) CALL fmmpy(mtfm%mfm,mb%mfm,fmmpy_imfm%mfm) END FUNCTION fmmpy_imfm FUNCTION fmmpy_imim(ma,mb) ! .. Function Return Value .. TYPE (im) :: fmmpy_imim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL immpy ! .. CALL immpy(ma%mim,mb%mim,fmmpy_imim%mim) END FUNCTION fmmpy_imim FUNCTION fmmpy_imzm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmmpy_imzm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmmpy ! .. CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmmpy(muzm%mzm,mb%mzm,fmmpy_imzm%mzm) END FUNCTION fmmpy_imzm FUNCTION fmmpy_zmi(ma,ival) ! .. Function Return Value .. TYPE (zm) :: fmmpy_zmi ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL zmmpyi ! .. CALL zmmpyi(ma%mzm,ival,fmmpy_zmi%mzm) END FUNCTION fmmpy_zmi FUNCTION fmmpy_zmr(ma,r) ! .. Function Return Value .. TYPE (zm) :: fmmpy_zmr ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsp2m, zmcmpx, zmmpy ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmmpy(ma%mzm,mtzm%mzm,fmmpy_zmr%mzm) END FUNCTION fmmpy_zmr FUNCTION fmmpy_zmd(ma,d) ! .. Function Return Value .. TYPE (zm) :: fmmpy_zmd ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmmpy ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmmpy(ma%mzm,mtzm%mzm,fmmpy_zmd%mzm) END FUNCTION fmmpy_zmd FUNCTION fmmpy_zmz(ma,z) ! .. Function Return Value .. TYPE (zm) :: fmmpy_zmz ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL zmmpy, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL zmmpy(ma%mzm,mtzm%mzm,fmmpy_zmz%mzm) END FUNCTION fmmpy_zmz FUNCTION fmmpy_zmc(ma,c) ! .. Function Return Value .. TYPE (zm) :: fmmpy_zmc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmcmpx, zmmpy ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmmpy(ma%mzm,mtzm%mzm,fmmpy_zmc%mzm) END FUNCTION fmmpy_zmc FUNCTION fmmpy_zmfm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmmpy_zmfm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmmpy ! .. CALL fmi2m(0,mtfm%mfm) CALL zmcmpx(mb%mfm,mtfm%mfm,mtzm%mzm) CALL zmmpy(ma%mzm,mtzm%mzm,fmmpy_zmfm%mzm) END FUNCTION fmmpy_zmfm FUNCTION fmmpy_zmim(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmmpy_zmim ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmmpy ! .. CALL imi2fm(mb%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmmpy(ma%mzm,muzm%mzm,fmmpy_zmim%mzm) END FUNCTION fmmpy_zmim FUNCTION fmmpy_zmzm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmmpy_zmzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL zmmpy ! .. CALL zmmpy(ma%mzm,mb%mzm,fmmpy_zmzm%mzm) END FUNCTION fmmpy_zmzm ! / FUNCTION fmdiv_ifm(ival,ma) ! .. Function Return Value .. TYPE (fm) :: fmdiv_ifm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmdiv, fmi2m ! .. CALL fmi2m(ival,mtfm%mfm) CALL fmdiv(mtfm%mfm,ma%mfm,fmdiv_ifm%mfm) END FUNCTION fmdiv_ifm FUNCTION fmdiv_iim(ival,ma) ! .. Function Return Value .. TYPE (im) :: fmdiv_iim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL imdiv, imi2m ! .. CALL imi2m(ival,mtim%mim) CALL imdiv(mtim%mim,ma%mim,fmdiv_iim%mim) END FUNCTION fmdiv_iim FUNCTION fmdiv_izm(ival,ma) ! .. Function Return Value .. TYPE (zm) :: fmdiv_izm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmdiv ! .. CALL fmi2m(ival,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmdiv(mtzm%mzm,ma%mzm,fmdiv_izm%mzm) END FUNCTION fmdiv_izm FUNCTION fmdiv_rfm(r,ma) ! .. Function Return Value .. TYPE (fm) :: fmdiv_rfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmdiv, fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmdiv(mtfm%mfm,ma%mfm,fmdiv_rfm%mfm) END FUNCTION fmdiv_rfm FUNCTION fmdiv_rim(r,ma) ! .. Function Return Value .. TYPE (fm) :: fmdiv_rim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmdiv, fmsp2m, imi2fm ! .. CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmdiv(mtfm%mfm,mufm%mfm,fmdiv_rim%mfm) END FUNCTION fmdiv_rim FUNCTION fmdiv_rzm(r,ma) ! .. Function Return Value .. TYPE (zm) :: fmdiv_rzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsp2m, zmcmpx, zmdiv ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmdiv(mtzm%mzm,ma%mzm,fmdiv_rzm%mzm) END FUNCTION fmdiv_rzm FUNCTION fmdiv_dfm(d,ma) ! .. Function Return Value .. TYPE (fm) :: fmdiv_dfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdiv, fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmdiv(mtfm%mfm,ma%mfm,fmdiv_dfm%mfm) END FUNCTION fmdiv_dfm FUNCTION fmdiv_dim(d,ma) ! .. Function Return Value .. TYPE (fm) :: fmdiv_dim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdiv, fmdp2m, imi2fm ! .. CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmdiv(mtfm%mfm,mufm%mfm,fmdiv_dim%mfm) END FUNCTION fmdiv_dim FUNCTION fmdiv_dzm(d,ma) ! .. Function Return Value .. TYPE (zm) :: fmdiv_dzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmdiv ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmdiv(mtzm%mzm,ma%mzm,fmdiv_dzm%mzm) END FUNCTION fmdiv_dzm FUNCTION fmdiv_zfm(z,ma) ! .. Function Return Value .. TYPE (zm) :: fmdiv_zfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmdiv, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmdiv(mtzm%mzm,muzm%mzm,fmdiv_zfm%mzm) END FUNCTION fmdiv_zfm FUNCTION fmdiv_zim(z,ma) ! .. Function Return Value .. TYPE (zm) :: fmdiv_zim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmdiv, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmdiv(mtzm%mzm,muzm%mzm,fmdiv_zim%mzm) END FUNCTION fmdiv_zim FUNCTION fmdiv_zzm(z,ma) ! .. Function Return Value .. TYPE (zm) :: fmdiv_zzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL zmdiv, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL zmdiv(mtzm%mzm,ma%mzm,fmdiv_zzm%mzm) END FUNCTION fmdiv_zzm FUNCTION fmdiv_cfm(c,ma) ! .. Function Return Value .. TYPE (zm) :: fmdiv_cfm ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmdiv ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmdiv(mtzm%mzm,muzm%mzm,fmdiv_cfm%mzm) END FUNCTION fmdiv_cfm FUNCTION fmdiv_cim(c,ma) ! .. Function Return Value .. TYPE (zm) :: fmdiv_cim ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, imi2fm, zmcmpx, zmdiv ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmdiv(mtzm%mzm,muzm%mzm,fmdiv_cim%mzm) END FUNCTION fmdiv_cim FUNCTION fmdiv_czm(c,ma) ! .. Function Return Value .. TYPE (zm) :: fmdiv_czm ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmcmpx, zmdiv ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmdiv(mtzm%mzm,ma%mzm,fmdiv_czm%mzm) END FUNCTION fmdiv_czm FUNCTION fmdiv_fmi(ma,ival) ! .. Function Return Value .. TYPE (fm) :: fmdiv_fmi ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmdivi ! .. CALL fmdivi(ma%mfm,ival,fmdiv_fmi%mfm) END FUNCTION fmdiv_fmi FUNCTION fmdiv_fmr(ma,r) ! .. Function Return Value .. TYPE (fm) :: fmdiv_fmr ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmdiv, fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmdiv(ma%mfm,mtfm%mfm,fmdiv_fmr%mfm) END FUNCTION fmdiv_fmr FUNCTION fmdiv_fmd(ma,d) ! .. Function Return Value .. TYPE (fm) :: fmdiv_fmd ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdiv, fmdp2m ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmdiv(ma%mfm,mtfm%mfm,fmdiv_fmd%mfm) END FUNCTION fmdiv_fmd FUNCTION fmdiv_fmz(ma,z) ! .. Function Return Value .. TYPE (zm) :: fmdiv_fmz ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmdiv, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmdiv(muzm%mzm,mtzm%mzm,fmdiv_fmz%mzm) END FUNCTION fmdiv_fmz FUNCTION fmdiv_fmc(ma,c) ! .. Function Return Value .. TYPE (zm) :: fmdiv_fmc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmdiv ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmdiv(muzm%mzm,mtzm%mzm,fmdiv_fmc%mzm) END FUNCTION fmdiv_fmc FUNCTION fmdiv_fmfm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmdiv_fmfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL fmdiv ! .. CALL fmdiv(ma%mfm,mb%mfm,fmdiv_fmfm%mfm) END FUNCTION fmdiv_fmfm FUNCTION fmdiv_fmim(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmdiv_fmim ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmdiv, imi2fm ! .. CALL imi2fm(mb%mim,mtfm%mfm) CALL fmdiv(ma%mfm,mtfm%mfm,fmdiv_fmim%mfm) END FUNCTION fmdiv_fmim FUNCTION fmdiv_fmzm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmdiv_fmzm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmdiv ! .. CALL fmi2m(0,mtfm%mfm) CALL zmcmpx(ma%mfm,mtfm%mfm,mtzm%mzm) CALL zmdiv(mtzm%mzm,mb%mzm,fmdiv_fmzm%mzm) END FUNCTION fmdiv_fmzm FUNCTION fmdiv_imi(ma,ival) ! .. Function Return Value .. TYPE (im) :: fmdiv_imi ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL imdivi ! .. CALL imdivi(ma%mim,ival,fmdiv_imi%mim) END FUNCTION fmdiv_imi FUNCTION fmdiv_imr(ma,r) ! .. Function Return Value .. TYPE (fm) :: fmdiv_imr ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmdiv, fmsp2m, imi2fm ! .. CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmdiv(mufm%mfm,mtfm%mfm,fmdiv_imr%mfm) END FUNCTION fmdiv_imr FUNCTION fmdiv_imd(ma,d) ! .. Function Return Value .. TYPE (fm) :: fmdiv_imd ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdiv, fmdp2m, imi2fm ! .. CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmdiv(mufm%mfm,mtfm%mfm,fmdiv_imd%mfm) END FUNCTION fmdiv_imd FUNCTION fmdiv_imz(ma,z) ! .. Function Return Value .. TYPE (zm) :: fmdiv_imz ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmdiv, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmdiv(muzm%mzm,mtzm%mzm,fmdiv_imz%mzm) END FUNCTION fmdiv_imz FUNCTION fmdiv_imc(ma,c) ! .. Function Return Value .. TYPE (zm) :: fmdiv_imc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, imi2fm, zmcmpx, zmdiv ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmdiv(muzm%mzm,mtzm%mzm,fmdiv_imc%mzm) END FUNCTION fmdiv_imc FUNCTION fmdiv_imfm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmdiv_imfm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmdiv, imi2fm ! .. CALL imi2fm(ma%mim,mtfm%mfm) CALL fmdiv(mtfm%mfm,mb%mfm,fmdiv_imfm%mfm) END FUNCTION fmdiv_imfm FUNCTION fmdiv_imim(ma,mb) ! .. Function Return Value .. TYPE (im) :: fmdiv_imim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL imdiv ! .. CALL imdiv(ma%mim,mb%mim,fmdiv_imim%mim) END FUNCTION fmdiv_imim FUNCTION fmdiv_imzm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmdiv_imzm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmdiv ! .. CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmdiv(muzm%mzm,mb%mzm,fmdiv_imzm%mzm) END FUNCTION fmdiv_imzm FUNCTION fmdiv_zmi(ma,ival) ! .. Function Return Value .. TYPE (zm) :: fmdiv_zmi ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL zmdivi ! .. CALL zmdivi(ma%mzm,ival,fmdiv_zmi%mzm) END FUNCTION fmdiv_zmi FUNCTION fmdiv_zmr(ma,r) ! .. Function Return Value .. TYPE (zm) :: fmdiv_zmr ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsp2m, zmcmpx, zmdiv ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmdiv(ma%mzm,mtzm%mzm,fmdiv_zmr%mzm) END FUNCTION fmdiv_zmr FUNCTION fmdiv_zmd(ma,d) ! .. Function Return Value .. TYPE (zm) :: fmdiv_zmd ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmdiv ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmdiv(ma%mzm,mtzm%mzm,fmdiv_zmd%mzm) END FUNCTION fmdiv_zmd FUNCTION fmdiv_zmz(ma,z) ! .. Function Return Value .. TYPE (zm) :: fmdiv_zmz ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL zmdiv, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL zmdiv(ma%mzm,mtzm%mzm,fmdiv_zmz%mzm) END FUNCTION fmdiv_zmz FUNCTION fmdiv_zmc(ma,c) ! .. Function Return Value .. TYPE (zm) :: fmdiv_zmc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmcmpx, zmdiv ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmdiv(ma%mzm,mtzm%mzm,fmdiv_zmc%mzm) END FUNCTION fmdiv_zmc FUNCTION fmdiv_zmfm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmdiv_zmfm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmdiv ! .. CALL fmi2m(0,mtfm%mfm) CALL zmcmpx(mb%mfm,mtfm%mfm,mtzm%mzm) CALL zmdiv(ma%mzm,mtzm%mzm,fmdiv_zmfm%mzm) END FUNCTION fmdiv_zmfm FUNCTION fmdiv_zmim(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmdiv_zmim ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmdiv ! .. CALL imi2fm(mb%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmdiv(ma%mzm,muzm%mzm,fmdiv_zmim%mzm) END FUNCTION fmdiv_zmim FUNCTION fmdiv_zmzm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmdiv_zmzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL zmdiv ! .. CALL zmdiv(ma%mzm,mb%mzm,fmdiv_zmzm%mzm) END FUNCTION fmdiv_zmzm ! ** FUNCTION fmpwr_ifm(ival,ma) ! .. Function Return Value .. TYPE (fm) :: fmpwr_ifm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmpwr ! .. CALL fmi2m(ival,mtfm%mfm) CALL fmpwr(mtfm%mfm,ma%mfm,fmpwr_ifm%mfm) END FUNCTION fmpwr_ifm FUNCTION fmpwr_iim(ival,ma) ! .. Function Return Value .. TYPE (im) :: fmpwr_iim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL imi2m, impwr ! .. CALL imi2m(ival,mtim%mim) CALL impwr(mtim%mim,ma%mim,fmpwr_iim%mim) END FUNCTION fmpwr_iim FUNCTION fmpwr_izm(ival,ma) ! .. Function Return Value .. TYPE (zm) :: fmpwr_izm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmpwr ! .. CALL fmi2m(ival,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmpwr(mtzm%mzm,ma%mzm,fmpwr_izm%mzm) END FUNCTION fmpwr_izm FUNCTION fmpwr_rfm(r,ma) ! .. Function Return Value .. TYPE (fm) :: fmpwr_rfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmpwr, fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmpwr(mtfm%mfm,ma%mfm,fmpwr_rfm%mfm) END FUNCTION fmpwr_rfm FUNCTION fmpwr_rim(r,ma) ! .. Function Return Value .. TYPE (fm) :: fmpwr_rim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmpwr, fmsp2m, imi2fm ! .. CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmpwr(mtfm%mfm,mufm%mfm,fmpwr_rim%mfm) END FUNCTION fmpwr_rim FUNCTION fmpwr_rzm(r,ma) ! .. Function Return Value .. TYPE (zm) :: fmpwr_rzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsp2m, zmcmpx, zmpwr ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmpwr(mtzm%mzm,ma%mzm,fmpwr_rzm%mzm) END FUNCTION fmpwr_rzm FUNCTION fmpwr_dfm(d,ma) ! .. Function Return Value .. TYPE (fm) :: fmpwr_dfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmpwr ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmpwr(mtfm%mfm,ma%mfm,fmpwr_dfm%mfm) END FUNCTION fmpwr_dfm FUNCTION fmpwr_dim(d,ma) ! .. Function Return Value .. TYPE (fm) :: fmpwr_dim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmpwr, imi2fm ! .. CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmpwr(mtfm%mfm,mufm%mfm,fmpwr_dim%mfm) END FUNCTION fmpwr_dim FUNCTION fmpwr_dzm(d,ma) ! .. Function Return Value .. TYPE (zm) :: fmpwr_dzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmpwr ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmpwr(mtzm%mzm,ma%mzm,fmpwr_dzm%mzm) END FUNCTION fmpwr_dzm FUNCTION fmpwr_zfm(z,ma) ! .. Function Return Value .. TYPE (zm) :: fmpwr_zfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmpwr, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmpwr(mtzm%mzm,muzm%mzm,fmpwr_zfm%mzm) END FUNCTION fmpwr_zfm FUNCTION fmpwr_zim(z,ma) ! .. Function Return Value .. TYPE (zm) :: fmpwr_zim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmpwr, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmpwr(mtzm%mzm,muzm%mzm,fmpwr_zim%mzm) END FUNCTION fmpwr_zim FUNCTION fmpwr_zzm(z,ma) ! .. Function Return Value .. TYPE (zm) :: fmpwr_zzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL zmpwr, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL zmpwr(mtzm%mzm,ma%mzm,fmpwr_zzm%mzm) END FUNCTION fmpwr_zzm FUNCTION fmpwr_cfm(c,ma) ! .. Function Return Value .. TYPE (zm) :: fmpwr_cfm ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmpwr ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmpwr(mtzm%mzm,muzm%mzm,fmpwr_cfm%mzm) END FUNCTION fmpwr_cfm FUNCTION fmpwr_cim(c,ma) ! .. Function Return Value .. TYPE (zm) :: fmpwr_cim ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, imi2fm, zmcmpx, zmpwr ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmpwr(mtzm%mzm,muzm%mzm,fmpwr_cim%mzm) END FUNCTION fmpwr_cim FUNCTION fmpwr_czm(c,ma) ! .. Function Return Value .. TYPE (zm) :: fmpwr_czm ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmcmpx, zmpwr ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmpwr(mtzm%mzm,ma%mzm,fmpwr_czm%mzm) END FUNCTION fmpwr_czm FUNCTION fmpwr_fmi(ma,ival) ! .. Function Return Value .. TYPE (fm) :: fmpwr_fmi ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL fmipwr ! .. CALL fmipwr(ma%mfm,ival,fmpwr_fmi%mfm) END FUNCTION fmpwr_fmi FUNCTION fmpwr_fmr(ma,r) ! .. Function Return Value .. TYPE (fm) :: fmpwr_fmr ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmpwr, fmsp2m ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmpwr(ma%mfm,mtfm%mfm,fmpwr_fmr%mfm) END FUNCTION fmpwr_fmr FUNCTION fmpwr_fmd(ma,d) ! .. Function Return Value .. TYPE (fm) :: fmpwr_fmd ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmpwr ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmpwr(ma%mfm,mtfm%mfm,fmpwr_fmd%mfm) END FUNCTION fmpwr_fmd FUNCTION fmpwr_fmz(ma,z) ! .. Function Return Value .. TYPE (zm) :: fmpwr_fmz ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmpwr, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmpwr(muzm%mzm,mtzm%mzm,fmpwr_fmz%mzm) END FUNCTION fmpwr_fmz FUNCTION fmpwr_fmc(ma,c) ! .. Function Return Value .. TYPE (zm) :: fmpwr_fmc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmpwr ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(ma%mfm,mufm%mfm,muzm%mzm) CALL zmpwr(muzm%mzm,mtzm%mzm,fmpwr_fmc%mzm) END FUNCTION fmpwr_fmc FUNCTION fmpwr_fmfm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmpwr_fmfm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL fmpwr ! .. CALL fmpwr(ma%mfm,mb%mfm,fmpwr_fmfm%mfm) END FUNCTION fmpwr_fmfm FUNCTION fmpwr_fmim(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmpwr_fmim ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmpwr, imi2fm ! .. CALL imi2fm(mb%mim,mtfm%mfm) CALL fmpwr(ma%mfm,mtfm%mfm,fmpwr_fmim%mfm) END FUNCTION fmpwr_fmim FUNCTION fmpwr_fmzm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmpwr_fmzm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmpwr ! .. CALL fmi2m(0,mtfm%mfm) CALL zmcmpx(ma%mfm,mtfm%mfm,mtzm%mzm) CALL zmpwr(mtzm%mzm,mb%mzm,fmpwr_fmzm%mzm) END FUNCTION fmpwr_fmzm FUNCTION fmpwr_imi(ma,ival) ! .. Function Return Value .. TYPE (im) :: fmpwr_imi ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL imi2m, impwr ! .. CALL imi2m(ival,mtim%mim) CALL impwr(ma%mim,mtim%mim,fmpwr_imi%mim) END FUNCTION fmpwr_imi FUNCTION fmpwr_imr(ma,r) ! .. Function Return Value .. TYPE (fm) :: fmpwr_imr ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmpwr, fmsp2m, imi2fm ! .. CALL fmsp2m(r,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmpwr(mufm%mfm,mtfm%mfm,fmpwr_imr%mfm) END FUNCTION fmpwr_imr FUNCTION fmpwr_imd(ma,d) ! .. Function Return Value .. TYPE (fm) :: fmpwr_imd ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmpwr, imi2fm ! .. CALL fmdp2m(d,mtfm%mfm) CALL imi2fm(ma%mim,mufm%mfm) CALL fmpwr(mufm%mfm,mtfm%mfm,fmpwr_imd%mfm) END FUNCTION fmpwr_imd FUNCTION fmpwr_imz(ma,z) ! .. Function Return Value .. TYPE (zm) :: fmpwr_imz ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmpwr, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmpwr(muzm%mzm,mtzm%mzm,fmpwr_imz%mzm) END FUNCTION fmpwr_imz FUNCTION fmpwr_imc(ma,c) ! .. Function Return Value .. TYPE (zm) :: fmpwr_imc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, imi2fm, zmcmpx, zmpwr ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmpwr(muzm%mzm,mtzm%mzm,fmpwr_imc%mzm) END FUNCTION fmpwr_imc FUNCTION fmpwr_imfm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmpwr_imfm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmpwr, imi2fm ! .. CALL imi2fm(ma%mim,mtfm%mfm) CALL fmpwr(mtfm%mfm,mb%mfm,fmpwr_imfm%mfm) END FUNCTION fmpwr_imfm FUNCTION fmpwr_imim(ma,mb) ! .. Function Return Value .. TYPE (im) :: fmpwr_imim ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL impwr ! .. CALL impwr(ma%mim,mb%mim,fmpwr_imim%mim) END FUNCTION fmpwr_imim FUNCTION fmpwr_imzm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmpwr_imzm ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (zm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmpwr ! .. CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmpwr(muzm%mzm,mb%mzm,fmpwr_imzm%mzm) END FUNCTION fmpwr_imzm FUNCTION fmpwr_zmi(ma,ival) ! .. Function Return Value .. TYPE (zm) :: fmpwr_zmi ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ival ! .. ! .. External Subroutines .. EXTERNAL zmipwr ! .. CALL zmipwr(ma%mzm,ival,fmpwr_zmi%mzm) END FUNCTION fmpwr_zmi FUNCTION fmpwr_zmr(ma,r) ! .. Function Return Value .. TYPE (zm) :: fmpwr_zmr ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL, INTENT (IN) :: r ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmsp2m, zmcmpx, zmpwr ! .. CALL fmsp2m(r,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmpwr(ma%mzm,mtzm%mzm,fmpwr_zmr%mzm) END FUNCTION fmpwr_zmr FUNCTION fmpwr_zmd(ma,d) ! .. Function Return Value .. TYPE (zm) :: fmpwr_zmd ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. REAL (kind(0.0D0)), INTENT (IN) :: d ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, fmi2m, zmcmpx, zmpwr ! .. CALL fmdp2m(d,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmpwr(ma%mzm,mtzm%mzm,fmpwr_zmd%mzm) END FUNCTION fmpwr_zmd FUNCTION fmpwr_zmz(ma,z) ! .. Function Return Value .. TYPE (zm) :: fmpwr_zmz ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX, INTENT (IN) :: z ! .. ! .. External Subroutines .. EXTERNAL zmpwr, zmz2m ! .. CALL zmz2m(z,mtzm%mzm) CALL zmpwr(ma%mzm,mtzm%mzm,fmpwr_zmz%mzm) END FUNCTION fmpwr_zmz FUNCTION fmpwr_zmc(ma,c) ! .. Function Return Value .. TYPE (zm) :: fmpwr_zmc ! .. ! .. Intrinsic Functions .. INTRINSIC kind ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. COMPLEX (kind(0.0D0)), INTENT (IN) :: c ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmcmpx, zmpwr ! .. CALL fmdp2m(real(c,kind(0.0D0)),mtfm%mfm) CALL fmdp2m(aimag(c),mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,mtzm%mzm) CALL zmpwr(ma%mzm,mtzm%mzm,fmpwr_zmc%mzm) END FUNCTION fmpwr_zmc FUNCTION fmpwr_zmfm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmpwr_zmfm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma TYPE (fm), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx, zmpwr ! .. CALL fmi2m(0,mtfm%mfm) CALL zmcmpx(mb%mfm,mtfm%mfm,mtzm%mzm) CALL zmpwr(ma%mzm,mtzm%mzm,fmpwr_zmfm%mzm) END FUNCTION fmpwr_zmfm FUNCTION fmpwr_zmim(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmpwr_zmim ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma TYPE (im), INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx, zmpwr ! .. CALL imi2fm(mb%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,muzm%mzm) CALL zmpwr(ma%mzm,muzm%mzm,fmpwr_zmim%mzm) END FUNCTION fmpwr_zmim FUNCTION fmpwr_zmzm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmpwr_zmzm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL zmpwr ! .. CALL zmpwr(ma%mzm,mb%mzm,fmpwr_zmzm%mzm) END FUNCTION fmpwr_zmzm ! ABS FUNCTION fmabs_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmabs_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmabs ! .. CALL fmabs(ma%mfm,fmabs_fm%mfm) END FUNCTION fmabs_fm FUNCTION fmabs_im(ma) ! .. Function Return Value .. TYPE (im) :: fmabs_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL imabs ! .. CALL imabs(ma%mim,fmabs_im%mim) END FUNCTION fmabs_im FUNCTION fmabs_zm(ma) ! .. Function Return Value .. TYPE (fm) :: fmabs_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmabs ! .. CALL zmabs(ma%mzm,fmabs_zm%mfm) END FUNCTION fmabs_zm ! ACOS FUNCTION fmacos_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmacos_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmacos ! .. CALL fmacos(ma%mfm,fmacos_fm%mfm) END FUNCTION fmacos_fm FUNCTION fmacos_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmacos_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmacos ! .. CALL zmacos(ma%mzm,fmacos_zm%mzm) END FUNCTION fmacos_zm ! AIMAG FUNCTION fmaimag_zm(ma) ! .. Function Return Value .. TYPE (fm) :: fmaimag_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmimag ! .. CALL zmimag(ma%mzm,fmaimag_zm%mfm) END FUNCTION fmaimag_zm ! AINT FUNCTION fmaint_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmaint_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmint ! .. CALL fmint(ma%mfm,fmaint_fm%mfm) END FUNCTION fmaint_fm FUNCTION fmaint_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmaint_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmint ! .. CALL zmint(ma%mzm,fmaint_zm%mzm) END FUNCTION fmaint_zm ! ANINT FUNCTION fmanint_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmanint_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmnint ! .. CALL fmnint(ma%mfm,fmanint_fm%mfm) END FUNCTION fmanint_fm FUNCTION fmanint_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmanint_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmnint ! .. CALL zmnint(ma%mzm,fmanint_zm%mzm) END FUNCTION fmanint_zm ! ASIN FUNCTION fmasin_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmasin_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmasin ! .. CALL fmasin(ma%mfm,fmasin_fm%mfm) END FUNCTION fmasin_fm FUNCTION fmasin_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmasin_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmasin ! .. CALL zmasin(ma%mzm,fmasin_zm%mzm) END FUNCTION fmasin_zm ! ATAN FUNCTION fmatan_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmatan_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmatan ! .. CALL fmatan(ma%mfm,fmatan_fm%mfm) END FUNCTION fmatan_fm FUNCTION fmatan_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmatan_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmatan ! .. CALL zmatan(ma%mzm,fmatan_zm%mzm) END FUNCTION fmatan_zm ! ATAN2 FUNCTION fmatan2_fm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmatan2_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL fmatn2 ! .. CALL fmatn2(ma%mfm,mb%mfm,fmatan2_fm%mfm) END FUNCTION fmatan2_fm ! BTEST FUNCTION fmbtest_im(ma,pos) ! .. Function Return Value .. LOGICAL :: fmbtest_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: pos ! .. ! .. External Subroutines .. EXTERNAL imabs, imdiv, imi2m, immod, impwr ! .. CALL imi2m(2,mtim%mim) CALL imi2m(pos,muim%mim) CALL impwr(mtim%mim,muim%mim,muim%mim) CALL imdiv(ma%mim,muim%mim,muim%mim) CALL imabs(muim%mim,muim%mim) CALL immod(muim%mim,mtim%mim,muim%mim) IF (muim%mim(2)==0) THEN fmbtest_im = .FALSE. ELSE fmbtest_im = .TRUE. END IF END FUNCTION fmbtest_im ! CEILING FUNCTION fmceiling_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmceiling_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmaddi, fmeq, fmint, fmsub ! .. CALL fmint(ma%mfm,mtfm%mfm) CALL fmsub(ma%mfm,mtfm%mfm,mufm%mfm) IF (mufm%mfm(2)==0) THEN CALL fmeq(ma%mfm,fmceiling_fm%mfm) ELSE IF (ma%mfm(2)>0) THEN CALL fmaddi(mtfm%mfm,1) CALL fmeq(mtfm%mfm,fmceiling_fm%mfm) ELSE CALL fmeq(mtfm%mfm,fmceiling_fm%mfm) END IF END FUNCTION fmceiling_fm FUNCTION fmceiling_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmceiling_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmcmpx ! .. mtzm = ceiling(real(ma)) mufm = ceiling(aimag(ma)) mtfm = real(mtzm) CALL zmcmpx(mtfm%mfm,mufm%mfm,fmceiling_zm%mzm) END FUNCTION fmceiling_zm ! CMPLX FUNCTION fmcmplx_fm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmcmplx_fm ! .. ! .. Intrinsic Functions .. INTRINSIC present ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma TYPE (fm), OPTIONAL, INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmcmpx ! .. IF (present(mb)) THEN CALL zmcmpx(ma%mfm,mb%mfm,fmcmplx_fm%mzm) ELSE CALL fmi2m(0,mtfm%mfm) CALL zmcmpx(ma%mfm,mtfm%mfm,fmcmplx_fm%mzm) END IF END FUNCTION fmcmplx_fm FUNCTION fmcmplx_im(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmcmplx_im ! .. ! .. Intrinsic Functions .. INTRINSIC present ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma TYPE (im), OPTIONAL, INTENT (IN) :: mb ! .. ! .. External Subroutines .. EXTERNAL fmi2m, imi2fm, zmcmpx ! .. IF (present(mb)) THEN CALL imi2fm(ma%mim,mtfm%mfm) CALL imi2fm(mb%mim,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,fmcmplx_im%mzm) ELSE CALL imi2fm(ma%mim,mtfm%mfm) CALL fmi2m(0,mufm%mfm) CALL zmcmpx(mtfm%mfm,mufm%mfm,fmcmplx_im%mzm) END IF END FUNCTION fmcmplx_im ! CONJG FUNCTION fmconjg_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmconjg_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmconj ! .. CALL zmconj(ma%mzm,fmconjg_zm%mzm) END FUNCTION fmconjg_zm ! COS FUNCTION fmcos_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmcos_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmcos ! .. CALL fmcos(ma%mfm,fmcos_fm%mfm) END FUNCTION fmcos_fm FUNCTION fmcos_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmcos_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmcos ! .. CALL zmcos(ma%mzm,fmcos_zm%mzm) END FUNCTION fmcos_zm ! COSH FUNCTION fmcosh_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmcosh_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmcosh ! .. CALL fmcosh(ma%mfm,fmcosh_fm%mfm) END FUNCTION fmcosh_fm FUNCTION fmcosh_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmcosh_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmcosh ! .. CALL zmcosh(ma%mzm,fmcosh_zm%mzm) END FUNCTION fmcosh_zm ! DBLE FUNCTION fmdble_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmdble_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmeq ! .. CALL fmeq(ma%mfm,fmdble_fm%mfm) END FUNCTION fmdble_fm FUNCTION fmdble_im(ma) ! .. Function Return Value .. TYPE (fm) :: fmdble_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL imi2fm ! .. CALL imi2fm(ma%mim,fmdble_im%mfm) END FUNCTION fmdble_im FUNCTION fmdble_zm(ma) ! .. Function Return Value .. TYPE (fm) :: fmdble_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmreal ! .. CALL zmreal(ma%mzm,fmdble_zm%mfm) END FUNCTION fmdble_zm ! DIGITS FUNCTION fmdigits_fm(ma) ! .. Function Return Value .. INTEGER :: fmdigits_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. fmdigits_fm = ndig END FUNCTION fmdigits_fm FUNCTION fmdigits_im(ma) ! .. Function Return Value .. INTEGER :: fmdigits_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. fmdigits_im = ndigmx END FUNCTION fmdigits_im FUNCTION fmdigits_zm(ma) ! .. Function Return Value .. INTEGER :: fmdigits_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. fmdigits_zm = ndig END FUNCTION fmdigits_zm ! DIM FUNCTION fmdim_fm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmdim_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL fmdim ! .. CALL fmdim(ma%mfm,mb%mfm,fmdim_fm%mfm) END FUNCTION fmdim_fm FUNCTION fmdim_im(ma,mb) ! .. Function Return Value .. TYPE (im) :: fmdim_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL imdim ! .. CALL imdim(ma%mim,mb%mim,fmdim_im%mim) END FUNCTION fmdim_im ! DINT FUNCTION fmdint_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmdint_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmint ! .. CALL fmint(ma%mfm,fmdint_fm%mfm) END FUNCTION fmdint_fm FUNCTION fmdint_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmdint_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmint ! .. CALL zmint(ma%mzm,fmdint_zm%mzm) END FUNCTION fmdint_zm ! DOTPRODUCT FUNCTION fmdotproduct_fm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmdotproduct_fm ! .. ! .. Intrinsic Functions .. INTRINSIC lbound, size ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma(:), mb(:) ! .. ! .. Local Scalars .. INTEGER :: j, ja, jb ! .. ! .. External Subroutines .. EXTERNAL fmdiv, fmeq ! .. IF (size(ma)==size(mb)) THEN mtfm = 0 DO j = 1, size(ma) ja = lbound(ma,dim=1) + j - 1 jb = lbound(mb,dim=1) + j - 1 mtfm = mtfm + ma(ja)*mb(jb) END DO CALL fmeq(mtfm%mfm,fmdotproduct_fm%mfm) ELSE mtfm = 1 mufm = 0 CALL fmdiv(mtfm%mfm,mufm%mfm,fmdotproduct_fm%mfm) END IF END FUNCTION fmdotproduct_fm FUNCTION fmdotproduct_im(ma,mb) ! .. Function Return Value .. TYPE (im) :: fmdotproduct_im ! .. ! .. Intrinsic Functions .. INTRINSIC lbound, size ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma(:), mb(:) ! .. ! .. Local Scalars .. INTEGER :: j, ja, jb ! .. ! .. External Subroutines .. EXTERNAL imdiv, imeq ! .. IF (size(ma)==size(mb)) THEN mtim = 0 DO j = 1, size(ma) ja = lbound(ma,dim=1) + j - 1 jb = lbound(mb,dim=1) + j - 1 mtim = mtim + ma(ja)*mb(jb) END DO CALL imeq(mtim%mim,fmdotproduct_im%mim) ELSE mtim = 1 muim = 0 CALL imdiv(mtim%mim,muim%mim,fmdotproduct_im%mim) END IF END FUNCTION fmdotproduct_im FUNCTION fmdotproduct_zm(ma,mb) ! .. Function Return Value .. TYPE (zm) :: fmdotproduct_zm ! .. ! .. Intrinsic Functions .. INTRINSIC lbound, size ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma(:), mb(:) ! .. ! .. Local Scalars .. INTEGER :: j, ja, jb ! .. ! .. External Subroutines .. EXTERNAL zmdiv, zmeq ! .. IF (size(ma)==size(mb)) THEN mtzm = 0 DO j = 1, size(ma) ja = lbound(ma,dim=1) + j - 1 jb = lbound(mb,dim=1) + j - 1 mtzm = mtzm + ma(ja)*mb(jb) END DO CALL zmeq(mtzm%mzm,fmdotproduct_zm%mzm) ELSE mtzm = 1 muzm = 0 CALL zmdiv(mtzm%mzm,muzm%mzm,fmdotproduct_zm%mzm) END IF END FUNCTION fmdotproduct_zm ! EPSILON FUNCTION fmepsilon_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmepsilon_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmi2m, fmulp ! .. CALL fmi2m(1,mtfm%mfm) CALL fmulp(mtfm%mfm,fmepsilon_fm%mfm) END FUNCTION fmepsilon_fm ! EXP FUNCTION fmexp_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmexp_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmexp ! .. CALL fmexp(ma%mfm,fmexp_fm%mfm) END FUNCTION fmexp_fm FUNCTION fmexp_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmexp_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmexp ! .. CALL zmexp(ma%mzm,fmexp_zm%mzm) END FUNCTION fmexp_zm ! EXPONENT FUNCTION fmexponent_fm(ma) ! .. Function Return Value .. INTEGER :: fmexponent_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. fmexponent_fm = int(ma%mfm(1)) END FUNCTION fmexponent_fm ! FLOOR FUNCTION fmfloor_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmfloor_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmaddi, fmeq, fmint, fmsub ! .. CALL fmint(ma%mfm,mtfm%mfm) CALL fmsub(ma%mfm,mtfm%mfm,mufm%mfm) IF (mufm%mfm(2)==0) THEN CALL fmeq(ma%mfm,fmfloor_fm%mfm) ELSE IF (ma%mfm(2)<0) THEN CALL fmaddi(mtfm%mfm,-1) CALL fmeq(mtfm%mfm,fmfloor_fm%mfm) ELSE CALL fmeq(mtfm%mfm,fmfloor_fm%mfm) END IF END FUNCTION fmfloor_fm FUNCTION fmfloor_im(ma) ! .. Function Return Value .. TYPE (im) :: fmfloor_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL imeq ! .. CALL imeq(ma%mim,fmfloor_im%mim) END FUNCTION fmfloor_im FUNCTION fmfloor_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmfloor_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmcmpx ! .. mtzm = floor(real(ma)) mufm = floor(aimag(ma)) mtfm = real(mtzm) CALL zmcmpx(mtfm%mfm,mufm%mfm,fmfloor_zm%mzm) END FUNCTION fmfloor_zm ! FRACTION FUNCTION fmfraction_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmfraction_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmeq ! .. CALL fmeq(ma%mfm,mtfm%mfm) mtfm%mfm(1) = 0 CALL fmeq(mtfm%mfm,fmfraction_fm%mfm) END FUNCTION fmfraction_fm FUNCTION fmfraction_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmfraction_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmeq ! .. CALL zmeq(ma%mzm,mtzm%mzm) mtzm%mzm(1) = 0 mtzm%mzm(kptimu+1) = 0 CALL zmeq(mtzm%mzm,fmfraction_zm%mzm) END FUNCTION fmfraction_zm ! HUGE FUNCTION fmhuge_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmhuge_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmbig ! .. CALL fmbig(fmhuge_fm%mfm) END FUNCTION fmhuge_fm FUNCTION fmhuge_im(ma) ! .. Function Return Value .. TYPE (im) :: fmhuge_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL imbig ! .. CALL imbig(fmhuge_im%mim) END FUNCTION fmhuge_im FUNCTION fmhuge_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmhuge_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmbig, zmcmpx ! .. CALL fmbig(mtfm%mfm) CALL zmcmpx(mtfm%mfm,mtfm%mfm,fmhuge_zm%mzm) END FUNCTION fmhuge_zm ! INT FUNCTION fmint_fm(ma) ! .. Function Return Value .. TYPE (im) :: fmint_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmint, imfm2i ! .. CALL fmint(ma%mfm,mtfm%mfm) CALL imfm2i(mtfm%mfm,fmint_fm%mim) END FUNCTION fmint_fm FUNCTION fmint_im(ma) ! .. Function Return Value .. TYPE (im) :: fmint_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL imeq ! .. CALL imeq(ma%mim,fmint_im%mim) END FUNCTION fmint_im FUNCTION fmint_zm(ma) ! .. Function Return Value .. TYPE (im) :: fmint_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmint, imfm2i, zmreal ! .. CALL zmreal(ma%mzm,mtfm%mfm) CALL fmint(mtfm%mfm,mtfm%mfm) CALL imfm2i(mtfm%mfm,fmint_zm%mim) END FUNCTION fmint_zm ! LOG FUNCTION fmlog_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmlog_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmln ! .. CALL fmln(ma%mfm,fmlog_fm%mfm) END FUNCTION fmlog_fm FUNCTION fmlog_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmlog_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmln ! .. CALL zmln(ma%mzm,fmlog_zm%mzm) END FUNCTION fmlog_zm ! LOG10 FUNCTION fmlog10_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmlog10_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmlg10 ! .. CALL fmlg10(ma%mfm,fmlog10_fm%mfm) END FUNCTION fmlog10_fm FUNCTION fmlog10_zm(ma) ! .. Function Return Value .. TYPE (zm) :: fmlog10_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmlg10 ! .. CALL zmlg10(ma%mzm,fmlog10_zm%mzm) END FUNCTION fmlog10_zm ! MATMUL FUNCTION fmmatmul_fm(ma,mb) RESULT (mc) ! .. Intrinsic Functions .. INTRINSIC lbound, size, ubound ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma(:,:), mb(:,:) ! .. ! .. Local Scalars .. INTEGER :: i, j, k ! .. ! .. Function Return Value .. TYPE (fm) :: mc(size(ma,dim=1),size(mb,dim=2)) ! .. IF (size(ma,dim=2)==size(mb,dim=1)) THEN DO i = lbound(ma,dim=1), ubound(ma,dim=1) DO j = lbound(mb,dim=2), ubound(mb,dim=2) mtfm = 0 DO k = lbound(ma,dim=2), ubound(ma,dim=2) mtfm = mtfm + ma(i,k)*mb(k,j) END DO mc(i,j) = mtfm END DO END DO ELSE mtfm = 1 mufm = 0 mc(1,1) = mtfm/mufm DO i = 1, size(ma,dim=1) DO j = 1, size(mb,dim=2) mc(i,j) = mc(1,1) END DO END DO END IF END FUNCTION fmmatmul_fm FUNCTION fmmatmul_im(ma,mb) RESULT (mc) ! .. Intrinsic Functions .. INTRINSIC lbound, size, ubound ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma(:,:), mb(:,:) ! .. ! .. Local Scalars .. INTEGER :: i, j, k ! .. ! .. Function Return Value .. TYPE (im) :: mc(size(ma,dim=1),size(mb,dim=2)) ! .. IF (size(ma,dim=2)==size(mb,dim=1)) THEN DO i = lbound(ma,dim=1), ubound(ma,dim=1) DO j = lbound(mb,dim=2), ubound(mb,dim=2) mtim = 0 DO k = lbound(ma,dim=2), ubound(ma,dim=2) mtim = mtim + ma(i,k)*mb(k,j) END DO mc(i,j) = mtim END DO END DO ELSE mtim = 1 muim = 0 mc(1,1) = mtim/muim DO i = 1, size(ma,dim=1) DO j = 1, size(mb,dim=2) mc(i,j) = mc(1,1) END DO END DO END IF END FUNCTION fmmatmul_im FUNCTION fmmatmul_zm(ma,mb) RESULT (mc) ! .. Intrinsic Functions .. INTRINSIC lbound, size, ubound ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma(:,:), mb(:,:) ! .. ! .. Local Scalars .. INTEGER :: i, j, k ! .. ! .. Function Return Value .. TYPE (zm) :: mc(size(ma,dim=1),size(mb,dim=2)) ! .. IF (size(ma,dim=2)==size(mb,dim=1)) THEN DO i = lbound(ma,dim=1), ubound(ma,dim=1) DO j = lbound(mb,dim=2), ubound(mb,dim=2) mtzm = 0 DO k = lbound(ma,dim=2), ubound(ma,dim=2) mtzm = mtzm + ma(i,k)*mb(k,j) END DO mc(i,j) = mtzm END DO END DO ELSE mtzm = 1 muzm = 0 mc(1,1) = mtzm/muzm DO i = 1, size(ma,dim=1) DO j = 1, size(mb,dim=2) mc(i,j) = mc(1,1) END DO END DO END IF END FUNCTION fmmatmul_zm ! MAX FUNCTION fmmax_fm(ma,mb,mc,md,me,mf,mg,mh,mi,mj) ! .. Function Return Value .. TYPE (fm) :: fmmax_fm ! .. ! .. Intrinsic Functions .. INTRINSIC present ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb TYPE (fm), OPTIONAL, INTENT (IN) :: mc, md, me, mf, mg, mh, mi, mj ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmmax ! .. CALL fmmax(ma%mfm,mb%mfm,mtfm%mfm) IF (present(mc)) THEN CALL fmmax(mtfm%mfm,mc%mfm,mtfm%mfm) END IF IF (present(md)) THEN CALL fmmax(mtfm%mfm,md%mfm,mtfm%mfm) END IF IF (present(me)) THEN CALL fmmax(mtfm%mfm,me%mfm,mtfm%mfm) END IF IF (present(mf)) THEN CALL fmmax(mtfm%mfm,mf%mfm,mtfm%mfm) END IF IF (present(mg)) THEN CALL fmmax(mtfm%mfm,mg%mfm,mtfm%mfm) END IF IF (present(mh)) THEN CALL fmmax(mtfm%mfm,mh%mfm,mtfm%mfm) END IF IF (present(mi)) THEN CALL fmmax(mtfm%mfm,mi%mfm,mtfm%mfm) END IF IF (present(mj)) THEN CALL fmmax(mtfm%mfm,mj%mfm,mtfm%mfm) END IF CALL fmeq(mtfm%mfm,fmmax_fm%mfm) END FUNCTION fmmax_fm FUNCTION fmmax_im(ma,mb,mc,md,me,mf,mg,mh,mi,mj) ! .. Function Return Value .. TYPE (im) :: fmmax_im ! .. ! .. Intrinsic Functions .. INTRINSIC present ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb TYPE (im), OPTIONAL, INTENT (IN) :: mc, md, me, mf, mg, mh, mi, mj ! .. ! .. External Subroutines .. EXTERNAL imeq, immax ! .. CALL immax(ma%mim,mb%mim,mtim%mim) IF (present(mc)) THEN CALL immax(mtim%mim,mc%mim,mtim%mim) END IF IF (present(md)) THEN CALL immax(mtim%mim,md%mim,mtim%mim) END IF IF (present(me)) THEN CALL immax(mtim%mim,me%mim,mtim%mim) END IF IF (present(mf)) THEN CALL immax(mtim%mim,mf%mim,mtim%mim) END IF IF (present(mg)) THEN CALL immax(mtim%mim,mg%mim,mtim%mim) END IF IF (present(mh)) THEN CALL immax(mtim%mim,mh%mim,mtim%mim) END IF IF (present(mi)) THEN CALL immax(mtim%mim,mi%mim,mtim%mim) END IF IF (present(mj)) THEN CALL immax(mtim%mim,mj%mim,mtim%mim) END IF CALL imeq(mtim%mim,fmmax_im%mim) END FUNCTION fmmax_im ! MAXEXPONENT FUNCTION fmmaxexponent_fm(ma) ! .. Function Return Value .. INTEGER :: fmmaxexponent_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. fmmaxexponent_fm = int(mxexp) + 1 END FUNCTION fmmaxexponent_fm ! MIN FUNCTION fmmin_fm(ma,mb,mc,md,me,mf,mg,mh,mi,mj) ! .. Function Return Value .. TYPE (fm) :: fmmin_fm ! .. ! .. Intrinsic Functions .. INTRINSIC present ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb TYPE (fm), OPTIONAL, INTENT (IN) :: mc, md, me, mf, mg, mh, mi, mj ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmmin ! .. CALL fmmin(ma%mfm,mb%mfm,mtfm%mfm) IF (present(mc)) THEN CALL fmmin(mtfm%mfm,mc%mfm,mtfm%mfm) END IF IF (present(md)) THEN CALL fmmin(mtfm%mfm,md%mfm,mtfm%mfm) END IF IF (present(me)) THEN CALL fmmin(mtfm%mfm,me%mfm,mtfm%mfm) END IF IF (present(mf)) THEN CALL fmmin(mtfm%mfm,mf%mfm,mtfm%mfm) END IF IF (present(mg)) THEN CALL fmmin(mtfm%mfm,mg%mfm,mtfm%mfm) END IF IF (present(mh)) THEN CALL fmmin(mtfm%mfm,mh%mfm,mtfm%mfm) END IF IF (present(mi)) THEN CALL fmmin(mtfm%mfm,mi%mfm,mtfm%mfm) END IF IF (present(mj)) THEN CALL fmmin(mtfm%mfm,mj%mfm,mtfm%mfm) END IF CALL fmeq(mtfm%mfm,fmmin_fm%mfm) END FUNCTION fmmin_fm FUNCTION fmmin_im(ma,mb,mc,md,me,mf,mg,mh,mi,mj) ! .. Function Return Value .. TYPE (im) :: fmmin_im ! .. ! .. Intrinsic Functions .. INTRINSIC present ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb TYPE (im), OPTIONAL, INTENT (IN) :: mc, md, me, mf, mg, mh, mi, mj ! .. ! .. External Subroutines .. EXTERNAL imeq, immin ! .. CALL immin(ma%mim,mb%mim,mtim%mim) IF (present(mc)) THEN CALL immin(mtim%mim,mc%mim,mtim%mim) END IF IF (present(md)) THEN CALL immin(mtim%mim,md%mim,mtim%mim) END IF IF (present(me)) THEN CALL immin(mtim%mim,me%mim,mtim%mim) END IF IF (present(mf)) THEN CALL immin(mtim%mim,mf%mim,mtim%mim) END IF IF (present(mg)) THEN CALL immin(mtim%mim,mg%mim,mtim%mim) END IF IF (present(mh)) THEN CALL immin(mtim%mim,mh%mim,mtim%mim) END IF IF (present(mi)) THEN CALL immin(mtim%mim,mi%mim,mtim%mim) END IF IF (present(mj)) THEN CALL immin(mtim%mim,mj%mim,mtim%mim) END IF CALL imeq(mtim%mim,fmmin_im%mim) END FUNCTION fmmin_im ! MINEXPONENT FUNCTION fmminexponent_fm(ma) ! .. Function Return Value .. INTEGER :: fmminexponent_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. fmminexponent_fm = -int(mxexp) END FUNCTION fmminexponent_fm ! MOD FUNCTION fmmod_fm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmmod_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL fmmod ! .. CALL fmmod(ma%mfm,mb%mfm,fmmod_fm%mfm) END FUNCTION fmmod_fm FUNCTION fmmod_im(ma,mb) ! .. Function Return Value .. TYPE (im) :: fmmod_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL immod ! .. CALL immod(ma%mim,mb%mim,fmmod_im%mim) END FUNCTION fmmod_im ! MODULO FUNCTION fmmodulo_fm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmmodulo_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmeq, fmmod ! .. CALL fmmod(ma%mfm,mb%mfm,mtfm%mfm) IF (mtfm%mfm(2)/=0) THEN IF ((ma%mfm(2)>0 .AND. mb%mfm(2)<0) .OR. (ma%mfm(2)<0 .AND. mb%mfm( & 2)>0)) THEN CALL fmadd(mtfm%mfm,mb%mfm,mtfm%mfm) END IF END IF CALL fmeq(mtfm%mfm,fmmodulo_fm%mfm) END FUNCTION fmmodulo_fm FUNCTION fmmodulo_im(ma,mb) ! .. Function Return Value .. TYPE (im) :: fmmodulo_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma, mb ! .. ! .. External Subroutines .. EXTERNAL imadd, imeq, immod ! .. CALL immod(ma%mim,mb%mim,mtim%mim) IF (mtim%mim(2)/=0) THEN IF ((ma%mim(2)>0 .AND. mb%mim(2)<0) .OR. (ma%mim(2)<0 .AND. mb%mim( & 2)>0)) THEN CALL imadd(mtim%mim,mb%mim,mtim%mim) END IF END IF CALL imeq(mtim%mim,fmmodulo_im%mim) END FUNCTION fmmodulo_im ! NEAREST FUNCTION fmnearest_fm(ma,mb) ! .. Function Return Value .. TYPE (fm) :: fmnearest_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma, mb ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmabs, fmadd, fmbig, fmdiv, fmi2m, fmsub, fmulp ! .. IF (ma%mfm(2)==0) THEN IF (mb%mfm(2)>=0) THEN CALL fmbig(mtfm%mfm) CALL fmi2m(1,mufm%mfm) CALL fmdiv(mufm%mfm,mtfm%mfm,fmnearest_fm%mfm) ELSE CALL fmbig(mtfm%mfm) CALL fmi2m(-1,mufm%mfm) CALL fmdiv(mufm%mfm,mtfm%mfm,fmnearest_fm%mfm) END IF ELSE IF (mb%mfm(2)>=0) THEN CALL fmulp(ma%mfm,mtfm%mfm) CALL fmabs(mtfm%mfm,mtfm%mfm) CALL fmadd(ma%mfm,mtfm%mfm,mufm%mfm) CALL fmulp(mufm%mfm,mufm%mfm) CALL fmabs(mufm%mfm,mufm%mfm) IF (fmcomp(mtfm%mfm,'LE',mufm%mfm)) THEN CALL fmadd(ma%mfm,mtfm%mfm,fmnearest_fm%mfm) ELSE CALL fmadd(ma%mfm,mufm%mfm,fmnearest_fm%mfm) END IF ELSE CALL fmulp(ma%mfm,mtfm%mfm) CALL fmabs(mtfm%mfm,mtfm%mfm) CALL fmsub(ma%mfm,mtfm%mfm,mufm%mfm) CALL fmulp(mufm%mfm,mufm%mfm) CALL fmabs(mufm%mfm,mufm%mfm) IF (fmcomp(mtfm%mfm,'LE',mufm%mfm)) THEN CALL fmsub(ma%mfm,mtfm%mfm,fmnearest_fm%mfm) ELSE CALL fmsub(ma%mfm,mufm%mfm,fmnearest_fm%mfm) END IF END IF END IF END FUNCTION fmnearest_fm ! NINT FUNCTION fmnint_fm(ma) ! .. Function Return Value .. TYPE (im) :: fmnint_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmnint, imfm2i ! .. CALL fmnint(ma%mfm,mtfm%mfm) CALL imfm2i(mtfm%mfm,fmnint_fm%mim) END FUNCTION fmnint_fm FUNCTION fmnint_im(ma) ! .. Function Return Value .. TYPE (im) :: fmnint_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL imeq ! .. CALL imeq(ma%mim,fmnint_im%mim) END FUNCTION fmnint_im FUNCTION fmnint_zm(ma) ! .. Function Return Value .. TYPE (im) :: fmnint_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmnint, imfm2i, zmreal ! .. CALL zmreal(ma%mzm,mtfm%mfm) CALL fmnint(mtfm%mfm,mtfm%mfm) CALL imfm2i(mtfm%mfm,fmnint_zm%mim) END FUNCTION fmnint_zm ! PRECISION FUNCTION fmprecision_fm(ma) ! .. Function Return Value .. INTEGER :: fmprecision_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. fmprecision_fm = int(log10(real(mbase))*(ndig-1)+1) END FUNCTION fmprecision_fm FUNCTION fmprecision_zm(ma) ! .. Function Return Value .. INTEGER :: fmprecision_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. fmprecision_zm = int(log10(real(mbase))*(ndig-1)+1) END FUNCTION fmprecision_zm ! RADIX FUNCTION fmradix_fm(ma) ! .. Function Return Value .. INTEGER :: fmradix_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. fmradix_fm = int(mbase) END FUNCTION fmradix_fm FUNCTION fmradix_im(ma) ! .. Function Return Value .. INTEGER :: fmradix_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. fmradix_im = int(mbase) END FUNCTION fmradix_im FUNCTION fmradix_zm(ma) ! .. Function Return Value .. INTEGER :: fmradix_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. fmradix_zm = int(mbase) END FUNCTION fmradix_zm ! RANGE FUNCTION fmrange_fm(ma) ! .. Function Return Value .. INTEGER :: fmrange_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. fmrange_fm = int(mxexp*log10(real(mbase))) END FUNCTION fmrange_fm FUNCTION fmrange_im(ma) ! .. Function Return Value .. INTEGER :: fmrange_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. fmrange_im = int(ndigmx*log10(real(mbase))) END FUNCTION fmrange_im FUNCTION fmrange_zm(ma) ! .. Function Return Value .. INTEGER :: fmrange_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. fmrange_zm = int(mxexp*log10(real(mbase))) END FUNCTION fmrange_zm ! REAL FUNCTION fmreal_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmreal_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmeq ! .. CALL fmeq(ma%mfm,fmreal_fm%mfm) END FUNCTION fmreal_fm FUNCTION fmreal_im(ma) ! .. Function Return Value .. TYPE (fm) :: fmreal_im ! .. ! .. Structure Arguments .. TYPE (im), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL imi2fm ! .. CALL imi2fm(ma%mim,fmreal_im%mfm) END FUNCTION fmreal_im FUNCTION fmreal_zm(ma) ! .. Function Return Value .. TYPE (fm) :: fmreal_zm ! .. ! .. Structure Arguments .. TYPE (zm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL zmreal ! .. CALL zmreal(ma%mzm,fmreal_zm%mfm) END FUNCTION fmreal_zm ! RRSPACING FUNCTION fmrrspacing_fm(ma) ! .. Function Return Value .. TYPE (fm) :: fmrrspacing_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. External Subroutines .. EXTERNAL fmabs, fmeq ! .. CALL fmabs(ma%mfm,mtfm%mfm) mtfm%mfm(1) = ndig CALL fmeq(mtfm%mfm,fmrrspacing_fm%mfm) END FUNCTION fmrrspacing_fm ! SCALE FUNCTION fmscale_fm(ma,l) ! .. Function Return Value .. TYPE (fm) :: fmscale_fm ! .. ! .. Structure Arguments .. TYPE (fm), INTENT (IN) :: ma ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: l ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmi2m, fmipwr, fmmpy ! .. CALL fmeq(ma%mfm,mtfm%mfm) IF (abs(mtfm%mfm(1)+l) 'fmzmcomm.f90' MODULE fmzmcommon ! Define the array sizes: ! Here are the common blocks used in FM and ZM. ! /FMUSER/, /FM/, /FMSAVE/, /FMBUFF/, and /ZMUSER/ should be declared ! in the main program. ! 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. ! Common blocks used by ZMLIB for complex operations. ! ZMUSER contains values that may need to be ! changed by the calling program. ! ZM1 contains scratch arrays for temporary storage of ZM ! numbers while computing various functions. ! ZMPCK contains scratch arrays used to hold input arguments ! in unpacked format when the packed versions of functions ! are used. ! ZMBUFF contains the complex i/o buffer. ! .. 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 ! .. ! .. 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)) :: 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), mz01(0:lunpkz), & mz02(0:lunpkz), mz03(0:lunpkz), mz04(0:lunpkz), mzx(0:lunpkz), & mzy(0:lunpkz) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff), cmbufz(lmbufz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 COMMON /zmbuff/cmbufz COMMON /zmpck/mzx, mzy COMMON /zmuser/jformz, jprntz ! .. END MODULE fmzmcommon SHAR_EOF fi # end of overwriting check if test -f 'zmlib.f90' then echo shar: will not over-write existing file "'zmlib.f90'" else cat << SHAR_EOF > 'zmlib.f90' ! ZM 1.1 David M. Smith 5-19-97 ! The ZM routines perform complex floating-point multiple-precision ! arithmetic. ! These routines use the FMLIB package (version 1.1) for real ! floating-point multiple-precision arithmetic. ! FMLIB 1.0 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 FMLIB 1.1 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 section 5 below. ! 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. ! 5. LIST OF ROUTINES ! 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 SUBROUTINE zmset(nprec) ! Initialize common and set precision to at least NPREC significant ! digits before using ZM arithmetic. IMPLICIT NONE ! Here are the common blocks used for complex arithmetic. ! /FMUSER/, /FM/, /FMBUFF/, /FMSAVE/, and /ZMUSER/ should also be ! declared in the main program. ! .. 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 ! .. ! .. Scalar Arguments .. INTEGER :: nprec ! .. ! .. External Subroutines .. EXTERNAL fmset ! .. ! .. 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), mx(0:lunpkz), my(0:lunpkz), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) INTEGER :: khasht(lhash1:lhash2), khashv(lhash1:lhash2) CHARACTER (1) :: cmbuff(lmbuff), cmbufz(lmbufz) 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 /zm1/mz01, mz02, mz03, mz04 COMMON /zmbuff/cmbufz COMMON /zmpck/mx, my COMMON /zmuser/jformz, jprntz ! .. ! Set JFORMZ to ' 1.23 + 4.56 i ' format. jformz = 1 ! Set JPRNTZ to print real and imaginary parts on one ! line whenever possible. jprntz = 1 ! Use FMSET to initialize the other common blocks. CALL fmset(nprec) RETURN END SUBROUTINE zmset SUBROUTINE zmabs(ma,mbfm) ! MBFM = ABS(MA) ! Complex absolute value. The result is a real FM number. IMPLICIT NONE ! Scratch array usage during ZMABS: M01 - M02, MZ01 ! .. Intrinsic Functions .. INTRINSIC int, max, min ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mbfm(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxexp1, mxsave INTEGER :: kasave, kovun, kreslt, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmabs, fmadd, fmeq, fmi2m, fmsqr, fmsqrt, zmentr, zmeq2, zmexi2 ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mwa(lmwa), mz01(0:lunpkz), & mz02(0:lunpkz), mz03(0:lunpkz), mz04(0:lunpkz) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /zm1/mz01, mz02, mz03, mz04 ! .. CALL zmentr('ZMABS ',ma,ma,1,mz01,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) THEN CALL fmeq(mz01,mbfm) RETURN END IF marz = ma(0) maiz = ma(kptimu) kaccsw = 0 CALL zmeq2(ma,ma,ndsave,ndig,1) ! Check for special cases. mxexp1 = int(mxexp2/2.01D0) IF (ma(2)==0) THEN CALL fmabs(ma(kptimu),mbfm) GO TO 10 ELSE IF (ma(kptimu+2)==0) THEN CALL fmabs(ma,mbfm) GO TO 10 ELSE IF (ma(1)==mexpov .OR. ma(kptimu+1)==mexpov) THEN CALL fmi2m(1,mbfm) mbfm(1) = max(ma(1),ma(kptimu+1)) GO TO 10 ELSE IF (ma(1)==mexpun) THEN IF (ma(kptimu+1)>-mxexp1+ndig+1) THEN CALL fmabs(ma(kptimu),mbfm) GO TO 10 END IF ELSE IF (ma(kptimu+1)==mexpun) THEN IF (ma(1)>-mxexp1+ndig+1) THEN CALL fmabs(ma,mbfm) GO TO 10 END IF ELSE IF (ma(1)/=munkno .AND. ma(kptimu+1)/=munkno) THEN IF (ma(1)>ma(kptimu+1)+ndig+1) THEN CALL fmabs(ma,mbfm) GO TO 10 ELSE IF (ma(kptimu+1)>ma(1)+ndig+1) THEN CALL fmabs(ma(kptimu),mbfm) GO TO 10 END IF END IF CALL fmsqr(ma,m01) CALL fmsqr(ma(kptimu),m02) CALL fmadd(m01,m02,mbfm) CALL fmsqrt(mbfm,mbfm) 10 maccmb = mbfm(0) ma(0) = marz ma(kptimu) = maiz mbfm(0) = min(maccmb,marz,maiz) CALL zmexi2(mbfm,mbfm,ndsave,mxsave,kasave,kovun,1) RETURN END SUBROUTINE zmabs SUBROUTINE zmacos(ma,mb) ! MB = ACOS(MA). IMPLICIT NONE ! Scratch array usage during ZMACOS: M01 - M06, MZ01 - MZ03 ! .. Intrinsic Functions .. INTRINSIC int, min ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave INTEGER :: j, kasave, kovun, kreslt, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmacos, fmadd, fmdivi, fmi2m, fmpi, fmsqr, fmsub, zmadd, & zmentr, zmeq2, zmexit, zmi2m, zmln, zmmpy, zmntr, zmrslt, zmsqrt, & zmsub, zmwarn ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. CALL zmentr('ZMACOS',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN marz = ma(0) maiz = ma(kptimu) kaccsw = 0 CALL zmeq2(ma,ma,ndsave,ndig,1) ! Check for special cases. IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN CALL fmpi(mz01) CALL fmdivi(mz01,2,mz01) CALL fmi2m(0,mz01(kptimu)) GO TO 60 ELSE IF (ma(kptimu+2)==0) THEN CALL fmacos(ma,mz01) IF (kflag==0) THEN CALL fmi2m(0,mz01(kptimu)) GO TO 60 END IF END IF IF ((ma(2)==0 .OR. ma(1)*2<=-ndig) .AND. (ma(kptimu+ & 2)==0 .OR. ma(kptimu+1)*2<=-ndig)) THEN CALL fmpi(mz01) CALL fmdivi(mz01,2,mz01) CALL fmi2m(0,mz01(kptimu)) CALL zmsub(mz01,ma,mz01) GO TO 60 END IF CALL zmi2m(1,mz03) CALL zmsub(mz03,ma,mz02) CALL zmadd(mz03,ma,mz03) CALL zmmpy(mz02,mz03,mz02) CALL zmsqrt(mz02,mz02) DO 10 j = 0, ndig + 1 mz03(j) = mz02(kptimu+j) mz03(kptimu+j) = mz02(j) 10 CONTINUE IF (mz03(1)/=munkno) mz03(2) = -mz03(2) IF ((ma(2)/=0 .AND. mz03(1)==ma(1) .AND. mz03(2)==ma(2)) .OR. (ma( & kptimu+2)/=0 .AND. mz03(kptimu+1)==ma(kptimu+1) .AND. mz03(kptimu+ & 2)==ma(kptimu+2))) THEN CALL zmadd(ma,mz03,mz03) CALL fmsqr(mz03,m04) CALL fmsqr(mz03(kptimu),m05) CALL fmadd(m04,m05,m06) CALL fmi2m(1,m03) CALL fmsub(m06,m03,m03) IF (m03(1)<0) THEN ndig = ndig - int(m03(1)) IF (ndig>ndg2mx) THEN namest(ncall) = 'ZMACOS' kflag = -9 CALL zmwarn kreslt = 12 ndig = ndsave CALL zmrslt(mb,kreslt) IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 mxexp = mxsave kaccsw = kasave RETURN END IF CALL zmeq2(ma,ma,ndsave,ndig,1) CALL zmi2m(1,mz03) CALL zmsub(mz03,ma,mz02) CALL zmadd(mz03,ma,mz03) CALL zmmpy(mz02,mz03,mz02) CALL zmsqrt(mz02,mz02) DO 20 j = 0, ndig + 1 mz03(j) = mz02(kptimu+j) mz03(kptimu+j) = mz02(j) 20 CONTINUE IF (mz03(1)/=munkno) mz03(2) = -mz03(2) CALL zmadd(ma,mz03,mz03) END IF CALL zmln(mz03,mz03) DO 30 j = 0, ndig + 1 mz01(j) = mz03(kptimu+j) mz01(kptimu+j) = mz03(j) 30 CONTINUE IF (mz01(kptimu+1)/=munkno) mz01(kptimu+2) = -mz01(kptimu+2) ELSE CALL zmsub(ma,mz03,mz03) CALL fmsqr(mz03,m04) CALL fmsqr(mz03(kptimu),m05) CALL fmadd(m04,m05,m06) CALL fmi2m(1,m03) CALL fmsub(m06,m03,m03) IF (m03(1)<0) THEN ndig = ndig - int(m03(1)) IF (ndig>ndg2mx) THEN namest(ncall) = 'ZMACOS' kflag = -9 CALL zmwarn kreslt = 12 ndig = ndsave CALL zmrslt(mb,kreslt) IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 mxexp = mxsave kaccsw = kasave RETURN END IF CALL zmeq2(ma,ma,ndsave,ndig,1) CALL zmi2m(1,mz03) CALL zmsub(mz03,ma,mz02) CALL zmadd(mz03,ma,mz03) CALL zmmpy(mz02,mz03,mz02) CALL zmsqrt(mz02,mz02) DO 40 j = 0, ndig + 1 mz03(j) = mz02(kptimu+j) mz03(kptimu+j) = mz02(j) 40 CONTINUE IF (mz03(1)/=munkno) mz03(2) = -mz03(2) CALL zmsub(ma,mz03,mz03) END IF CALL zmln(mz03,mz03) DO 50 j = 0, ndig + 1 mz01(j) = mz03(kptimu+j) mz01(kptimu+j) = mz03(j) 50 CONTINUE IF (mz01(1)/=munkno) mz01(2) = -mz01(2) END IF 60 maccmb = mz01(0) ma(0) = marz mz01(0) = min(maccmb,marz,maiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mz01(kptimu) = min(maccmb,marz,maiz) CALL zmexit(mz01,mb,ndsave,mxsave,kasave,kovun,0) RETURN END SUBROUTINE zmacos SUBROUTINE zmadd(ma,mb,mc) ! MC = MA + MB IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz), mc(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mai, mar, mbi, mbr, mxsave INTEGER :: kasave, kf1, kovun, kreslt, kwrnsv, ndsave, ntrsav ! .. ! .. External Subroutines .. EXTERNAL fmadd, zmentr, zmntr, zmwarn ! .. ! .. 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 (abs(ma(1))>mexpab .OR. abs(ma(kptimu+1))>mexpab .OR. abs(mb(1))> & mexpab .OR. abs(mb(kptimu+1))>mexpab .OR. kdebug>=1) THEN CALL zmentr('ZMADD ',ma,mb,2,mc,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ndig = ndsave mxexp = mxsave kaccsw = kasave ntrsav = ntrace ELSE ncall = ncall + 1 ntrsav = ntrace IF (ntrace/=0) THEN namest(ncall) = 'ZMADD ' CALL zmntr(2,ma,mb,2) ntrace = 0 END IF kovun = 0 END IF ! Force FMADD to use more guard digits for user calls. ncall = ncall - 1 kwrnsv = kwarn kwarn = 0 mar = ma(1) IF (ma(2)==0) mar = mexpun - 1 mai = ma(kptimu+1) IF (ma(kptimu+2)==0) mai = mexpun - 1 mbr = mb(1) IF (mb(2)==0) mbr = mexpun - 1 mbi = mb(kptimu+1) IF (mb(kptimu+2)==0) mbi = mexpun - 1 CALL fmadd(ma,mb,mc) kf1 = kflag CALL fmadd(ma(kptimu),mb(kptimu),mc(kptimu)) ncall = ncall + 1 IF (ntrsav/=0) THEN ntrace = ntrsav namest(ncall) = 'ZMADD ' END IF kwarn = kwrnsv IF (kflag==1) kflag = kf1 IF (kflag==1) THEN kflag = 0 IF (mar<=mbr .AND. mai<=mbi) kflag = 1 IF (mar>=mbr .AND. mai>=mbi) kflag = 1 END IF IF (mc(1)==munkno .OR. mc(kptimu+1)==munkno) THEN kflag = -4 ELSE IF (mc(1)==mexpov .OR. mc(kptimu+1)==mexpov) THEN kflag = -5 ELSE IF (mc(1)==mexpun .OR. mc(kptimu+1)==mexpun) THEN kflag = -6 END IF IF ((mc(1)==munkno) .OR. (mc(kptimu+1)==munkno) .OR. (mc(1)==mexpun & .AND. kovun==0) .OR. (mc(kptimu+1)==mexpun .AND. kovun==0) .OR. (mc( & 1)==mexpov .AND. kovun==0) .OR. (mc(kptimu+ & 1)==mexpov .AND. kovun==0)) THEN namest(ncall) = 'ZMADD ' CALL zmwarn END IF IF (ntrace/=0) THEN CALL zmntr(1,mc,mc,1) END IF ncall = ncall - 1 RETURN END SUBROUTINE zmadd SUBROUTINE zmaddi(ma,integ) ! MA = MA + INTEG Increment by one-word (real) integer. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs ! .. ! .. 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 ! .. ! .. Scalar Arguments .. INTEGER :: integ ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mxsave INTEGER :: kasave, kovun, kreslt, kwrnsv, ndsave, ntrsav ! .. ! .. External Subroutines .. EXTERNAL fmaddi, fmntri, zmentr, zmntr, zmwarn ! .. ! .. 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 (abs(ma(1))>mexpab .OR. abs(ma(kptimu+1))>mexpab .OR. kdebug>=1) THEN CALL zmentr('ZMADDI',ma,ma,1,ma,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ndig = ndsave mxexp = mxsave kaccsw = kasave ntrsav = ntrace ELSE ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'ZMADDI' CALL zmntr(2,ma,ma,1) CALL fmntri(2,integ,0) END IF kovun = 0 END IF ! Force FMADDI to use more guard digits for user calls. ncall = ncall - 1 ntrsav = ntrace ntrace = 0 kwrnsv = kwarn kwarn = 0 CALL fmaddi(ma,integ) ntrace = ntrsav kwarn = kwrnsv ncall = ncall + 1 IF (ntrace/=0) namest(ncall) = 'ZMADDI' IF (ma(1)==munkno .OR. ma(kptimu+1)==munkno) THEN kflag = -4 ELSE IF (ma(1)==mexpov .OR. ma(kptimu+1)==mexpov) THEN kflag = -5 ELSE IF (ma(1)==mexpun .OR. ma(kptimu+1)==mexpun) THEN kflag = -6 END IF IF ((ma(1)==munkno) .OR. (ma(kptimu+1)==munkno) .OR. (ma(1)==mexpun & .AND. kovun==0) .OR. (ma(kptimu+1)==mexpun .AND. kovun==0) .OR. (ma( & 1)==mexpov .AND. kovun==0) .OR. (ma(kptimu+ & 1)==mexpov .AND. kovun==0)) THEN namest(ncall) = 'ZMADDI' CALL zmwarn END IF IF (ntrace/=0) CALL zmntr(1,ma,ma,1) ncall = ncall - 1 RETURN END SUBROUTINE zmaddi SUBROUTINE zmarg(ma,mbfm) ! MBFM = ARG(MA) ! Complex argument. The result is a real FM number. IMPLICIT NONE ! Scratch array usage during ZMARG: M01 - M06, MZ01 ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mbfm(0:lunpck) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mxsave INTEGER :: kasave, kovun, kreslt, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmatn2, fmeq, zmentr, zmeq2, zmexi2 ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mwa(lmwa), mz01(0:lunpkz), & mz02(0:lunpkz), mz03(0:lunpkz), mz04(0:lunpkz) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /zm1/mz01, mz02, mz03, mz04 ! .. CALL zmentr('ZMARG ',ma,ma,1,mz01,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) THEN CALL fmeq(mz01,mbfm) RETURN END IF kaccsw = 0 CALL zmeq2(ma,ma,ndsave,ndig,1) CALL fmatn2(ma(kptimu),ma,mbfm) CALL zmexi2(mbfm,mbfm,ndsave,mxsave,kasave,kovun,1) RETURN END SUBROUTINE zmarg SUBROUTINE zmasin(ma,mb) ! MB = ASIN(MA). IMPLICIT NONE ! Scratch array usage during ZMASIN: M01 - M06, MZ01 - MZ03 ! .. Intrinsic Functions .. INTRINSIC int, min ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave INTEGER :: j, kasave, kovun, kreslt, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmasin, fmi2m, fmsqr, fmsub, zmadd, zmentr, zmeq, zmeq2, & zmexit, zmi2m, zmln, zmmpy, zmntr, zmrslt, zmsqrt, zmsub, zmwarn ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. CALL zmentr('ZMASIN',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN marz = ma(0) maiz = ma(kptimu) kaccsw = 0 CALL zmeq2(ma,ma,ndsave,ndig,1) ! Check for special cases. IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN CALL zmi2m(0,mz01) GO TO 60 ELSE IF ((ma(2)==0 .OR. ma(1)*2<=-ndig) .AND. (ma(kptimu+ & 2)==0 .OR. ma(kptimu+1)*2<=-ndig)) THEN CALL zmeq(ma,mz01) GO TO 60 ELSE IF (ma(kptimu+2)==0) THEN CALL fmasin(ma,mz01) IF (kflag==0) THEN CALL fmi2m(0,mz01(kptimu)) GO TO 60 END IF END IF CALL zmi2m(1,mz03) CALL zmsub(mz03,ma,mz02) CALL zmadd(mz03,ma,mz03) CALL zmmpy(mz02,mz03,mz02) CALL zmsqrt(mz02,mz02) DO 10 j = 0, ndig + 1 mz03(j) = ma(kptimu+j) mz03(kptimu+j) = ma(j) 10 CONTINUE IF (mz03(1)/=munkno) mz03(2) = -mz03(2) IF ((mz02(2)/=0 .AND. mz03(1)==mz02(1) .AND. mz03(2)==mz02( & 2)) .OR. (mz02(kptimu+2)/=0 .AND. mz03(kptimu+1)==mz02(kptimu+ & 1) .AND. mz03(kptimu+2)==mz02(kptimu+2))) THEN CALL zmadd(mz02,mz03,mz03) CALL fmsqr(mz03,m04) CALL fmsqr(mz03(kptimu),m05) CALL fmadd(m04,m05,m06) CALL fmi2m(1,m03) CALL fmsub(m06,m03,m03) IF (m03(1)<0) THEN ndig = ndig - int(m03(1)) IF (ndig>ndg2mx) THEN namest(ncall) = 'ZMASIN' kflag = -9 CALL zmwarn kreslt = 12 ndig = ndsave CALL zmrslt(mb,kreslt) IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 mxexp = mxsave kaccsw = kasave RETURN END IF CALL zmeq2(ma,ma,ndsave,ndig,1) CALL zmi2m(1,mz03) CALL zmsub(mz03,ma,mz02) CALL zmadd(mz03,ma,mz03) CALL zmmpy(mz02,mz03,mz02) CALL zmsqrt(mz02,mz02) DO 20 j = 0, ndig + 1 mz03(j) = ma(kptimu+j) mz03(kptimu+j) = ma(j) 20 CONTINUE IF (mz03(1)/=munkno) mz03(2) = -mz03(2) CALL zmadd(mz02,mz03,mz03) END IF CALL zmln(mz03,mz03) DO 30 j = 0, ndig + 1 mz01(j) = mz03(kptimu+j) mz01(kptimu+j) = mz03(j) 30 CONTINUE IF (mz01(kptimu+1)/=munkno) mz01(kptimu+2) = -mz01(kptimu+2) ELSE CALL zmsub(mz02,mz03,mz03) CALL fmsqr(mz03,m04) CALL fmsqr(mz03(kptimu),m05) CALL fmadd(m04,m05,m06) CALL fmi2m(1,m03) CALL fmsub(m06,m03,m03) IF (m03(1)<0) THEN ndig = ndig - int(m03(1)) IF (ndig>ndg2mx) THEN namest(ncall) = 'ZMASIN' kflag = -9 CALL zmwarn kreslt = 12 ndig = ndsave CALL zmrslt(mb,kreslt) IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 mxexp = mxsave kaccsw = kasave RETURN END IF CALL zmeq2(ma,ma,ndsave,ndig,1) CALL zmi2m(1,mz03) CALL zmsub(mz03,ma,mz02) CALL zmadd(mz03,ma,mz03) CALL zmmpy(mz02,mz03,mz02) CALL zmsqrt(mz02,mz02) DO 40 j = 0, ndig + 1 mz03(j) = ma(kptimu+j) mz03(kptimu+j) = ma(j) 40 CONTINUE IF (mz03(1)/=munkno) mz03(2) = -mz03(2) CALL zmsub(mz02,mz03,mz03) END IF CALL zmln(mz03,mz03) DO 50 j = 0, ndig + 1 mz01(j) = mz03(kptimu+j) mz01(kptimu+j) = mz03(j) 50 CONTINUE IF (mz01(1)/=munkno) mz01(2) = -mz01(2) END IF 60 maccmb = mz01(0) ma(0) = marz mz01(0) = min(maccmb,marz,maiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mz01(kptimu) = min(maccmb,marz,maiz) CALL zmexit(mz01,mb,ndsave,mxsave,kasave,kovun,0) RETURN END SUBROUTINE zmasin SUBROUTINE zmatan(ma,mb) ! MB = ATAN(MA). IMPLICIT NONE ! Scratch array usage during ZMATAN: M01 - M06, MZ01 - MZ04 ! .. Intrinsic Functions .. INTRINSIC int, min ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave REAL :: x INTEGER :: j, jterm, kasave, kovun, kreslt, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmabs, fmadd, fmatan, fmdivi, fmeq, fmi2m, fmpi, fmsp2m, fmsqr, & fmsub, zm2i2m, zmadd, zmdiv, zmdivi, zmentr, zmeq, zmeq2, zmexit, & zmi2m, zmln, zmmpy, zmntr, zmrslt, zmsqr, zmsub, zmwarn ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. CALL zmentr('ZMATAN',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN marz = ma(0) maiz = ma(kptimu) kaccsw = 0 CALL zmeq2(ma,ma,ndsave,ndig,1) ! Check for special cases. IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN CALL zmi2m(0,mz04) GO TO 30 ELSE IF ((ma(2)==0 .OR. ma(1)*2<=-ndig) .AND. (ma(kptimu+ & 2)==0 .OR. ma(kptimu+1)*2<=-ndig)) THEN CALL zmeq(ma,mz04) GO TO 30 ELSE IF (ma(kptimu+2)==0) THEN CALL fmatan(ma,mz04) IF (kflag==0) THEN CALL fmi2m(0,mz04(kptimu)) GO TO 30 END IF END IF x = 1.0E+5 CALL fmsp2m(x,m02) CALL fmabs(ma,m03) CALL fmabs(ma(kptimu),m04) CALL fmadd(m03,m04,m04) IF (fmcomp(m04,'GE',m02)) THEN CALL zmi2m(0,mz04) CALL fmpi(mz04) CALL fmdivi(mz04,2,mz04) IF (ma(2)<0) mz04(2) = -mz04(2) CALL zmi2m(1,mz02) CALL zmdiv(mz02,ma,mz02) CALL zmeq(mz02,mz03) CALL zmsub(mz04,mz02,mz04) IF (ma(1)>ndig .OR. ma(kptimu+1)>ndig) GO TO 30 CALL zmsqr(mz02,mz02) jterm = 1 10 CALL zmmpy(mz03,mz02,mz03) jterm = jterm + 2 CALL fmeq(mz03,m05) CALL fmeq(mz03(kptimu),m06) CALL zmdivi(mz03,jterm,mz03) CALL zmadd(mz04,mz03,mz04) IF (kflag/=0) GO TO 30 CALL fmeq(m05,mz03) CALL fmeq(m06,mz03(kptimu)) CALL zmmpy(mz03,mz02,mz03) jterm = jterm + 2 CALL fmeq(mz03,m05) CALL fmeq(mz03(kptimu),m06) CALL zmdivi(mz03,jterm,mz03) CALL zmsub(mz04,mz03,mz04) IF (kflag/=0) GO TO 30 CALL fmeq(m05,mz03) CALL fmeq(m06,mz03(kptimu)) GO TO 10 ELSE CALL zm2i2m(0,1,mz02) CALL zmsub(mz02,ma,mz03) CALL zmadd(mz02,ma,mz02) CALL zmdiv(mz02,mz03,mz03) CALL fmsqr(mz03,m04) CALL fmsqr(mz03(kptimu),m05) CALL fmadd(m04,m05,m06) CALL fmi2m(1,m03) CALL fmsub(m06,m03,m03) IF (m03(1)<0) THEN ndig = ndig - int(m03(1)) IF (ndig>ndg2mx) THEN namest(ncall) = 'ZMATAN' kflag = -9 CALL zmwarn kreslt = 12 ndig = ndsave CALL zmrslt(mb,kreslt) IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 mxexp = mxsave kaccsw = kasave RETURN END IF CALL zmeq2(ma,ma,ndsave,ndig,1) CALL zm2i2m(0,1,mz02) CALL zmsub(mz02,ma,mz03) CALL zmadd(mz02,ma,mz02) CALL zmdiv(mz02,mz03,mz03) END IF CALL zmln(mz03,mz03) CALL zmdivi(mz03,2,mz03) DO 20 j = 0, ndig + 1 mz04(j) = mz03(kptimu+j) mz04(kptimu+j) = mz03(j) 20 CONTINUE IF (mz04(1)/=munkno) mz04(2) = -mz04(2) END IF 30 maccmb = mz04(0) ma(0) = marz mz04(0) = min(maccmb,marz,maiz) maccmb = mz04(kptimu) ma(kptimu) = maiz mz04(kptimu) = min(maccmb,marz,maiz) CALL zmexit(mz04,mb,ndsave,mxsave,kasave,kovun,0) RETURN END SUBROUTINE zmatan SUBROUTINE zmchsh(ma,mb,mc) ! MB = COSH(MA), MC = SINH(MA). ! If both the hyperbolic sine and cosine are needed, this routine ! is faster than calling both ZMCOS and ZMSIN. ! MB and MC must be distinct arrays. IMPLICIT NONE ! Scratch array usage during ZMCHSH: M01 - M06, MZ01 - MZ04 ! .. Intrinsic Functions .. INTRINSIC abs, min ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz), mc(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave INTEGER :: kasave, kovun, kreslt, krsave, ncsave, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmchsh, fmcssn, fmi2m, fmmpy, zmentr, zmeq, zmeq2, zmexit, & zmi2m, zmntr, zmntrj, zmprnt ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. ncsave = ncall CALL zmentr('ZMCHSH',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) ncall = ncsave + 1 IF (kreslt/=0) THEN CALL zmeq(mb,mc) IF (ntrace/=0) THEN CALL zmntr(1,mb,mb,1) IF (abs(ntrace)>=1 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN CALL zmntrj(mc,ndig) ELSE CALL zmprnt(mc) END IF END IF END IF ncall = ncall - 1 RETURN END IF marz = ma(0) maiz = ma(kptimu) kaccsw = 0 krsave = krad krad = 1 CALL zmeq2(ma,ma,ndsave,ndig,1) ! Check for special cases. IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN CALL zmi2m(1,mz01) CALL zmi2m(0,mc) GO TO 10 ELSE IF (ma(kptimu+2)==0) THEN CALL fmchsh(ma,mz01,mc) CALL fmi2m(0,mz01(kptimu)) CALL fmi2m(0,mc(kptimu)) GO TO 10 ELSE IF (ma(2)==0) THEN CALL fmcssn(ma(kptimu),mz01,mc(kptimu)) CALL fmi2m(0,mz01(kptimu)) CALL fmi2m(0,mc) GO TO 10 END IF ! Find SINH(REAL(MA)) and COSH(REAL(MA)). CALL fmchsh(ma,mz02,mz02(kptimu)) ! Find SIN(IMAG(MA)) and COS(IMAG(MA)). CALL fmcssn(ma(kptimu),mz03,mz03(kptimu)) ! COSH(MA) = COSH(REAL(MA))*COS(IMAG(MA)) + ! SINH(REAL(MA))*SIN(IMAG(MA)) i CALL fmmpy(mz02,mz03,mz01) CALL fmmpy(mz02(kptimu),mz03(kptimu),mz01(kptimu)) ! SINH(MA) = SINH(REAL(MA))*COS(IMAG(MA)) + ! COSH(REAL(MA))*SIN(IMAG(MA)) i CALL fmmpy(mz02(kptimu),mz03,mc) CALL fmmpy(mz02,mz03(kptimu),mc(kptimu)) 10 maccmb = mz01(0) ma(0) = marz mz01(0) = min(maccmb,marz,maiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mz01(kptimu) = min(maccmb,marz,maiz) mc(0) = mz01(0) mc(kptimu) = mz01(kptimu) kaccsw = kasave CALL zmeq2(mc,mc,ndig,ndsave,1) CALL zmexit(mz01,mb,ndsave,mxsave,kasave,kovun,0) IF (ntrace/=0) THEN IF (abs(ntrace)>=1 .AND. ncall+1<=lvltrc) THEN IF (ntrace<0) THEN CALL zmntrj(mc,ndig) ELSE CALL zmprnt(mc) END IF END IF END IF krad = krsave RETURN END SUBROUTINE zmchsh SUBROUTINE zmcmpx(mafm,mbfm,mc) ! MC = COMPLEX( MAFM , MBFM ) ! MAFM and MBFM are real FM numbers, MC is a complex ZM number. IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: mafm(0:lunpck), mbfm(0:lunpck), mc(0:lunpkz) ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmntr, zmntr ! .. ! .. 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 ! .. kflag = 0 ncall = ncall + 1 namest(ncall) = 'ZMCMPX' IF (ntrace/=0) CALL fmntr(2,mafm,mbfm,2) CALL fmeq(mafm,mc) CALL fmeq(mbfm,mc(kptimu)) IF (ntrace/=0) CALL zmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END SUBROUTINE zmcmpx SUBROUTINE zmconj(ma,mb) ! MB = CONJG(MA) ! Complex conjugate. IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. External Subroutines .. EXTERNAL fmeq, zmntr ! .. ! .. 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 ! .. kflag = 0 ncall = ncall + 1 namest(ncall) = 'ZMCONJ' IF (ntrace/=0) CALL zmntr(2,ma,ma,1) CALL fmeq(ma,mb) CALL fmeq(ma(kptimu),mb(kptimu)) IF (mb(kptimu+1)/=munkno) mb(kptimu+2) = -mb(kptimu+2) IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END SUBROUTINE zmconj SUBROUTINE zmcos(ma,mb) ! MB = COS(MA). IMPLICIT NONE ! Scratch array usage during ZMCOS: M01 - M06, MZ01 - MZ03 ! .. Intrinsic Functions .. INTRINSIC min ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave INTEGER :: kasave, kovun, kreslt, krsave, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmchsh, fmcos, fmcosh, fmcssn, fmi2m, fmmpy, zmentr, zmeq2, & zmexit, zmi2m ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. CALL zmentr('ZMCOS ',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN marz = ma(0) maiz = ma(kptimu) kaccsw = 0 krsave = krad krad = 1 CALL zmeq2(ma,ma,ndsave,ndig,1) ! Check for special cases. IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN CALL zmi2m(1,mz01) GO TO 10 ELSE IF (ma(kptimu+2)==0) THEN CALL fmcos(ma,mz01) CALL fmi2m(0,mz01(kptimu)) GO TO 10 ELSE IF (ma(2)==0) THEN CALL fmcosh(ma(kptimu),mz01) CALL fmi2m(0,mz01(kptimu)) GO TO 10 END IF ! Find COS(REAL(MA)) and SIN(REAL(MA)). CALL fmcssn(ma,mz01,mz01(kptimu)) ! Find COSH(IMAG(MA)) and SINH(IMAG(MA)). CALL fmchsh(ma(kptimu),m05,m06) ! COS(MA) = COS(REAL(MA))*COSH(IMAG(MA)) - ! SIN(REAL(MA))*SINH(IMAG(MA)) i CALL fmmpy(mz01,m05,mz01) IF (m06(1)/=munkno) m06(2) = -m06(2) CALL fmmpy(mz01(kptimu),m06,mz01(kptimu)) 10 maccmb = mz01(0) ma(0) = marz mz01(0) = min(maccmb,marz,maiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mz01(kptimu) = min(maccmb,marz,maiz) CALL zmexit(mz01,mb,ndsave,mxsave,kasave,kovun,0) krad = krsave RETURN END SUBROUTINE zmcos SUBROUTINE zmcosh(ma,mb) ! MB = COSH(MA). IMPLICIT NONE ! Scratch array usage during ZMCOSH: M01 - M06, MZ01 - MZ03 ! .. Intrinsic Functions .. INTRINSIC min ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave INTEGER :: kasave, kovun, kreslt, krsave, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmchsh, fmcos, fmcosh, fmcssn, fmi2m, fmmpy, zmentr, zmeq2, & zmexit, zmi2m ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. CALL zmentr('ZMCOSH',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN marz = ma(0) maiz = ma(kptimu) kaccsw = 0 krsave = krad krad = 1 CALL zmeq2(ma,ma,ndsave,ndig,1) ! Check for special cases. IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN CALL zmi2m(1,mz01) GO TO 10 ELSE IF (ma(2)==0) THEN CALL fmcos(ma(kptimu),mz01) CALL fmi2m(0,mz01(kptimu)) GO TO 10 ELSE IF (ma(kptimu+2)==0) THEN CALL fmcosh(ma,mz01) CALL fmi2m(0,mz01(kptimu)) GO TO 10 END IF ! Find COS(IMAG(MA)) and SIN(IMAG(MA)). CALL fmcssn(ma(kptimu),mz01,mz01(kptimu)) ! Find COSH(REAL(MA)) and SINH(REAL(MA)). CALL fmchsh(ma,m05,m06) ! COSH(MA) = COSH(REAL(MA))*COS(IMAG(MA)) + ! SINH(REAL(MA))*SIN(IMAG(MA)) i CALL fmmpy(mz01,m05,mz01) CALL fmmpy(mz01(kptimu),m06,mz01(kptimu)) 10 maccmb = mz01(0) ma(0) = marz mz01(0) = min(maccmb,marz,maiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mz01(kptimu) = min(maccmb,marz,maiz) CALL zmexit(mz01,mb,ndsave,mxsave,kasave,kovun,0) krad = krsave RETURN END SUBROUTINE zmcosh SUBROUTINE zmcssn(ma,mb,mc) ! MB = COS(MA), MC = SIN(MA). ! If both the sine and cosine are needed, this routine is faster ! than calling both ZMCOS and ZMSIN. ! MB and MC must be distinct arrays. IMPLICIT NONE ! Scratch array usage during ZMCSSN: M01 - M06, MZ01 - MZ04 ! .. Intrinsic Functions .. INTRINSIC abs, min ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz), mc(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave INTEGER :: kasave, kovun, kreslt, krsave, ncsave, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmchsh, fmcssn, fmi2m, fmmpy, zmentr, zmeq, zmeq2, zmexit, & zmi2m, zmntr, zmntrj, zmprnt ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. ncsave = ncall CALL zmentr('ZMCSSN',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) ncall = ncsave + 1 IF (kreslt/=0) THEN CALL zmeq(mb,mc) IF (ntrace/=0) THEN CALL zmntr(1,mb,mb,1) IF (abs(ntrace)>=1 .AND. ncall<=lvltrc) THEN IF (ntrace<0) THEN CALL zmntrj(mc,ndig) ELSE CALL zmprnt(mc) END IF END IF END IF ncall = ncall - 1 RETURN END IF marz = ma(0) maiz = ma(kptimu) kaccsw = 0 krsave = krad krad = 1 CALL zmeq2(ma,ma,ndsave,ndig,1) ! Check for special cases. IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN CALL zmi2m(1,mz01) CALL zmi2m(0,mc) GO TO 10 ELSE IF (ma(kptimu+2)==0) THEN CALL fmcssn(ma,mz01,mc) CALL fmi2m(0,mz01(kptimu)) CALL fmi2m(0,mc(kptimu)) GO TO 10 ELSE IF (ma(2)==0) THEN CALL fmchsh(ma(kptimu),mz01,mc(kptimu)) CALL fmi2m(0,mz01(kptimu)) CALL fmi2m(0,mc) GO TO 10 END IF ! Find SIN(REAL(MA)) and COS(REAL(MA)). CALL fmcssn(ma,mz02,mz02(kptimu)) ! Find SINH(IMAG(MA)) and COSH(IMAG(MA)). CALL fmchsh(ma(kptimu),mz03,mz03(kptimu)) ! COS(MA) = COS(REAL(MA))*COSH(IMAG(MA)) - ! SIN(REAL(MA))*SINH(IMAG(MA)) i CALL fmmpy(mz02,mz03,mz01) CALL fmmpy(mz02(kptimu),mz03(kptimu),mz01(kptimu)) IF (mz01(kptimu+1)/=munkno) mz01(kptimu+2) = -mz01(kptimu+2) ! SIN(MA) = SIN(REAL(MA))*COSH(IMAG(MA)) + ! COS(REAL(MA))*SINH(IMAG(MA)) i CALL fmmpy(mz02(kptimu),mz03,mc) CALL fmmpy(mz02,mz03(kptimu),mc(kptimu)) 10 maccmb = mz01(0) ma(0) = marz mz01(0) = min(maccmb,marz,maiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mz01(kptimu) = min(maccmb,marz,maiz) mc(0) = mz01(0) mc(kptimu) = mz01(kptimu) kaccsw = kasave CALL zmeq2(mc,mc,ndig,ndsave,1) CALL zmexit(mz01,mb,ndsave,mxsave,kasave,kovun,0) IF (ntrace/=0) THEN IF (abs(ntrace)>=1 .AND. ncall+1<=lvltrc) THEN IF (ntrace<0) THEN CALL zmntrj(mc,ndig) ELSE CALL zmprnt(mc) END IF END IF END IF krad = krsave RETURN END SUBROUTINE zmcssn SUBROUTINE zmdiv(ma,mb,mc) ! MC = MA / MB IMPLICIT NONE ! Scratch array usage during ZMDIV: M01 - M04, MZ01 ! .. Intrinsic Functions .. INTRINSIC abs, int, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz), mc(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mbiz, mbrz, mxsave, mz11sv, mz1ksv, & mzero INTEGER :: iextra, j, kasave, kovun, kreslt, kwrnsv, ndgsv2, ndsave, & ngoal, ntrsav ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmdiv, fmdivd, fmmpye, fmsub, zmentr, zmeq2, zmi2m, & zmntr, zmrslt, zmwarn ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. IF (abs(ma(1))>mexpab .OR. abs(ma(kptimu+1))>mexpab .OR. abs(mb(1))> & mexpab .OR. abs(mb(kptimu+1))>mexpab .OR. kdebug>=1) THEN CALL zmentr('ZMDIV ',ma,mb,2,mc,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'ZMDIV ' CALL zmntr(2,ma,mb,2) END IF ndsave = ndig IF (ncall==1) THEN ndig = max(ndig+ngrd52,2) IF (ndig>ndg2mx) THEN namest(ncall) = 'ZMDIV ' kflag = -9 CALL zmwarn kreslt = 12 ndig = ndsave CALL zmrslt(mc,kreslt) IF (ntrace/=0) CALL zmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END IF IF (mbase>=100*abs(ma(2)) .OR. mbase>=100*abs(ma(kptimu+2))) THEN ndig = min(ndig+1,ndg2mx) ELSE IF (mbase>=100*abs(mb(2)) .OR. mbase>=100*abs(mb(kptimu+ & 2))) THEN ndig = min(ndig+1,ndg2mx) END IF END IF kasave = kaccsw kaccsw = 1 mxsave = mxexp mxexp = mxexp2 kovun = 0 END IF marz = ma(0) mbrz = mb(0) maiz = ma(kptimu) mbiz = mb(kptimu) mzero = 0 ntrsav = ntrace ntrace = 0 kwrnsv = kwarn kwarn = 0 iextra = 0 mz11sv = -munkno mz1ksv = -munkno 10 DO 20 j = ndsave + 2, ndig + 1 ma(j) = mzero mb(j) = mzero ma(kptimu+j) = mzero mb(kptimu+j) = mzero 20 CONTINUE IF (ncall==1) THEN ma(0) = nint(ndig*alogm2) mb(0) = ma(0) ma(kptimu) = ma(0) mb(kptimu) = ma(0) END IF ! Check for special cases. IF (mb(kptimu+2)==0) THEN CALL fmdivd(ma,ma(kptimu),mb,mz01,mz01(kptimu)) GO TO 70 ELSE IF (mb(2)==0) THEN CALL fmdivd(ma(kptimu),ma,mb(kptimu),mz01,mz01(kptimu)) IF (mz01(kptimu+1)/=munkno) mz01(kptimu+2) = -mz01(kptimu+2) GO TO 70 END IF IF (ma(1)==mb(1) .AND. ma(2)==mb(2)) THEN IF (ma(kptimu+1)==mb(kptimu+1) .AND. ma(kptimu+2)==mb(kptimu+2)) THEN DO 30 j = 3, ndsave + 1 IF (ma(j)/=mb(j)) GO TO 50 IF (ma(kptimu+j)/=mb(kptimu+j)) GO TO 50 30 CONTINUE IF (abs(ma(1))=iextra-1 .AND. mz01(kptimu)>ngoal) GO TO 70 IF (mz1ksv-mz01(kptimu+1)>=iextra-1 .AND. mz01(0)>ngoal) GO TO 70 IF (mz11sv>-munkno .AND. mz01(0)>ngoal .AND. mz01(kptimu+2)==0) & GO TO 70 IF (mz11sv>-munkno .AND. mz01(kptimu)>ngoal .AND. mz01(2)==0) GO TO 70 iextra = int(real(max(ngoal-mz01(0),ngoal-mz01(kptimu)))/alogm2+23.03/ & alogmb) + 1 mz11sv = mz01(1) mz1ksv = mz01(kptimu+1) ndig = ndig + iextra IF (ndig>ndg2mx) THEN namest(ncall) = 'ZMDIV ' kflag = -9 CALL zmwarn mz01(1) = munkno mz01(2) = 1 mz01(kptimu+1) = munkno mz01(kptimu+2) = 1 DO 60 j = 2, ndsave mz01(j+1) = 0 mz01(kptimu+j+1) = 0 60 CONTINUE ndig = ndig - iextra mz01(0) = nint(ndig*alogm2) mz01(kptimu) = nint(ndig*alogm2) GO TO 70 END IF GO TO 10 END IF 70 mxexp = mxsave ntrace = ntrsav ndgsv2 = ndig ndig = ndsave kwarn = kwrnsv maccmb = mz01(0) ma(0) = marz mb(0) = mbrz mz01(0) = min(maccmb,marz,maiz,mbrz,mbiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mb(kptimu) = mbiz mz01(kptimu) = min(maccmb,marz,maiz,mbrz,mbiz) CALL zmeq2(mz01,mc,ndgsv2,ndsave,0) IF (mc(1)>=mexpov .OR. mc(1)<=-mexpov .OR. mc(kptimu+1)>=mexpov .OR. & mc(kptimu+1)<=-mexpov) THEN IF (mc(1)==munkno .OR. mc(kptimu+1)==munkno) THEN kflag = -4 ELSE IF (mc(1)==mexpov .OR. mc(kptimu+1)==mexpov) THEN kflag = -5 ELSE IF (mc(1)==mexpun .OR. mc(kptimu+1)==mexpun) THEN kflag = -6 END IF IF ((mc(1)==munkno) .OR. (mc(kptimu+1)==munkno) .OR. (mc(1)==mexpun & .AND. kovun==0) .OR. (mc(kptimu+1)==mexpun .AND. kovun==0) .OR. ( & mc(1)==mexpov .AND. kovun==0) .OR. (mc(kptimu+ & 1)==mexpov .AND. kovun==0)) THEN namest(ncall) = 'ZMDIV ' CALL zmwarn END IF END IF IF (ntrace/=0) CALL zmntr(1,mc,mc,1) kaccsw = kasave ncall = ncall - 1 RETURN END SUBROUTINE zmdiv SUBROUTINE zmdivi(ma,integ,mb) ! MB = MA / INTEG Divide by one-word (real) integer. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs ! .. ! .. 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 ! .. ! .. Scalar Arguments .. INTEGER :: integ ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mxsave INTEGER :: kasave, kovun, kreslt, kwrnsv, ndsave, ntrsav ! .. ! .. External Subroutines .. EXTERNAL fmdivi, fmntri, zmentr, zmntr, zmwarn ! .. ! .. 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 (abs(ma(1))>mexpab .OR. abs(ma(kptimu+1))>mexpab .OR. kdebug>=1) THEN CALL zmentr('ZMDIVI',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ndig = ndsave mxexp = mxsave kaccsw = kasave ntrsav = ntrace ELSE ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'ZMDIVI' CALL zmntr(2,ma,ma,1) CALL fmntri(2,integ,0) END IF kovun = 0 END IF ! Force FMDIVI to use more guard digits for user calls. ncall = ncall - 1 ntrsav = ntrace ntrace = 0 kwrnsv = kwarn kwarn = 0 CALL fmdivi(ma,integ,mb) CALL fmdivi(ma(kptimu),integ,mb(kptimu)) ntrace = ntrsav kwarn = kwrnsv ncall = ncall + 1 IF (ntrace/=0) namest(ncall) = 'ZMDIVI' IF (mb(1)==munkno .OR. mb(kptimu+1)==munkno) THEN kflag = -4 ELSE IF (mb(1)==mexpov .OR. mb(kptimu+1)==mexpov) THEN kflag = -5 ELSE IF (mb(1)==mexpun .OR. mb(kptimu+1)==mexpun) THEN kflag = -6 END IF IF ((mb(1)==munkno) .OR. (mb(kptimu+1)==munkno) .OR. (mb(1)==mexpun & .AND. kovun==0) .OR. (mb(kptimu+1)==mexpun .AND. kovun==0) .OR. (mb( & 1)==mexpov .AND. kovun==0) .OR. (mb(kptimu+ & 1)==mexpov .AND. kovun==0)) THEN namest(ncall) = 'ZMDIVI' CALL zmwarn END IF IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END SUBROUTINE zmdivi SUBROUTINE zmentr(nroutn,ma,mb,nargs,mc,kreslt,ndsave,mxsave,kasave,kovun) ! Do the argument checking and increasing of precision, overflow ! threshold, etc., upon entry to a ZM routine. ! NROUTN - routine name of calling routine ! MA - first input argument ! MB - second input argument (optional) ! NARGS - number of input arguments ! MC - result argument ! KRESLT - returned nonzero if the input arguments give the result ! immediately (e.g., MA*0 or OVERFLOW*MB) ! NDSAVE - saves the value of NDIG after NDIG is increased ! MXSAVE - saves the value of MXEXP ! KASAVE - saves the value of KACCSW ! KOVUN - returned nonzero if an input argument is (+ or -) overflow ! or underflow. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int, max, min, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: 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 .. REAL (KIND(0.0D0)) :: mxsave INTEGER :: kasave, kovun, kreslt, nargs, ndsave CHARACTER (6) :: nroutn ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz), mc(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mbs INTEGER :: j, kwrnsv, nds ! .. ! .. External Subroutines .. EXTERNAL fmcons, zmi2m, zmntr, zmrslt, zmwarn ! .. ! .. 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 ! .. kreslt = 0 ncall = ncall + 1 kflag = 0 namest(ncall) = nroutn IF (ntrace/=0) CALL zmntr(2,ma,mb,nargs) IF (mblogs/=mbase) CALL fmcons kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun .OR. ma(kptimu+1)==mexpov .OR. & ma(kptimu+1)==mexpun) kovun = 1 IF (nargs==2) THEN IF (mb(1)==mexpov .OR. mb(1)==mexpun .OR. mb(kptimu+1)==mexpov .OR. & mb(kptimu+1)==mexpun) kovun = 1 END IF kasave = kaccsw mxsave = mxexp ! Check the validity of parameters if this is a user call. IF (ncall>1 .AND. kdebug==0) GO TO 70 ! Check NDIG. IF (ndig<2 .OR. ndig>ndigmx) THEN kflag = -1 CALL zmwarn nds = ndig IF (ndig<2) ndig = 2 IF (ndig>ndigmx) ndig = ndigmx WRITE (kw,90000) nds, ndig kreslt = 12 GO TO 70 END IF ! Check MBASE. IF (mbase<2 .OR. mbase>mxbase) THEN kflag = -2 CALL zmwarn mbs = mbase IF (mbase<2) mbase = 2 IF (mbase>mxbase) mbase = mxbase WRITE (kw,90010) int(mbs), int(mbase) CALL fmcons kreslt = 12 GO TO 70 END IF ! Check exponent range. IF (ma(1)>mxexp+1 .OR. ma(1)<-mxexp) THEN IF ((abs(ma(1))/=mexpov .AND. abs(ma(1))/=munkno) .OR. abs(ma(2))/=1) & THEN kflag = -3 CALL zmwarn CALL zmi2m(0,ma) ma(1) = munkno ma(2) = 1 ma(kptimu+1) = munkno ma(kptimu+2) = 1 ma(0) = nint(ndig*alogm2) ma(kptimu) = nint(ndig*alogm2) kreslt = 12 GO TO 70 END IF END IF IF (ma(kptimu+1)>mxexp+1 .OR. ma(kptimu+1)<-mxexp) THEN IF ((abs(ma(kptimu+1))/=mexpov .AND. abs(ma(kptimu+1))/=munkno) .OR. & abs(ma(kptimu+2))/=1) THEN kflag = -3 CALL zmwarn CALL zmi2m(0,ma) ma(1) = munkno ma(2) = 1 ma(kptimu+1) = munkno ma(kptimu+2) = 1 ma(0) = nint(ndig*alogm2) ma(kptimu) = nint(ndig*alogm2) kreslt = 12 GO TO 70 END IF END IF IF (nargs==2) THEN IF (mb(1)>mxexp+1 .OR. mb(1)<-mxexp) THEN IF ((abs(mb(1))/=mexpov .AND. abs(mb(1))/=munkno) .OR. abs(mb( & 2))/=1) THEN kflag = -3 CALL zmwarn CALL zmi2m(0,mb) mb(1) = munkno mb(2) = 1 mb(kptimu+1) = munkno mb(kptimu+2) = 1 mb(0) = nint(ndig*alogm2) mb(kptimu) = nint(ndig*alogm2) kreslt = 12 GO TO 70 END IF END IF IF (mb(kptimu+1)>mxexp+1 .OR. mb(kptimu+1)<-mxexp) THEN IF ((abs(mb(kptimu+1))/=mexpov .AND. abs(mb(kptimu+1))/=munkno) .OR. & abs(mb(kptimu+2))/=1) THEN kflag = -3 CALL zmwarn CALL zmi2m(0,mb) mb(1) = munkno mb(2) = 1 mb(kptimu+1) = munkno mb(kptimu+2) = 1 mb(0) = nint(ndig*alogm2) mb(kptimu) = nint(ndig*alogm2) kreslt = 12 GO TO 70 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 (abs(ma(kptimu+1)-int(ma(kptimu+1)))/=0) kflag = kptimu + 1 IF (ma(2)<=(-mbase) .OR. ma(2)>=mbase .OR. abs(ma(2)-int(ma(2)))/=0) & kflag = 2 IF (ma(kptimu+2)<=(-mbase) .OR. ma(kptimu+2)>=mbase .OR. abs(ma(kptimu+ & 2)-int(ma(kptimu+2)))/=0) kflag = kptimu + 2 IF (kdebug==0) GO TO 30 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 30 END IF 10 CONTINUE DO 20 j = kptimu + 3, kptimu + ndig + 1 IF (ma(j)<0 .OR. ma(j)>=mbase .OR. abs(ma(j)-int(ma(j)))/=0) THEN kflag = j GO TO 30 END IF 20 CONTINUE 30 IF (kflag/=0) THEN j = kflag mbs = ma(j) CALL zmi2m(0,ma) kflag = -4 kwrnsv = kwarn IF (kwarn>=2) kwarn = 1 CALL zmwarn kwarn = kwrnsv IF (kwarn>=1) THEN IF (j=0) kflag = -4 ELSE IF (mcfm(1)==mexpov) THEN kflag = -5 ELSE IF (mcfm(1)==mexpun) THEN kflag = -6 END IF IF ((mcfm(1)==munkno .AND. kflag/=-9) .OR. (mcfm( & 1)==mexpun .AND. kovun==0) .OR. (mcfm(1)==mexpov .AND. kovun==0)) & CALL zmwarn IF (ntrace/=0) CALL zmntr2(1,mcfm,mcfm,1) ncall = ncall - 1 RETURN END SUBROUTINE zmexi2 SUBROUTINE zmexp(ma,mb) ! MB = EXP(MA). IMPLICIT NONE ! Scratch array usage during ZMEXP: M01 - M06, MZ01 ! .. Intrinsic Functions .. INTRINSIC min ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave INTEGER :: kasave, kovun, kreslt, krsave, kwrnsv, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmcssn, fmexp, fmi2m, fmmpyd, zmentr, zmeq2, zmexit, zmi2m ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. CALL zmentr('ZMEXP ',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN marz = ma(0) maiz = ma(kptimu) kaccsw = 0 krsave = krad krad = 1 CALL zmeq2(ma,ma,ndsave,ndig,1) ! Check for special cases. IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN CALL zmi2m(1,mz01) GO TO 10 ELSE IF (ma(2)==0) THEN CALL fmi2m(1,m06) ELSE CALL fmexp(ma,m06) END IF CALL fmcssn(ma(kptimu),mz01,mz01(kptimu)) kwrnsv = kwarn kwarn = 0 CALL fmmpyd(m06,mz01,mz01(kptimu),mz01,mz01(kptimu)) kwarn = kwrnsv 10 maccmb = mz01(0) ma(0) = marz mz01(0) = min(maccmb,marz,maiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mz01(kptimu) = min(maccmb,marz,maiz) CALL zmexit(mz01,mb,ndsave,mxsave,kasave,kovun,0) krad = krsave RETURN END SUBROUTINE zmexp SUBROUTINE zmform(form1,form2,ma,string) ! Convert MA to STRING using FORM1 format for the real part and ! FORM2 format for the imaginary part. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC len ! .. ! .. 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 .. CHARACTER (*) :: form1, form2, string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz) ! .. ! .. Local Scalars .. INTEGER :: j, kwidim, kwidre, last, lsign ! .. ! .. External Subroutines .. EXTERNAL fmeq, zmfpcm ! .. ! .. 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, jformz, jprntz, kaccsw, & kdebug, keswch, kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, & ncall, ndg2mx, ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff), cmbufz(lmbufz) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /zmbuff/cmbufz COMMON /zmuser/jformz, jprntz ! .. ncall = ncall + 1 namest(ncall) = 'ZMFORM' string = ' ' CALL zmfpcm(form1,ma,kwidre,cmbufz) CALL fmeq(ma(kptimu),m02) IF (m02(2)>=0) THEN lsign = 1 ELSE lsign = -1 m02(2) = -m02(2) END IF CALL zmfpcm(form2,m02,kwidim,cmbuff) cmbufz(kwidre+1) = ' ' IF (lsign==1) THEN cmbufz(kwidre+2) = '+' ELSE cmbufz(kwidre+2) = '-' END IF cmbufz(kwidre+3) = ' ' DO 10 j = 1, kwidim cmbufz(kwidre+3+j) = cmbuff(j) 10 CONTINUE cmbufz(kwidre+4+kwidim) = ' ' cmbufz(kwidre+5+kwidim) = 'i' IF (jformz==2) cmbufz(kwidre+5+kwidim) = 'I' last = kwidre + kwidim + 5 IF (last<=len(string)) THEN DO 20 j = 1, last string(j:j) = cmbufz(j) 20 CONTINUE ELSE DO 30 j = 1, last string(j:j) = '*' 30 CONTINUE END IF ncall = ncall - 1 RETURN END SUBROUTINE zmform SUBROUTINE zmfpcm(form,ma,kwi,cmb) ! Internal routine to convert MA to base 10 using FORM format. ! The result is returned in CMB and the field width is KWI. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, dble, index, int, len, log10, max, min, real ! .. ! .. 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 :: kwi CHARACTER (*) :: form ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(*) CHARACTER (1) :: cmb(lmbuff) ! .. ! .. Local Scalars .. INTEGER :: j, jf1sav, jf2sav, jpt, k1, k2, k3, kd, ksave, kwd, last, lb, & lengfm, lfirst, nd, nexp CHARACTER (20) :: formb ! .. ! .. External Subroutines .. EXTERNAL fmnint, fmout ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mwa(lmwa) ! .. ! .. 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 /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ksave = kflag jf1sav = jform1 jf2sav = jform2 lengfm = len(form) kwi = 75 kwd = 40 IF (index(form,'I')>0 .OR. index(form,'i')>0) THEN k1 = max(index(form,'I'),index(form,'i')) + 1 k2 = lengfm WRITE (formb,90000) k2 - k1 + 1 IF (k2>=k1) THEN READ (form(k1:k2),formb) kwi ELSE kwi = 50 END IF kwi = max(1,min(kwi,lmbuff-11)) jform1 = 2 jform2 = 0 kwd = kwi + 11 CALL fmnint(ma,m03) IF (m03(2)/=0) THEN CALL fmout(m03,cmb,kwd) ELSE DO 10 j = 1, kwd cmb(j) = ' ' 10 CONTINUE cmb(2) = '0' END IF lfirst = 1 last = 1 DO 20 j = 1, kwd IF (cmb(kwd+1-j)/=' ') lfirst = kwd + 1 - j IF (cmb(j)/=' ') last = j 20 CONTINUE jpt = 1 IF (last-lfirst+1>kwi) GO TO 110 IF (last<=kwi) THEN DO 30 j = last, lfirst, -1 jpt = kwi - last + j cmb(jpt) = cmb(j) 30 CONTINUE DO 40 j = 1, jpt - 1 cmb(j) = ' ' 40 CONTINUE ELSE DO 50 j = lfirst, last jpt = kwi - last + j cmb(jpt) = cmb(j) 50 CONTINUE END IF ELSE IF (index(form,'F')>0 .OR. index(form,'f')>0) THEN k1 = max(index(form,'F'),index(form,'f')) + 1 k2 = index(form(1:lengfm),'.') k3 = lengfm IF (k2>k1) THEN WRITE (formb,90000) k2 - k1 READ (form(k1:k2-1),formb) kwi ELSE kwi = 50 END IF IF (k3>k2) THEN WRITE (formb,90000) k3 - k2 READ (form(k2+1:k3),formb) kd ELSE kd = 0 END IF kwi = max(1,min(kwi,lmbuff)) kd = max(0,min(kd,kwi-2)) jform1 = 2 jform2 = kd nd = int(real(ndig)*log10(real(mbase))) + 1 IF (nd<2) nd = 2 nexp = int(2.0*log10(real(mxbase))) + 6 lb = max(jform2+nexp,nd+nexp) lb = min(lb,lmbuff) kwd = lb CALL fmout(ma,cmb,kwd) lfirst = 1 last = 1 DO 60 j = 1, kwd IF (cmb(kwd+1-j)/=' ') lfirst = kwd + 1 - j IF (cmb(j)/=' ') last = j 60 CONTINUE IF (last-lfirst+1>kwi) THEN ! Not enough room for this F format, or FMOUT converted ! it to E format to avoid showing no significant digits. ! See if a shortened form will fit in E format. nexp = int(log10((abs(ma(1))+1)*log10(dble(mbase))+1)+1) nd = kwi - nexp - 5 IF (nd<1) THEN GO TO 110 ELSE jform1 = 0 jform2 = nd CALL fmout(ma,cmb,kwi) lfirst = 1 last = 1 DO 70 j = 1, kwi IF (cmb(kwi+1-j)/=' ') lfirst = kwi + 1 - j IF (cmb(j)/=' ') last = j 70 CONTINUE END IF END IF jpt = 1 IF (last<=kwi) THEN DO 80 j = last, lfirst, -1 jpt = kwi - last + j cmb(jpt) = cmb(j) 80 CONTINUE DO 90 j = 1, jpt - 1 cmb(j) = ' ' 90 CONTINUE ELSE DO 100 j = lfirst, last jpt = kwi - last + j cmb(jpt) = cmb(j) 100 CONTINUE END IF ELSE IF (index(form,'1PE')>0 .OR. index(form,'1pe')>0) THEN k1 = max(index(form,'E'),index(form,'e')) + 1 k2 = index(form(1:lengfm),'.') k3 = lengfm IF (k2>k1) THEN WRITE (formb,90000) k2 - k1 READ (form(k1:k2-1),formb) kwi ELSE kwi = 50 END IF IF (k3>k2) THEN WRITE (formb,90000) k3 - k2 READ (form(k2+1:k3),formb) kd ELSE kd = 0 END IF kwi = max(1,min(kwi,lmbuff)) kd = max(0,min(kd,kwi-2)) jform1 = 1 jform2 = kd CALL fmout(ma,cmb,kwi) ELSE IF (index(form,'E')>0 .OR. index(form,'e')>0) THEN k1 = max(index(form,'E'),index(form,'e')) + 1 k2 = index(form(1:lengfm),'.') k3 = lengfm IF (k2>k1) THEN WRITE (formb,90000) k2 - k1 READ (form(k1:k2-1),formb) kwi ELSE kwi = 50 END IF IF (k3>k2) THEN WRITE (formb,90000) k3 - k2 READ (form(k2+1:k3),formb) kd ELSE kd = 0 END IF kwi = max(1,min(kwi,lmbuff)) kd = max(0,min(kd,kwi-2)) jform1 = 0 jform2 = kd CALL fmout(ma,cmb,kwi) ELSE GO TO 110 END IF jform1 = jf1sav jform2 = jf2sav kflag = ksave RETURN ! Error condition. 110 kflag = -8 DO 120 j = 1, kwi cmb(j) = '*' 120 CONTINUE jform1 = jf1sav jform2 = jf2sav kflag = ksave RETURN 90000 FORMAT ('(I',I5,')') END SUBROUTINE zmfpcm SUBROUTINE zmfprt(form1,form2,ma) ! Print MA in base 10 using FORM1 format for the real part and ! FORM2 format for the imaginary part. IMPLICIT NONE ! .. 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 .. CHARACTER (*) :: form1, form2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz) ! .. ! .. Local Scalars .. INTEGER :: j, k, kwidim, kwidre, last, lsign CHARACTER (20) :: form ! .. ! .. External Subroutines .. EXTERNAL fmeq, zmfpcm ! .. ! .. 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, jformz, jprntz, kaccsw, & kdebug, keswch, kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, & ncall, ndg2mx, ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: m01(0:lunpck), m02(0:lunpck), m03(0:lunpck), m04(0:lunpck), & m05(0:lunpck), m06(0:lunpck), mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff), cmbufz(lmbufz) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fm1/m01, m02, m03, m04, m05, m06 COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug COMMON /zmbuff/cmbufz COMMON /zmuser/jformz, jprntz ! .. ncall = ncall + 1 namest(ncall) = 'ZMFPRT' CALL zmfpcm(form1,ma,kwidre,cmbufz) CALL fmeq(ma(kptimu),m02) IF (m02(2)>=0) THEN lsign = 1 ELSE lsign = -1 m02(2) = -m02(2) END IF CALL zmfpcm(form2,m02,kwidim,cmbuff) cmbufz(kwidre+1) = ' ' IF (lsign==1) THEN cmbufz(kwidre+2) = '+' ELSE cmbufz(kwidre+2) = '-' END IF cmbufz(kwidre+3) = ' ' DO 10 j = 1, kwidim cmbufz(kwidre+3+j) = cmbuff(j) 10 CONTINUE cmbufz(kwidre+4+kwidim) = ' ' cmbufz(kwidre+5+kwidim) = 'i' IF (jformz==2) cmbufz(kwidre+5+kwidim) = 'I' last = kwidre + kwidim + 5 IF (m02(1)==mexpov .OR. m02(1)==mexpun) THEN DO 20 j = kwidre + 3, last IF (cmbufz(j)=='O' .OR. cmbufz(j)=='U') THEN cmbufz(j-2) = ' ' GO TO 30 END IF 20 CONTINUE END IF 30 WRITE (form,90000) kswide - 7 WRITE (kw,form) (cmbufz(k),k=1,last) ncall = ncall - 1 RETURN 90000 FORMAT (' (6X,',I3,'A1) ') END SUBROUTINE zmfprt SUBROUTINE zmi2m(integ,ma) ! MA = INTEG ! The real part of MA is set to the one word integer value INTEG. ! The imaginary part is set to zero. IMPLICIT NONE ! .. 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 :: integ ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz) ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmntr, zmntri ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'ZMI2M ' IF (ntrace/=0) CALL zmntri(2,integ,1) CALL fmi2m(integ,ma) CALL fmi2m(0,ma(kptimu)) IF (ntrace/=0) CALL zmntr(1,ma,ma,1) ncall = ncall - 1 RETURN END SUBROUTINE zmi2m SUBROUTINE zm2i2m(integ1,integ2,ma) ! MA = INTEG1 + INTEG2 i IMPLICIT NONE ! .. 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 :: integ1, integ2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz) ! .. ! .. External Subroutines .. EXTERNAL fmi2m, zmntr, zmntri ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'ZM2I2M' IF (ntrace/=0) THEN CALL zmntri(2,integ1,1) CALL zmntri(2,integ2,0) END IF CALL fmi2m(integ1,ma) CALL fmi2m(integ2,ma(kptimu)) IF (ntrace/=0) CALL zmntr(1,ma,ma,1) ncall = ncall - 1 RETURN END SUBROUTINE zm2i2m SUBROUTINE zmimag(ma,mbfm) ! MBFM = IMAG(MA) imaginary part of MA ! MA is a complex ZM number, MBFM is a real FM number. IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mbfm(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmntr, zmntr ! .. ! .. 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 ! .. kflag = 0 ncall = ncall + 1 namest(ncall) = 'ZMIMAG' IF (ntrace/=0) CALL zmntr(2,ma,ma,1) CALL fmeq(ma(kptimu),mbfm) IF (ntrace/=0) CALL fmntr(1,mbfm,mbfm,1) ncall = ncall - 1 RETURN END SUBROUTINE zmimag SUBROUTINE zminp(line,ma,la,lb) ! Convert an A1 character string to floating point multiple precision ! complex format. ! LINE is an A1 character array of length LB to be converted ! to ZM format and returned in MA. ! LA is a pointer telling the routine where in the array to begin ! the conversion. This allows more than one number to be stored ! in an array and converted in place. ! LB is a pointer to the last character of the field for that number. ! The input numbers may be in integer or any real format. ! In exponential format the 'E' may also be 'D', 'Q', or 'M'. ! The following are all valid input strings: ! 1.23 + 4.56 I ! 1.23 + 4.56*I ! 2 + i ! -i ! 1.23 ! 4.56i ! ( 1.23 , 4.56 ) ! So that ZMINP will convert any output from ZMOUT, LINE is tested ! to see if the input contains any of the special symbols +OVERFLOW, ! -OVERFLOW, +UNDERFLOW, -UNDERFLOW, or UNKNOWN. ! For user input the abbreviations OVFL, UNFL, UNKN may be used. IMPLICIT NONE ! Scratch array usage during ZMINP: M01 - M05 ! Simulate a finite-state automaton to scan the input line ! and build the number. States 2-8 refer to the real part, ! states 10-16 refer to the imaginary part. ! States of the machine: ! 1. Initial entry to the subroutine ! 2. Sign of the number ! 3. Scanning digits before a decimal point ! 4. Decimal point ! 5. Scanning digits after a decimal point ! 6. E, D, Q, or M - precision indicator before the exponent ! 7. Sign of the exponent ! 8. Scanning exponent ! 9. Comma between the real and imaginary part ! 10. Sign of the number ! 11. Scanning digits before a decimal point ! 12. Decimal point ! 13. Scanning digits after a decimal point ! 14. E, D, Q, or M - precision indicator before the exponent ! 15. Sign of the exponent ! 16. Scanning exponent ! 17. Syntax error ! Character types recognized by the machine: ! 1. Sign (+,-) ! 2. Numeral (0,1,...,9) ! 3. Decimal point (.) ! 4. Precision indicator (E,D,Q,M) ! 5. Illegal character for number ! 6. Comma (,) ! 7. Character to be ignored ' ' '(' ')' '*' ! All blanks are ignored. The analysis of the number proceeds as ! follows: If the simulated machine is in state JSTATE and a character ! of type JTYPE is encountered the new state of the machine is given by ! JTRANS(JSTATE,JTYPE). ! State 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 ! .. Intrinsic Functions .. INTRINSIC ichar, max, nint ! .. ! .. 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 ! .. ! .. Scalar Arguments .. INTEGER :: la, lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz) CHARACTER (1) :: line(lb) ! .. ! .. Local Scalars .. INTEGER :: j, jstate, k, kasave, kdigfl, kflag1, kiflag, kpt, krsave, & ksign, kstart, kstop, kstopi, kstopr, kstrti, kstrtr, ktype, kval, & ndsave, ntrsav ! .. ! .. Local Arrays .. INTEGER :: jtrans(16,4) ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmim, fminp, zmwarn ! .. ! .. 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 ! .. ! .. Data Statements .. DATA jtrans/2, 17, 10, 10, 10, 7, 17, 10, 10, 17, 17, 17, 17, 15, 17, & 17, 3, 3, 3, 5, 5, 8, 8, 8, 11, 11, 11, 13, 13, 16, 16, 16, 4, 4, 4, & 17, 17, 17, 17, 17, 12, 12, 12, 17, 17, 17, 17, 17, 6, 6, 6, 6, 6, 8, & 17, 17, 14, 14, 14, 14, 14, 16, 17, 17/ ! .. IF (mblogs/=mbase) CALL fmcons ncall = ncall + 1 namest(ncall) = 'ZMINP ' ndsave = ndig kasave = kaccsw krsave = kround kround = 1 kflag = 0 ! Since arithmetic tracing is not usually desired during ! I/O conversion, disable tracing during this routine. ntrsav = ntrace ntrace = 0 ! Increase the working precision. IF (ncall<=2) THEN k = ngrd52 ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL zmwarn ma(0) = nint(ndig*alogm2) ma(1) = munkno ma(2) = 1 ma(kptimu) = nint(ndig*alogm2) ma(kptimu+1) = munkno ma(kptimu+2) = 1 DO 10 j = 2, ndsave ma(j+1) = 0 ma(kptimu+j+1) = 0 10 CONTINUE GO TO 30 END IF END IF kstart = la kstop = lb jstate = 1 kstrtr = 0 kstopr = 0 kstrti = 0 kstopi = 0 kdigfl = 0 kiflag = 0 ksign = 1 ! Scan the number. DO 20 j = kstart, kstop IF (line(j)==' ' .OR. line(j)=='(' .OR. line(j)==')' .OR. & line(j)=='*') GO TO 20 IF (line(j)=='I' .OR. line(j)=='i') THEN kiflag = 1 IF (kstrti==0) THEN kstrti = kstrtr kstopi = kstopr kstrtr = 0 kstopr = 0 END IF GO TO 20 END IF kpt = ichar(line(j)) IF (kptlhash2) THEN WRITE (kw,90000) line(j), kpt, lhash1, lhash2 ktype = 5 kval = 0 ELSE ktype = khasht(kpt) kval = khashv(kpt) END IF IF (ktype==2 .OR. ktype==5) kdigfl = 1 IF (line(j)==',') THEN IF (jstate<9) THEN jstate = 9 ELSE GO TO 40 END IF ELSE IF (ktype>=5) ktype = 2 IF (jstate<17) jstate = jtrans(jstate,ktype) END IF IF (jstate==9 .OR. jstate==10) kdigfl = 0 IF (jstate==2 .OR. jstate==10) ksign = kval IF (jstate>=2 .AND. jstate<=8) THEN IF (kstrtr==0) kstrtr = j kstopr = j END IF IF (jstate>=10 .AND. jstate<=16) THEN IF (kstrti==0) kstrti = j kstopi = j END IF 20 CONTINUE ! Form the number and return. IF (kstrtr>0) THEN CALL fminp(line,ma,kstrtr,kstopr) ELSE CALL fmim(0,ma) END IF kflag1 = kflag IF (kstrti>0) THEN IF (kiflag==1 .AND. kdigfl==0) THEN CALL fmim(ksign,ma(kptimu)) ELSE CALL fminp(line,ma(kptimu),kstrti,kstopi) END IF ELSE IF (kiflag==1) THEN CALL fmim(1,ma(kptimu)) ELSE CALL fmim(0,ma(kptimu)) END IF IF (kflag1/=0 .OR. kflag/=0 .OR. jstate==17) GO TO 40 30 ndig = ndsave kaccsw = kasave ntrace = ntrsav kround = krsave IF (kflag==1) kflag = 0 ma(0) = nint(ndig*alogm2) ma(kptimu) = ma(0) ncall = ncall - 1 RETURN ! Error in converting the number. 40 kflag = -7 CALL zmwarn ma(0) = nint(ndig*alogm2) ma(1) = munkno ma(2) = 1 ma(kptimu) = nint(ndig*alogm2) ma(kptimu+1) = munkno ma(kptimu+2) = 1 DO 50 j = 2, ndsave ma(j+1) = 0 ma(kptimu+j+1) = 0 50 CONTINUE GO TO 30 90000 FORMAT (/' Error in input conversion.'/ & ' ICHAR function was out of range for the current', & ' dimensions.'/' ICHAR(''',A,''') gave the value ',I12, & ', which is outside the currently'/' dimensioned',' bounds of (',I5, & ':',I5,') for variables KHASHT ','and KHASHV.'/ & ' Re-define the two parameters ', & 'LHASH1 and LHASH2 so the dimensions will'/' contain', & ' all possible output values from ICHAR.'//) END SUBROUTINE zminp SUBROUTINE zmint(ma,mb) ! MB = INT(MA) ! The integer parts of both real and imaginary values are returned. IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. External Subroutines .. EXTERNAL fmint, zmntr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'ZMINT ' IF (ntrace/=0) CALL zmntr(2,ma,ma,1) CALL fmint(ma,mb) CALL fmint(ma(kptimu),mb(kptimu)) IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END SUBROUTINE zmint SUBROUTINE zmipwr(ma,ival,mb) ! MB = MA ** IVAL ! Raise a ZM number to an integer power. ! The binary multiplication method used requires an average of ! 1.5 * LOG2(IVAL) multiplications. IMPLICIT NONE ! Scratch array usage during ZMIPWR: M01 - M03, MZ01 - MZ02 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, mod, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: 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 :: ival ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ma2, maccmb, maiz, marz, mxsave REAL :: xval INTEGER :: i2n, j, k, kasave, kovun, kwrnsv, lvlsav, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmcons, fmim, fmipwr, fmntri, zmdiv, zmeq, zmeq2, zmexit, & zmi2m, zmmpy, zmntr, zmsqr, zmwarn ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), mz03(0:lunpkz), & mz04(0:lunpkz) 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 /zm1/mz01, mz02, mz03, mz04 ! .. ncall = ncall + 1 namest(ncall) = 'ZMIPWR' ndsave = ndig IF (ntrace/=0) THEN CALL zmntr(2,ma,ma,1) CALL fmntri(2,ival,0) END IF kovun = 0 marz = ma(0) maiz = ma(kptimu) IF (ma(1)==mexpov .OR. ma(1)==mexpun .OR. ma(kptimu+1)==mexpov .OR. & ma(kptimu+1)==mexpun) kovun = 1 IF (mblogs/=mbase) CALL fmcons kflag = 0 kasave = kaccsw mxsave = mxexp mxexp = mxexp2 ! Check for special cases. IF (ma(1)==munkno .OR. ma(kptimu+1)==munkno .OR. (ival<=0 .AND. ma( & 2)==0 .AND. ma(kptimu+2)==0)) THEN ma2 = ma(2) mb(0) = nint(ndig*alogm2) mb(1) = munkno mb(2) = 1 mb(kptimu) = nint(ndig*alogm2) mb(kptimu+1) = munkno mb(kptimu+2) = 1 DO 10 j = 2, ndsave mb(j+1) = 0 mb(kptimu+j+1) = 0 10 CONTINUE kflag = -4 IF (ival<=0 .AND. ma2==0) CALL zmwarn IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 mxexp = mxsave RETURN END IF IF (ival==0) THEN CALL zmi2m(1,mb) IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 mxexp = mxsave RETURN END IF IF (abs(ival)==1) THEN kwrnsv = kwarn kwarn = 0 IF (ival==1) THEN CALL zmeq(ma,mb) ELSE k = int((5.0D0*dlogtn)/dlogmb+2.0D0) ndig = min(max(ndig+k,2),ndg2mx) CALL zmi2m(1,mz02) CALL zmeq2(ma,ma,ndsave,ndig,1) CALL zmdiv(mz02,ma,mb) CALL zmeq2(mb,mb,ndig,ndsave,1) ndig = ndsave END IF IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 kwarn = kwrnsv mxexp = mxsave RETURN END IF IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN CALL zmi2m(0,mb) IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 mxexp = mxsave RETURN END IF IF (ma(kptimu+2)==0) THEN ncall = ncall - 1 lvlsav = lvltrc lvltrc = lvltrc - 1 CALL fmipwr(ma,ival,mb) CALL fmim(0,mb(kptimu)) ncall = ncall + 1 lvltrc = lvlsav IF (ntrace/=0) THEN namest(ncall) = 'ZMIPWR' CALL zmntr(1,mb,mb,1) END IF ncall = ncall - 1 mxexp = mxsave RETURN END IF IF (ma(2)==0) THEN ncall = ncall - 1 lvlsav = lvltrc lvltrc = lvltrc - 1 IF (ival>=0) THEN i2n = mod(ival,4) ELSE i2n = mod(4-mod(abs(ival),4),4) END IF IF (i2n==0) THEN CALL fmipwr(ma(kptimu),ival,mb) CALL fmim(0,mb(kptimu)) ELSE IF (i2n==1) THEN CALL fmipwr(ma(kptimu),ival,mb(kptimu)) CALL fmim(0,mb) ELSE IF (i2n==2) THEN CALL fmipwr(ma(kptimu),ival,mb) CALL fmim(0,mb(kptimu)) IF (mb(1)/=munkno) mb(2) = -mb(2) ELSE IF (i2n==3) THEN CALL fmipwr(ma(kptimu),ival,mb(kptimu)) CALL fmim(0,mb) IF (mb(kptimu+1)/=munkno) mb(kptimu+2) = -mb(kptimu+2) END IF ncall = ncall + 1 lvltrc = lvlsav IF (ntrace/=0) THEN namest(ncall) = 'ZMIPWR' CALL zmntr(1,mb,mb,1) END IF ncall = ncall - 1 mxexp = mxsave RETURN END IF ! Increase the working precision. IF (ncall==1) THEN xval = abs(ival) + 1 k = int((5.0*real(dlogtn)+1.5*log(xval))/alogmb+2.0) ndig = max(ndig+k,2) ELSE xval = abs(ival) + 1 k = int(log(xval)/alogmb+1.0) ndig = ndig + k END IF IF (ndig>ndg2mx) THEN kflag = -9 CALL zmwarn mb(1) = munkno mb(2) = 1 mb(kptimu+1) = munkno mb(kptimu+2) = 1 DO 20 j = 2, ndsave mb(j+1) = 0 mb(kptimu+j+1) = 0 20 CONTINUE ndig = ndsave mb(0) = nint(ndig*alogm2) mb(kptimu) = nint(ndig*alogm2) ndig = ndsave IF (ntrace/=0) CALL zmntr(1,mb,mb,1) mxexp = mxsave kaccsw = kasave ncall = ncall - 1 RETURN END IF ! Initialize. kwrnsv = kwarn kwarn = 0 k = abs(ival) CALL zmeq2(ma,mz02,ndsave,ndig,0) IF (mod(k,2)==0) THEN CALL zmi2m(1,mb) ELSE CALL zmeq(mz02,mb) END IF ! This is the multiplication loop. 30 k = k/2 CALL zmsqr(mz02,mz02) IF (mod(k,2)==1) CALL zmmpy(mz02,mb,mb) IF (k>1) GO TO 30 ! Invert if the exponent is negative. IF (ival<0) THEN CALL zmi2m(1,mz02) CALL zmdiv(mz02,mb,mb) END IF kwarn = kwrnsv ! Round the result and return. maccmb = mb(0) ma(0) = marz mb(0) = min(maccmb,marz,maiz) maccmb = mb(kptimu) ma(kptimu) = maiz mb(kptimu) = min(maccmb,marz,maiz) CALL zmexit(mb,mb,ndsave,mxsave,kasave,kovun,1) RETURN END SUBROUTINE zmipwr SUBROUTINE zmlg10(ma,mb) ! MB = LOG10(MA). IMPLICIT NONE ! Scratch array usage during ZMLG10: M01 - M05, MZ01 - MZ02 ! .. Intrinsic Functions .. INTRINSIC min ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave INTEGER :: kasave, kovun, kreslt, krsave, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmdivd, fmlni, zmentr, zmeq2, zmexit, zmln ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. CALL zmentr('ZMLG10',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN marz = ma(0) maiz = ma(kptimu) kaccsw = 0 krsave = krad krad = 1 CALL zmeq2(ma,ma,ndsave,ndig,1) CALL zmln(ma,mz02) CALL fmlni(10,m03) CALL fmdivd(mz02,mz02(kptimu),m03,mz01,mz01(kptimu)) maccmb = mz01(0) ma(0) = marz mz01(0) = min(maccmb,marz,maiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mz01(kptimu) = min(maccmb,marz,maiz) CALL zmexit(mz01,mb,ndsave,mxsave,kasave,kovun,0) krad = krsave RETURN END SUBROUTINE zmlg10 SUBROUTINE zmln(ma,mb) ! MB = LN(MA). IMPLICIT NONE ! Scratch array usage during ZMLN: M01 - M05, MZ01 ! .. Intrinsic Functions .. INTRINSIC int, min, nint ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave INTEGER :: j, kasave, kf1, kovun, kreslt, krsave, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmabs, fmadd, fmatn2, fmdiv, fmdivi, fmeq, fmi2m, fmln, fmmpy, & fmpi, fmsqr, fmsub, zmabs, zmentr, zmeq2, zmexit, zmntr, zmrslt, & zmwarn ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. CALL zmentr('ZMLN ',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN marz = ma(0) maiz = ma(kptimu) kaccsw = 0 krsave = krad krad = 1 CALL zmeq2(ma,ma,ndsave,ndig,1) ! Check for special cases. IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN kflag = -4 mz01(1) = munkno mz01(2) = 1 mz01(kptimu+1) = munkno mz01(kptimu+2) = 1 DO 10 j = 2, ndsave mz01(j+1) = 0 mz01(kptimu+j+1) = 0 10 CONTINUE mz01(0) = nint(ndig*alogm2) mz01(kptimu) = nint(ndig*alogm2) GO TO 20 ELSE IF (ma(kptimu+2)==0) THEN IF (ma(2)<0) THEN CALL fmeq(ma,mz01) IF (mz01(1)/=munkno) mz01(2) = -mz01(2) CALL fmln(mz01,mz01) CALL fmpi(mz01(kptimu)) ELSE CALL fmln(ma,mz01) CALL fmi2m(0,mz01(kptimu)) END IF GO TO 20 ELSE IF (ma(2)==0) THEN IF (ma(kptimu+2)<0) THEN CALL fmeq(ma(kptimu),mz01) IF (mz01(1)/=munkno) mz01(2) = -mz01(2) CALL fmln(mz01,mz01) CALL fmpi(mz01(kptimu)) CALL fmdivi(mz01(kptimu),-2,mz01(kptimu)) ELSE CALL fmln(ma(kptimu),mz01) CALL fmpi(mz01(kptimu)) CALL fmdivi(mz01(kptimu),2,mz01(kptimu)) END IF GO TO 20 END IF ! Ln(a + b i) = Ln(Abs(a + b i)) + Arg(a + b i) i. CALL fmabs(ma,m03) CALL fmabs(ma(kptimu),m04) ! Check for cancellation in Ln(x). CALL fmi2m(1,m05) kf1 = 0 IF (fmcomp(m03,'EQ',m05) .AND. m04(1)<=(-ndig)) kf1 = 1 IF (fmcomp(m04,'EQ',m05) .AND. m03(1)<=(-ndig)) kf1 = 1 IF (fmcomp(m03,'GE',m04)) THEN CALL fmsub(ma,m05,m03) CALL fmadd(ma,m05,m04) CALL fmmpy(m03,m04,m03) CALL fmsqr(ma(kptimu),m04) CALL fmadd(m03,m04,m04) ELSE CALL fmsub(ma(kptimu),m05,m03) CALL fmadd(ma(kptimu),m05,m04) CALL fmmpy(m03,m04,m03) CALL fmsqr(ma,m04) CALL fmadd(m03,m04,m04) END IF CALL zmabs(ma,mz01) CALL fmadd(mz01,m05,m03) CALL fmdiv(m04,m03,m03) IF (kf1==1) THEN CALL fmeq(m03,mz01) CALL fmatn2(ma(kptimu),ma,mz01(kptimu)) GO TO 20 ELSE IF (m03(1)<0) THEN ndig = ndig - int(m03(1)) IF (ndig>ndg2mx) THEN namest(ncall) = 'ZMLN ' kflag = -9 CALL zmwarn kreslt = 12 ndig = ndsave CALL zmrslt(mb,kreslt) IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 mxexp = mxsave kaccsw = kasave RETURN END IF CALL zmeq2(ma,ma,ndsave,ndig,1) CALL zmabs(ma,mz01) END IF CALL fmln(mz01,mz01) CALL fmatn2(ma(kptimu),ma,mz01(kptimu)) 20 maccmb = mz01(0) ma(0) = marz mz01(0) = min(maccmb,marz,maiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mz01(kptimu) = min(maccmb,marz,maiz) CALL zmexit(mz01,mb,ndsave,mxsave,kasave,kovun,0) krad = krsave RETURN END SUBROUTINE zmln SUBROUTINE zmm2i(ma,integ) ! INTEG = MA ! INTEG is set to the integer value of the real part of MA IMPLICIT NONE ! .. 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 :: integ ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz) ! .. ! .. External Subroutines .. EXTERNAL fmm2i, zmntr, zmntri ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'ZMM2I ' IF (ntrace/=0) CALL zmntr(2,ma,ma,1) CALL fmm2i(ma,integ) IF (ntrace/=0) CALL zmntri(1,integ,1) ncall = ncall - 1 RETURN END SUBROUTINE zmm2i SUBROUTINE zmm2z(ma,zval) ! ZVAL = MA ! Complex variable ZVAL is set to MA. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC cmplx ! .. ! .. 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 .. COMPLEX :: zval ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz) ! .. ! .. Local Scalars .. REAL :: di, dr ! .. ! .. External Subroutines .. EXTERNAL fmm2sp, zmntr, zmntrz ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'ZMM2Z ' IF (ntrace/=0) CALL zmntr(2,ma,ma,1) CALL fmm2sp(ma,dr) CALL fmm2sp(ma(kptimu),di) zval = cmplx(dr,di) IF (ntrace/=0) CALL zmntrz(1,zval,1) ncall = ncall - 1 RETURN END SUBROUTINE zmm2z SUBROUTINE zmmpy(ma,mb,mc) ! MC = MA * MB IMPLICIT NONE ! Scratch array usage during ZMMPY: M01 - M03, MZ01 ! .. Intrinsic Functions .. INTRINSIC abs, int, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz), mc(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mbiz, mbrz, mxsave, mz11sv, mzero INTEGER :: iextra, j, kasave, kmethd, kovun, kreslt, kwrnsv, ndgsv2, & ndsave, ngoal, ntrsav ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmmpy, fmmpyd, fmsub, zmentr, zmeq2, zmntr, zmrslt, & zmwarn ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. IF (abs(ma(1))>mexpab .OR. abs(ma(kptimu+1))>mexpab .OR. abs(mb(1))> & mexpab .OR. abs(mb(kptimu+1))>mexpab .OR. kdebug>=1) THEN CALL zmentr('ZMMPY ',ma,mb,2,mc,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'ZMMPY ' CALL zmntr(2,ma,mb,2) END IF ndsave = ndig IF (ncall==1) THEN ndig = max(ndig+ngrd52,2) IF (ndig>ndg2mx) THEN namest(ncall) = 'ZMMPY ' kflag = -9 CALL zmwarn kreslt = 12 ndig = ndsave CALL zmrslt(mc,kreslt) IF (ntrace/=0) CALL zmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END IF IF (mbase>=100*abs(ma(2)) .OR. mbase>=100*abs(ma(kptimu+2))) THEN ndig = min(ndig+1,ndg2mx) ELSE IF (mbase>=100*abs(mb(2)) .OR. mbase>=100*abs(mb(kptimu+ & 2))) THEN ndig = min(ndig+1,ndg2mx) END IF END IF kasave = kaccsw kaccsw = 1 mxsave = mxexp mxexp = mxexp2 kovun = 0 END IF marz = ma(0) mbrz = mb(0) maiz = ma(kptimu) mbiz = mb(kptimu) mz11sv = -munkno mzero = 0 ntrsav = ntrace ntrace = 0 kwrnsv = kwarn kwarn = 0 10 DO 20 j = ndsave + 2, ndig + 1 ma(j) = mzero mb(j) = mzero ma(kptimu+j) = mzero mb(kptimu+j) = mzero 20 CONTINUE IF (ncall==1) THEN ma(0) = nint(ndig*alogm2) mb(0) = ma(0) ma(kptimu) = ma(0) mb(kptimu) = ma(0) END IF ! Check for special cases. kmethd = 1 IF (ndig>=35) kmethd = 2 IF (mb(kptimu+2)==0) THEN CALL fmmpyd(mb,ma,ma(kptimu),mz01,mz01(kptimu)) ELSE IF (mb(2)==0) THEN CALL fmmpyd(mb(kptimu),ma(kptimu),ma,mz01,mz01(kptimu)) IF (mz01(1)/=munkno) mz01(2) = -mz01(2) ELSE IF (ma(kptimu+2)==0) THEN CALL fmmpyd(ma,mb,mb(kptimu),mz01,mz01(kptimu)) ELSE IF (ma(2)==0) THEN CALL fmmpyd(ma(kptimu),mb(kptimu),mb,mz01,mz01(kptimu)) IF (mz01(1)/=munkno) mz01(2) = -mz01(2) ELSE IF (kmethd==1) THEN ! Method 1 for ( a + b i ) * ( c + d i ) ! result = a*c - b*d + ( a*d + b*c ) i kaccsw = 0 CALL fmmpyd(ma,mb,mb(kptimu),mz01,mz01(kptimu)) CALL fmmpyd(ma(kptimu),mb(kptimu),mb,m01,m02) IF (mz01(2)*m01(2)<0) THEN kaccsw = 0 ELSE kaccsw = 1 END IF CALL fmsub(mz01,m01,mz01) IF (mz01(kptimu+2)*m02(2)<0) THEN kaccsw = 1 ELSE kaccsw = 0 END IF CALL fmadd(mz01(kptimu),m02,mz01(kptimu)) kaccsw = 1 ELSE ! Method 2 for ( a + b i ) * ( c + d i ) ! P = ( a + b )*( c + d ) ! result = a*c - b*d + ( P - a*c - b*d ) i CALL fmadd(ma,ma(kptimu),m01) CALL fmadd(mb,mb(kptimu),m02) CALL fmmpy(m01,m02,m01) CALL fmmpy(ma,mb,m02) CALL fmmpy(ma(kptimu),mb(kptimu),m03) CALL fmsub(m02,m03,mz01) CALL fmsub(m01,m02,mz01(kptimu)) CALL fmsub(mz01(kptimu),m03,mz01(kptimu)) END IF ! Check for too much cancellation. IF (ncall<=1) THEN ngoal = int(real(ndsave)*alogm2) + 7 ELSE ngoal = int(-mxexp2) END IF IF (mz01(0)<=ngoal .OR. mz01(kptimu)<=ngoal) THEN IF (mz11sv>-munkno .AND. mz01(0)>ngoal .AND. mz01(kptimu+2)==0) & GO TO 40 IF (mz11sv>-munkno .AND. mz01(kptimu)>ngoal .AND. mz01(2)==0) GO TO 40 iextra = int(real(max(ngoal-mz01(0),ngoal-mz01(kptimu)))/alogm2+23.03/ & alogmb) + 1 ndig = ndig + iextra IF (ndig>ndg2mx) THEN namest(ncall) = 'ZMMPY ' kflag = -9 CALL zmwarn mz01(1) = munkno mz01(2) = 1 mz01(kptimu+1) = munkno mz01(kptimu+2) = 1 DO 30 j = 2, ndsave mz01(j+1) = 0 mz01(kptimu+j+1) = 0 30 CONTINUE ndig = ndig - iextra mz01(0) = nint(ndig*alogm2) mz01(kptimu) = nint(ndig*alogm2) GO TO 40 END IF mz11sv = mz01(1) GO TO 10 END IF 40 mxexp = mxsave ntrace = ntrsav ndgsv2 = ndig ndig = ndsave kwarn = kwrnsv maccmb = mz01(0) ma(0) = marz mb(0) = mbrz mz01(0) = min(maccmb,marz,maiz,mbrz,mbiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mb(kptimu) = mbiz mz01(kptimu) = min(maccmb,marz,maiz,mbrz,mbiz) CALL zmeq2(mz01,mc,ndgsv2,ndsave,0) IF (mc(1)>=mexpov .OR. mc(1)<=-mexpov .OR. mc(kptimu+1)>=mexpov .OR. & mc(kptimu+1)<=-mexpov) THEN IF (mc(1)==munkno .OR. mc(kptimu+1)==munkno) THEN kflag = -4 ELSE IF (mc(1)==mexpov .OR. mc(kptimu+1)==mexpov) THEN kflag = -5 ELSE IF (mc(1)==mexpun .OR. mc(kptimu+1)==mexpun) THEN kflag = -6 END IF IF ((mc(1)==munkno) .OR. (mc(kptimu+1)==munkno) .OR. (mc(1)==mexpun & .AND. kovun==0) .OR. (mc(kptimu+1)==mexpun .AND. kovun==0) .OR. ( & mc(1)==mexpov .AND. kovun==0) .OR. (mc(kptimu+ & 1)==mexpov .AND. kovun==0)) THEN namest(ncall) = 'ZMMPY ' CALL zmwarn END IF END IF IF (ntrace/=0) CALL zmntr(1,mc,mc,1) kaccsw = kasave ncall = ncall - 1 RETURN END SUBROUTINE zmmpy SUBROUTINE zmmpyi(ma,integ,mb) ! MB = MA * INTEG Multiply by one-word (real) integer. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs ! .. ! .. 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 ! .. ! .. Scalar Arguments .. INTEGER :: integ ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mxsave INTEGER :: kasave, kovun, kreslt, kwrnsv, ndsave, ntrsav ! .. ! .. External Subroutines .. EXTERNAL fmmpyi, fmntri, zmentr, zmntr, zmwarn ! .. ! .. 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 (abs(ma(1))>mexpab .OR. abs(ma(kptimu+1))>mexpab .OR. kdebug>=1) THEN CALL zmentr('ZMMPYI',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ndig = ndsave mxexp = mxsave kaccsw = kasave ntrsav = ntrace ELSE ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'ZMMPYI' CALL zmntr(2,ma,ma,1) CALL fmntri(2,integ,0) END IF kovun = 0 END IF ! Force FMMPYI to use more guard digits for user calls. ncall = ncall - 1 ntrsav = ntrace ntrace = 0 kwrnsv = kwarn kwarn = 0 CALL fmmpyi(ma,integ,mb) CALL fmmpyi(ma(kptimu),integ,mb(kptimu)) ntrace = ntrsav kwarn = kwrnsv ncall = ncall + 1 IF (ntrace/=0) namest(ncall) = 'ZMMPYI' IF (mb(1)==munkno .OR. mb(kptimu+1)==munkno) THEN kflag = -4 ELSE IF (mb(1)==mexpov .OR. mb(kptimu+1)==mexpov) THEN kflag = -5 ELSE IF (mb(1)==mexpun .OR. mb(kptimu+1)==mexpun) THEN kflag = -6 END IF IF ((mb(1)==munkno) .OR. (mb(kptimu+1)==munkno) .OR. (mb(1)==mexpun & .AND. kovun==0) .OR. (mb(kptimu+1)==mexpun .AND. kovun==0) .OR. (mb( & 1)==mexpov .AND. kovun==0) .OR. (mb(kptimu+ & 1)==mexpov .AND. kovun==0)) THEN namest(ncall) = 'ZMMPYI' CALL zmwarn END IF IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END SUBROUTINE zmmpyi SUBROUTINE zmnint(ma,mb) ! MB = NINT(MA) ! The nearest integers to both real and imaginary parts are returned. IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. External Subroutines .. EXTERNAL fmnint, zmntr ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'ZMNINT' IF (ntrace/=0) CALL zmntr(2,ma,ma,1) CALL fmnint(ma,mb) CALL fmnint(ma(kptimu),mb(kptimu)) IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END SUBROUTINE zmnint SUBROUTINE zmntr(ntr,ma,mb,narg) ! Print ZM numbers in base 10 format using ZMOUT for conversion. ! This is used for trace output from the ZM routines. ! NTR = 1 if a result of an ZM call is to be printed. ! = 2 to print input argument(s) to an ZM call. ! MA - the ZM number to be printed. ! MB - an optional second ZM number to be printed. ! NARG - the number of arguments. NARG = 1 if only MA is to be ! printed, and NARG = 2 if both MA and MB are to be printed. ! NTRACE and LVLTRC (in COMMON /FMUSER/) control trace printout. ! NTRACE = 0 No printout except warnings and errors. ! NTRACE = 1 The result of each call to one of the routines ! is printed in base 10, using ZMOUT. ! NTRACE = -1 The result of each call to one of the routines ! is printed in internal base MBASE format. ! NTRACE = 2 The input arguments and result of each call to one ! of the routines is printed in base 10, using ZMOUT. ! NTRACE = -2 The input arguments and result of each call to one ! of the routines is printed in base MBASE format. ! LVLTRC defines the call level to which the trace is done. LVLTRC = 1 ! means only FM routines called directly by the user are traced, ! LVLTRC = K prints traces for ZM or FM routines with call ! levels up to and including level K. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. 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 :: narg, ntr ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. CHARACTER (6) :: name ! .. ! .. External Subroutines .. EXTERNAL zmntrj, zmprnt ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (ntrace==0) RETURN IF (ncall>lvltrc) RETURN IF (ntr==2 .AND. abs(ntrace)==1) RETURN IF (ntr==2) THEN name = namest(ncall) WRITE (kw,90000) name ELSE name = namest(ncall) IF (kflag==0) THEN WRITE (kw,90010) name, ncall, int(mbase), ndig ELSE WRITE (kw,90020) name, ncall, int(mbase), ndig, kflag END IF END IF ! Check for base MBASE internal format trace. IF (ntrace<0) THEN CALL zmntrj(ma,ndig) IF (narg==2) CALL zmntrj(mb,ndig) END IF ! Check for base 10 trace using ZMOUT. IF (ntrace>0) THEN CALL zmprnt(ma) IF (narg==2) THEN CALL zmprnt(mb) END IF END IF RETURN 90000 FORMAT (' Input to ',A6) 90010 FORMAT (' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10,5X,'NDIG =',I6) 90020 FORMAT (' ',A6,6X,'Call level =',I2,4X,'MBASE =',I10,4X,'NDIG =',I6,4X, & 'KFLAG =',I3) END SUBROUTINE zmntr SUBROUTINE zmntr2(ntr,mafm,mbfm,narg) ! Print real FM numbers in base 10 format using FMOUT for conversion. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. 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 :: narg, ntr ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: mafm(0:lunpck), mbfm(0:lunpck) ! .. ! .. Local Scalars .. CHARACTER (6) :: name ! .. ! .. External Subroutines .. EXTERNAL fmntrj, fmprnt ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (ntrace==0) RETURN IF (ncall>lvltrc) RETURN IF (ntr==2 .AND. abs(ntrace)==1) RETURN IF (ntr==2) THEN name = namest(ncall) WRITE (kw,90000) name ELSE name = namest(ncall) IF (kflag==0) THEN WRITE (kw,90010) name, ncall, int(mbase), ndig ELSE WRITE (kw,90020) name, ncall, int(mbase), ndig, kflag END IF END IF ! Check for base MBASE internal format trace. IF (ntrace<0) THEN CALL fmntrj(mafm,ndig) IF (narg==2) CALL fmntrj(mbfm,ndig) END IF ! Check for base 10 trace using FMOUT. IF (ntrace>0) THEN CALL fmprnt(mafm) IF (narg==2) THEN CALL fmprnt(mbfm) END IF END IF RETURN 90000 FORMAT (' Input to ',A6) 90010 FORMAT (' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10,5X,'NDIG =',I6) 90020 FORMAT (' ',A6,6X,'Call level =',I2,4X,'MBASE =',I10,4X,'NDIG =',I6,4X, & 'KFLAG =',I3) END SUBROUTINE zmntr2 SUBROUTINE zmntri(ntr,n,knam) ! Internal routine for trace output of integer variables. ! NTR = 1 for output values ! 2 for input values ! N Integer to be printed. ! KNAM is positive if the routine name is to be printed. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, int ! .. ! .. 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 :: knam, n, ntr ! .. ! .. Local Scalars .. CHARACTER (6) :: name ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (ntrace==0) RETURN IF (ncall>lvltrc) RETURN IF (ntr==2 .AND. abs(ntrace)==1) RETURN IF (ntr==2 .AND. knam>0) THEN name = namest(ncall) WRITE (kw,90000) name END IF IF (ntr==1 .AND. knam>0) THEN name = namest(ncall) IF (kflag==0) THEN WRITE (kw,90010) name, ncall, int(mbase), ndig ELSE WRITE (kw,90020) name, ncall, int(mbase), ndig, kflag END IF END IF WRITE (kw,90030) n RETURN 90000 FORMAT (' Input to ',A6) 90010 FORMAT (' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10,5X,'NDIG =',I6) 90020 FORMAT (' ',A6,6X,'Call level =',I2,4X,'MBASE =',I10,4X,'NDIG =',I6,4X, & 'KFLAG =',I3) 90030 FORMAT (1X,I18) END SUBROUTINE zmntri SUBROUTINE zmntrj(ma,nd) ! Print trace output in internal base MBASE format. The number to ! be printed is in MA. ! ND is the number of base MBASE digits to be printed. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC dble, int, log10 ! .. ! .. 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 :: nd ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz) ! .. ! .. Local Scalars .. INTEGER :: j, l, n, n1 CHARACTER (50) :: form ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. n1 = nd + 1 l = int(log10(dble(mbase-1))) + 2 n = (kswide-23)/l IF (n>10) n = 5*(n/5) IF (nd<=n) THEN WRITE (form,90000) l + 2, n - 1, l ELSE WRITE (form,90010) l + 2, n - 1, l, n, l END IF WRITE (kw,form) (int(ma(j)),j=1,n1) WRITE (kw,form) (int(ma(j+kptimu)),j=1,n1) RETURN 90000 FORMAT (' (1X,I19,I',I2,',',I3,'I',I2,') ') 90010 FORMAT (' (1X,I19,I',I2,',',I3,'I',I2,'/(22X,',I3,'I',I2,')) ') END SUBROUTINE zmntrj SUBROUTINE zmntrz(ntr,x,knam) ! Internal routine for trace output of complex variables. ! NTR - 1 for output values ! 2 for input values ! X - Complex value to be printed if NX.EQ.1 ! KNAM - Positive if the routine name is to be printed. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs, aimag, dble, int ! .. ! .. 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 .. COMPLEX :: x INTEGER :: knam, ntr ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ximag, xreal CHARACTER (6) :: name ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (ntrace==0) RETURN IF (ncall>lvltrc) RETURN IF (ntr==2 .AND. abs(ntrace)==1) RETURN IF (ntr==2 .AND. knam>0) THEN name = namest(ncall) WRITE (kw,90000) name END IF IF (ntr==1 .AND. knam>0) THEN name = namest(ncall) IF (kflag==0) THEN WRITE (kw,90010) name, ncall, int(mbase), ndig ELSE WRITE (kw,90020) name, ncall, int(mbase), ndig, kflag END IF END IF xreal = dble(x) ximag = dble(aimag(x)) IF (ximag>=0.0D0) THEN WRITE (kw,90030) xreal, ximag ELSE WRITE (kw,90040) xreal, abs(ximag) END IF RETURN 90000 FORMAT (' Input to ',A6) 90010 FORMAT (' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10,5X,'NDIG =',I6) 90020 FORMAT (' ',A6,6X,'Call level =',I2,4X,'MBASE =',I10,4X,'NDIG =',I6,4X, & 'KFLAG =',I3) 90030 FORMAT (1X,D30.20,' +',D30.20,' i') 90040 FORMAT (1X,D30.20,' -',D30.20,' i') END SUBROUTINE zmntrz SUBROUTINE zmout(ma,line,lb,last1,last2) ! Convert a floating multiple precision number to a character array ! for output. ! MA is an ZM number to be converted to an A1 character ! array in base 10 format ! LINE is the CHARACTER*1 array in which the result is returned. ! LB is the length of LINE. ! LAST1 is the position of the last nonblank character of the ! real part of the number in LINE. ! LAST2 is the position of the last nonblank character of the ! imaginary part of the number in LINE. ! JFORM1 and JFORM2 determine the format of the two FM numbers ! making up the complex value MA. See FMOUT for details. ! JFORMZ determines the format of the real and imaginary parts. ! JFORMZ = 1 normal setting : 1.23 - 4.56 i ! = 2 use capital I : 1.23 - 4.56 I ! = 3 parenthesis format ( 1.23 , -4.56 ) ! LINE should be dimensioned at least 4*(LOG10(MBASE)*NDIG + 15) on a ! 32-bit machine to allow for up to 10 digit exponents. Replace ! 15 by 20 if 48-bit integers are used, 25 for 64-bit integers, etc. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int, log10, max, min, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: 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 :: last1, last2, lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz) CHARACTER (1) :: line(lb) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maim2 INTEGER :: j, kpt, lb2, nd, nexp ! .. ! .. External Subroutines .. EXTERNAL fmout ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, jformz, jprntz, 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 COMMON /zmuser/jformz, jprntz ! .. ncall = ncall + 1 namest(ncall) = 'ZMOUT ' DO 10 j = 1, lb line(j) = ' ' 10 CONTINUE nd = int(real(ndig)*log10(real(mbase))) + 1 IF (nd<2) nd = 2 nexp = int(2.0*log10(real(mxbase))) + 6 kpt = 1 IF (jformz==3) kpt = 3 lb2 = max(jform2+nexp,nd+nexp) lb2 = min(lb+1-kpt,lb2) CALL fmout(ma,line(kpt),lb2) IF (jformz==3) line(1) = '(' last1 = 1 DO 20 j = lb2, 1, -1 IF (line(j)/=' ') THEN last1 = j GO TO 30 END IF 20 CONTINUE 30 maim2 = ma(kptimu+2) line(last1+1) = ' ' IF (jformz==3) THEN line(last1+2) = ',' ELSE IF (maim2<0) THEN ma(kptimu+2) = -ma(kptimu+2) line(last1+2) = '-' ELSE line(last1+2) = '+' END IF END IF kpt = last1 + 3 lb2 = max(jform2+nexp,nd+nexp) lb2 = min(lb+1-kpt,lb2+2) CALL fmout(ma(kptimu),line(kpt),lb2) last1 = kpt DO 40 j = lb2 + kpt - 1, kpt, -1 IF (line(j)/=' ') THEN last2 = j GO TO 50 END IF 40 CONTINUE 50 last2 = last2 + 2 line(last2) = 'i' IF (jformz==2) line(last2) = 'I' IF (jformz==3) line(last2) = ')' IF (line(kpt)==' ' .AND. line(kpt+1)=='+') THEN DO 60 j = kpt + 2, last2 line(j-2) = line(j) 60 CONTINUE line(last2-1) = ' ' line(last2) = ' ' last2 = last2 - 2 END IF ma(kptimu+2) = maim2 ncall = ncall - 1 RETURN END SUBROUTINE zmout SUBROUTINE zmpack(ma,mp) ! MA is packed two base NDIG digits per word and returned in MP. IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mp(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL fmpack ! .. CALL fmpack(ma,mp) CALL fmpack(ma(kptimu),mp(kptimp)) RETURN END SUBROUTINE zmpack SUBROUTINE zmprnt(ma) ! Print MA in base 10 format. ! ZMPRNT can be called directly by the user for easy output ! in M format. MA is converted using ZMOUT and printed. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int, log10, max, real ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz) ! .. ! .. Local Scalars .. INTEGER :: k, ksave, last1, last2, lb, lbz, nd, nexp CHARACTER (20) :: form ! .. ! .. External Subroutines .. EXTERNAL fmprnt, zmout ! .. ! .. 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, jformz, jprntz, 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), cmbufz(lmbufz) 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 COMMON /zmbuff/cmbufz COMMON /zmuser/jformz, jprntz ! .. ksave = kflag nd = int(real(ndig)*log10(real(mbase))) + 1 IF (nd<2) nd = 2 nexp = int(2.0*log10(real(mxbase))) + 6 lb = max(jform2+nexp,nd+nexp) IF (2*lb+7<=lmbufz .AND. jprntz==1) THEN lbz = 2*lb + 7 CALL zmout(ma,cmbufz,lbz,last1,last2) WRITE (form,90000) kswide - 7 WRITE (kw,form) (cmbufz(k),k=1,last2) ELSE CALL fmprnt(ma) CALL fmprnt(ma(kptimu)) END IF kflag = ksave RETURN 90000 FORMAT (' (6X,',I3,'A1) ') END SUBROUTINE zmprnt SUBROUTINE zmpwr(ma,mb,mc) ! MC = MA ** MB. IMPLICIT NONE ! Scratch array usage during ZMPWR: M01 - M06, MZ01 - MZ03 ! .. Intrinsic Functions .. INTRINSIC abs, int, log, max, min, nint ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz), mc(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mbiz, mbrz, mtemp, mxsave REAL :: xval INTEGER :: iextra, intmb, j, jcos, jsin, jswap, k, kasave, kovun, & kradsv, kreslt, kwrnsv, ndsave ! .. ! .. External Functions .. LOGICAL, EXTERNAL :: fmcomp ! .. ! .. External Subroutines .. EXTERNAL fmabs, fmadd, fmcssn, fmdivi, fmexp, fmi2m, fmmi, fmmpy, & fmmpyd, fmmpyi, fmpi, fmrdc, zm2i2m, zmentr, zmeq, zmeq2, zmexit, & zmexp, zmi2m, zmipwr, zmln, zmmpy, zmmpyi, zmntr, zmsub, zmwarn ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. CALL zmentr('ZMPWR ',ma,mb,2,mc,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN marz = ma(0) mbrz = mb(0) maiz = ma(kptimu) mbiz = mb(kptimu) kaccsw = 0 ndig = min(ndig+1,ndg2mx) CALL zmeq2(ma,ma,ndsave,ndig,1) CALL zmeq2(mb,mb,ndsave,ndig,1) ! Check for special cases. IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN IF (mb(2)>0 .AND. mb(kptimu+2)==0) THEN CALL zmi2m(0,mz02) GO TO 60 ELSE kflag = -4 mz02(1) = munkno mz02(2) = 1 mz02(kptimu+1) = munkno mz02(kptimu+2) = 1 DO 10 j = 2, ndsave mz02(j+1) = 0 mz02(kptimu+j+1) = 0 10 CONTINUE mz02(0) = nint(ndig*alogm2) mz02(kptimu) = nint(ndig*alogm2) GO TO 60 END IF END IF IF (mb(kptimu+2)==0) THEN kwrnsv = kwarn kwarn = 0 CALL fmmi(mb,intmb) kwarn = kwrnsv IF (kflag==0) THEN IF (ncall==1) THEN xval = abs(intmb) + 1 k = int((1.5*log(xval))/alogmb+2.0) ndig = max(ndig+k,2) IF (ndig>ndg2mx) THEN kflag = -9 CALL zmwarn mb(1) = munkno mb(2) = 1 mb(kptimu+1) = munkno mb(kptimu+2) = 1 DO 20 j = 2, ndsave mb(j+1) = 0 mb(kptimu+j+1) = 0 20 CONTINUE ndig = ndsave IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF IF (mbase>=100*abs(ma(2)) .OR. mbase>=100*abs(ma(kptimu+2))) THEN ndig = min(ndig+1,ndg2mx) END IF END IF CALL zmeq2(ma,ma,ndsave,ndig,1) CALL zmipwr(ma,intmb,mz03) CALL zmeq(mz03,mz02) GO TO 60 END IF END IF ! Check for cases where ABS(MA) is very close to 1, and ! avoid cancellation. CALL fmabs(ma,m03) CALL fmabs(ma(kptimu),m04) CALL fmi2m(1,m05) IF (fmcomp(m03,'EQ',m05) .AND. (m04(1)<=(-ndig) .OR. m04(2)==0)) THEN IF (ma(2)>0) THEN ! (1+c)**b = 1 + b*c + ... CALL zmi2m(1,mz02) CALL zmsub(ma,mz02,mz02) CALL zmmpy(mb,mz02,mz02) CALL fmadd(mz02,m05,mz02) ELSE ! (-1+c)**b = (-1)**b * (1 - b*c + ... ) CALL zmi2m(-1,mz02) CALL zmsub(ma,mz02,mz02) CALL zmmpy(mb,mz02,mz02) CALL zmmpyi(mz02,-1,mz02) CALL fmadd(mz02,m05,mz02) kradsv = krad krad = 0 IF (ma(kptimu+2)>=0) THEN CALL fmmpyi(mb,180,m06) ELSE CALL fmmpyi(mb,-180,m06) END IF CALL fmcssn(m06,mz03,mz03(kptimu)) krad = kradsv CALL fmpi(m05) CALL fmmpy(m05,mb(kptimu),m05) IF (ma(kptimu+2)>=0) CALL fmmpyi(m05,-1,m05) CALL fmexp(m05,m05) CALL fmmpyd(m05,mz03,mz03(kptimu),mz03,mz03(kptimu)) CALL zmmpy(mz02,mz03,mz02) END IF GO TO 60 END IF IF (fmcomp(m04,'EQ',m05) .AND. (m03(1)<=(-ndig) .OR. m03(2)==0)) THEN IF (ma(kptimu+2)>0) THEN ! (i+c)**b = i**b * (1 - b*c*i - ... ) CALL zm2i2m(0,1,mz02) CALL zmsub(ma,mz02,mz02) CALL zmmpy(mb,mz02,mz02) DO 30 j = 0, ndig + 1 mtemp = mz02(j) mz02(j) = mz02(kptimu+j) mz02(kptimu+j) = mtemp 30 CONTINUE IF (mz02(kptimu+1)/=munkno) mz02(kptimu+2) = -mz02(kptimu+2) CALL fmadd(mz02,m05,mz02) kradsv = krad krad = 0 CALL fmmpyi(mb,90,m06) CALL fmcssn(m06,mz03,mz03(kptimu)) krad = kradsv CALL fmpi(m05) CALL fmmpy(m05,mb(kptimu),m05) CALL fmdivi(m05,-2,m05) CALL fmexp(m05,m05) CALL fmmpyd(m05,mz03,mz03(kptimu),mz03,mz03(kptimu)) CALL zmmpy(mz02,mz03,mz02) ELSE ! (-i+c)**b = (-i)**b * (1 + b*c*i - ... ) CALL zm2i2m(0,-1,mz02) CALL zmsub(ma,mz02,mz02) CALL zmmpy(mb,mz02,mz02) DO 40 j = 0, ndig + 1 mtemp = mz02(j) mz02(j) = mz02(kptimu+j) mz02(kptimu+j) = mtemp 40 CONTINUE IF (mz02(1)/=munkno) mz02(2) = -mz02(2) CALL fmadd(mz02,m05,mz02) kradsv = krad krad = 0 CALL fmmpyi(mb,-90,m06) CALL fmcssn(m06,mz03,mz03(kptimu)) krad = kradsv CALL fmpi(m05) CALL fmmpy(m05,mb(kptimu),m05) CALL fmdivi(m05,2,m05) CALL fmexp(m05,m05) CALL fmmpyd(m05,mz03,mz03(kptimu),mz03,mz03(kptimu)) CALL zmmpy(mz02,mz03,mz02) END IF GO TO 60 END IF CALL zmln(ma,mz02) CALL zmmpy(mb,mz02,mz02) kwrnsv = kwarn kwarn = 0 CALL fmrdc(mz02(kptimu),mz01,jsin,jcos,jswap) kwarn = kwrnsv IF (kflag==-9) THEN iextra = int(mz01(1)) ELSE iextra = int(mz02(kptimu+1)-mz01(1)) END IF IF (iextra>1) THEN ndig = ndig + iextra IF (ndig>ndg2mx) THEN kflag = -9 CALL zmwarn mz02(1) = munkno mz02(2) = 1 mz02(kptimu+1) = munkno mz02(kptimu+2) = 1 DO 50 j = 2, ndsave mz02(j+1) = 0 mz02(kptimu+j+1) = 0 50 CONTINUE ndig = ndig - iextra mz02(0) = nint(ndig*alogm2) mz02(kptimu) = nint(ndig*alogm2) GO TO 60 END IF CALL zmeq2(ma,ma,ndsave,ndig,1) CALL zmeq2(mb,mb,ndsave,ndig,1) CALL zmln(ma,mz02) CALL zmmpy(mb,mz02,mz02) END IF CALL zmexp(mz02,mz02) 60 maccmb = mz02(0) ma(0) = marz mb(0) = mbrz mz02(0) = min(maccmb,marz,maiz,mbrz,mbiz) maccmb = mz02(kptimu) ma(kptimu) = maiz mb(kptimu) = mbiz mz02(kptimu) = min(maccmb,marz,maiz,mbrz,mbiz) CALL zmexit(mz02,mc,ndsave,mxsave,kasave,kovun,0) RETURN END SUBROUTINE zmpwr SUBROUTINE zmread(kread,ma) ! Read MA on unit KREAD. Multi-line numbers will have '&' as the ! last nonblank character on all but the last line. Only one ! number is allowed on the line(s). 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 :: 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 :: kread ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz) ! .. ! .. Local Scalars .. INTEGER :: j, lb ! .. ! .. Local Arrays .. CHARACTER (1) :: line(80) ! .. ! .. External Subroutines .. EXTERNAL zminp, zmwarn ! .. ! .. 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), cmbufz(lmbufz) 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 /zmbuff/cmbufz ! .. ncall = ncall + 1 namest(ncall) = 'ZMREAD' lb = 0 10 READ (kread,90000,err=30,end=30) line ! Scan the line and look for '&' DO 20 j = 1, 80 IF (line(j)=='&') GO TO 10 IF (line(j)/=' ') THEN lb = lb + 1 IF (lb>lmbufz) THEN kflag = -8 GO TO 40 END IF cmbufz(lb) = line(j) END IF 20 CONTINUE CALL zminp(cmbufz,ma,1,lb) ncall = ncall - 1 RETURN ! If there is an error, return UNKNOWN. 30 kflag = -4 40 CALL zmwarn ma(1) = munkno ma(2) = 1 ma(kptimu+1) = munkno ma(kptimu+2) = 1 ma(0) = nint(ndig*alogm2) ma(kptimu) = nint(ndig*alogm2) DO 50 j = 2, ndig ma(j+1) = 0 ma(kptimu+j+1) = 0 50 CONTINUE ncall = ncall - 1 RETURN 90000 FORMAT (80A1) END SUBROUTINE zmread SUBROUTINE zmreal(ma,mbfm) ! MBFM = REAL(MA) ! MA is a complex ZM number, MBFM is a real FM number. IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mbfm(0:lunpck) ! .. ! .. External Subroutines .. EXTERNAL fmeq, fmntr, zmntr ! .. ! .. 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 ! .. kflag = 0 ncall = ncall + 1 namest(ncall) = 'ZMREAL' IF (ntrace/=0) CALL zmntr(2,ma,ma,1) CALL fmeq(ma,mbfm) IF (ntrace/=0) CALL fmntr(1,mbfm,mbfm,1) ncall = ncall - 1 RETURN END SUBROUTINE zmreal SUBROUTINE zmrpwr(ma,ival,jval,mb) ! MB = MA ** (IVAL/JVAL) ! Raise a ZM number to a rational power. IMPLICIT NONE ! Scratch array usage during ZMRPWR: M01 - M03, MZ01 - MZ04 ! .. Intrinsic Functions .. INTRINSIC abs, atan2, cos, dble, int, log, max, min, nint, real, sin ! .. ! .. 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 ! .. ! .. Scalar Arguments .. INTEGER :: ival, jval ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: ar, br, f, theta, x REAL (KIND(0.0D0)) :: ma2, maccmb, maiz, marz, mr1, mxsave REAL :: xval INTEGER :: ijsign, invert, ival2, j, jval2, k, kasave, kovun, kst, l, & lval, ndsave ! .. ! .. Local Arrays .. INTEGER :: nstack(19) ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmcons, fmdig, fmdiv, fmdpm, fmgcdi, fmm2dp, fmmpy, & fmntri, fmsqr, fmsqrt, zmadd, zmdiv, zmdivi, zmeq2, zmexit, zmi2m, & zmipwr, zmmpyi, zmntr, zmsqrt, zmwarn ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. ncall = ncall + 1 namest(ncall) = 'ZMRPWR' ndsave = ndig IF (ntrace/=0) THEN CALL zmntr(2,ma,ma,1) CALL fmntri(2,ival,0) CALL fmntri(2,jval,0) END IF marz = ma(0) maiz = ma(kptimu) kovun = 0 IF (ma(1)==mexpov .OR. ma(1)==mexpun .OR. ma(kptimu+1)==mexpov .OR. & ma(kptimu+1)==mexpun) kovun = 1 IF (mblogs/=mbase) CALL fmcons kflag = 0 ijsign = 1 ival2 = abs(ival) jval2 = abs(jval) IF (ival>0 .AND. jval<0) ijsign = -1 IF (ival<0 .AND. jval>0) ijsign = -1 IF (ival2>0 .AND. jval2>0) CALL fmgcdi(ival2,jval2) ! Check for special cases. IF (ma(1)==munkno .OR. ma(kptimu+1)==munkno .OR. (ijsign<=0 .AND. ma( & 2)==0 .AND. ma(kptimu+2)==0) .OR. jval==0) THEN ma2 = ma(2) mb(0) = nint(ndig*alogm2) mb(1) = munkno mb(2) = 1 mb(kptimu) = nint(ndig*alogm2) mb(kptimu+1) = munkno mb(kptimu+2) = 1 DO 10 j = 2, ndsave mb(j+1) = 0 mb(kptimu+j+1) = 0 10 CONTINUE kflag = -4 IF (ival<=0 .AND. ma2==0) CALL zmwarn IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF IF (ival==0) THEN CALL zmi2m(1,mb) IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF ! Increase the working precision. IF (ncall==1) THEN xval = max(abs(ival),abs(jval)) + 1 k = int((5.0*real(dlogtn)+log(xval))/alogmb+2.0) ndig = max(ndig+k,2) ELSE xval = max(abs(ival),abs(jval)) + 1 k = int(log(xval)/alogmb+1.0) ndig = ndig + k END IF IF (ndig>ndg2mx) THEN kflag = -9 CALL zmwarn mb(1) = munkno mb(2) = 1 mb(kptimu+1) = munkno mb(kptimu+2) = 1 DO 20 j = 2, ndsave mb(j+1) = 0 mb(kptimu+j+1) = 0 20 CONTINUE ndig = ndsave mb(0) = nint(ndig*alogm2) mb(kptimu) = nint(ndig*alogm2) ndig = ndsave IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF IF (mbase>=100*abs(ma(2)) .OR. mbase>=100*abs(ma(kptimu+2))) THEN ndig = min(ndig+1,ndg2mx) END IF kasave = kaccsw mxsave = mxexp mxexp = mxexp2 CALL zmeq2(ma,mz04,ndsave,ndig,0) IF (ival2==1 .AND. jval2==2) THEN CALL zmsqrt(mz04,mb) GO TO 50 END IF ! Generate the first approximation to MA**(1/JVAL2). CALL zmi2m(0,mb) CALL fmdig(nstack,kst) ndig = nstack(1) CALL fmsqr(mz04,mz03) CALL fmsqr(mz04(kptimu),m03) CALL fmadd(mz03,m03,mz03) CALL fmsqrt(mz03,mz03) IF (mz03(1)>=mexpov) THEN kflag = -4 CALL zmwarn mb(1) = munkno mb(2) = 1 mb(kptimu+1) = munkno mb(kptimu+2) = 1 DO 30 j = 2, ndsave mb(j+1) = 0 mb(kptimu+j+1) = 0 30 CONTINUE ndig = ndsave mb(0) = nint(ndig*alogm2) mb(kptimu) = nint(ndig*alogm2) mxexp = mxsave kaccsw = kasave ndig = ndsave IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF ! Invert MA if ABS(MA) > 1 and IVAL or JVAL is large. invert = 0 IF (ival>5 .OR. jval>5) THEN IF (mz03(1)>0) THEN invert = 1 ndig = nstack(kst) CALL zmi2m(1,mb) CALL zmdiv(mb,mz04,mz04) ndig = nstack(1) CALL fmdiv(mb,mz03,mz03) END IF END IF CALL fmdiv(mz04,mz03,m03) CALL fmm2dp(m03,ar) CALL fmdiv(mz04(kptimu),mz03,m03) CALL fmm2dp(m03,br) mr1 = mz03(1) mz03(1) = 0 CALL fmm2dp(mz03,x) l = int(mr1/jval2) f = mr1/dble(jval2) - l x = x**(1.0D0/jval2)*dble(mbase)**f CALL fmdpm(x,m03) m03(1) = m03(1) + l theta = atan2(br,ar) x = cos(theta/jval2) CALL fmdpm(x,mb) x = sin(theta/jval2) CALL fmdpm(x,mb(kptimu)) CALL fmmpy(m03,mb,mb) CALL fmmpy(m03,mb(kptimu),mb(kptimu)) ! Newton iteration. DO 40 j = 1, kst ndig = nstack(j) IF (j15) THEN CALL zmi2m(0,mc) mc(1) = munkno mc(2) = 1 mc(0) = nint(ndig*alogm2) mc(kptimu+1) = munkno mc(kptimu+2) = 1 mc(kptimu) = nint(ndig*alogm2) kflag = kfsave RETURN END IF RETURN END SUBROUTINE zmrslt SUBROUTINE zmsin(ma,mb) ! MB = SIN(MA). IMPLICIT NONE ! Scratch array usage during ZMSIN: M01 - M06, MZ01 - MZ03 ! .. Intrinsic Functions .. INTRINSIC min ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave INTEGER :: kasave, kovun, kreslt, krsave, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmchsh, fmcssn, fmi2m, fmmpy, fmsin, fmsinh, zmentr, zmeq, & zmeq2, zmexit, zmi2m ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. CALL zmentr('ZMSIN ',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN marz = ma(0) maiz = ma(kptimu) kaccsw = 0 krsave = krad krad = 1 CALL zmeq2(ma,ma,ndsave,ndig,1) ! Check for special cases. IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN CALL zmi2m(0,mz01) GO TO 10 ELSE IF (ma(1)<(-ndig) .AND. ma(kptimu+1)<(-ndig)) THEN CALL zmeq(ma,mz01) GO TO 10 ELSE IF (ma(kptimu+2)==0) THEN CALL fmsin(ma,mz01) CALL fmi2m(0,mz01(kptimu)) GO TO 10 ELSE IF (ma(2)==0) THEN CALL fmsinh(ma(kptimu),mz01(kptimu)) CALL fmi2m(0,mz01) GO TO 10 END IF ! Find COS(REAL(MA)) and SIN(REAL(MA)). CALL fmcssn(ma,mz01(kptimu),mz01) ! Find COSH(IMAG(MA)) and SINH(IMAG(MA)). CALL fmchsh(ma(kptimu),m05,m06) ! SIN(MA) = SIN(REAL(MA))*COSH(IMAG(MA)) + ! COS(REAL(MA))*SINH(IMAG(MA)) i CALL fmmpy(mz01,m05,mz01) CALL fmmpy(mz01(kptimu),m06,mz01(kptimu)) 10 maccmb = mz01(0) ma(0) = marz mz01(0) = min(maccmb,marz,maiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mz01(kptimu) = min(maccmb,marz,maiz) CALL zmexit(mz01,mb,ndsave,mxsave,kasave,kovun,0) krad = krsave RETURN END SUBROUTINE zmsin SUBROUTINE zmsinh(ma,mb) ! MB = SINH(MA). IMPLICIT NONE ! Scratch array usage during ZMSINH: M01 - M06, MZ01 - MZ03 ! .. Intrinsic Functions .. INTRINSIC min ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave INTEGER :: kasave, kovun, kreslt, krsave, ndsave ! .. ! .. External Subroutines .. EXTERNAL fmchsh, fmcssn, fmi2m, fmmpy, fmsin, fmsinh, zmentr, zmeq, & zmeq2, zmexit, zmi2m ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. CALL zmentr('ZMSINH',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN marz = ma(0) maiz = ma(kptimu) kaccsw = 0 krsave = krad krad = 1 CALL zmeq2(ma,ma,ndsave,ndig,1) ! Check for special cases. IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN CALL zmi2m(0,mz01) GO TO 10 ELSE IF (ma(1)<(-ndig) .AND. ma(kptimu+1)<(-ndig)) THEN CALL zmeq(ma,mz01) GO TO 10 ELSE IF (ma(2)==0) THEN CALL fmsin(ma(kptimu),mz01(kptimu)) CALL fmi2m(0,mz01) GO TO 10 ELSE IF (ma(kptimu+2)==0) THEN CALL fmsinh(ma,mz01) CALL fmi2m(0,mz01(kptimu)) GO TO 10 END IF ! Find SIN(IMAG(MA)) and COS(IMAG(MA)). CALL fmcssn(ma(kptimu),mz01,mz01(kptimu)) ! Find SINH(REAL(MA)) and COSH(REAL(MA)). CALL fmchsh(ma,m05,m06) ! SINH(MA) = SINH(REAL(MA))*COS(IMAG(MA)) + ! COSH(REAL(MA))*SIN(IMAG(MA)) i CALL fmmpy(mz01,m06,mz01) CALL fmmpy(mz01(kptimu),m05,mz01(kptimu)) 10 maccmb = mz01(0) ma(0) = marz mz01(0) = min(maccmb,marz,maiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mz01(kptimu) = min(maccmb,marz,maiz) CALL zmexit(mz01,mb,ndsave,mxsave,kasave,kovun,0) krad = krsave RETURN END SUBROUTINE zmsinh SUBROUTINE zmsqr(ma,mb) ! MB = MA * MA IMPLICIT NONE ! Scratch array usage during ZMSQR: M01 - M03, MZ01 ! .. Intrinsic Functions .. INTRINSIC abs, max, min, nint ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave, mzero INTEGER :: j, kasave, kovun, kreslt, kwrnsv, ndgsv2, ndsave, ntrsav ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmi2m, fmmpy, fmsqr, fmsub, zmentr, zmeq2, zmntr, & zmrslt, zmwarn ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. IF (abs(ma(1))>mexpab .OR. abs(ma(kptimu+1))>mexpab .OR. kdebug>=1) THEN CALL zmentr('ZMSQR ',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'ZMSQR ' CALL zmntr(2,ma,ma,1) END IF ndsave = ndig IF (ncall==1) THEN ndig = max(ndig+ngrd52,2) IF (ndig>ndg2mx) THEN namest(ncall) = 'ZMSQR ' kflag = -9 CALL zmwarn kreslt = 12 ndig = ndsave CALL zmrslt(mb,kreslt) IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF IF (mbase>=100*abs(ma(2)) .OR. mbase>=100*abs(ma(kptimu+2))) THEN ndig = min(ndig+1,ndg2mx) END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 kovun = 0 END IF marz = ma(0) maiz = ma(kptimu) mzero = 0 ntrsav = ntrace ntrace = 0 kwrnsv = kwarn kwarn = 0 DO 10 j = ndsave + 2, ndig + 1 ma(j) = mzero ma(kptimu+j) = mzero 10 CONTINUE IF (ncall==1) THEN ma(0) = nint(ndig*alogm2) ma(kptimu) = ma(0) END IF ! Check for special cases. IF (ma(kptimu+2)==0) THEN CALL fmsqr(ma,mz01) CALL fmi2m(0,mz01(kptimu)) ELSE IF (ma(2)==0) THEN CALL fmsqr(ma(kptimu),mz01) IF (mz01(1)/=munkno) mz01(2) = -mz01(2) CALL fmi2m(0,mz01(kptimu)) ELSE CALL fmadd(ma,ma(kptimu),m02) CALL fmsub(ma,ma(kptimu),m03) CALL fmmpy(m02,m03,mz01) CALL fmmpy(ma,ma(kptimu),m03) CALL fmadd(m03,m03,mz01(kptimu)) END IF mxexp = mxsave ntrace = ntrsav ndgsv2 = ndig ndig = ndsave kwarn = kwrnsv IF (ncall==1) THEN ma(0) = marz ma(kptimu) = maiz END IF maccmb = mz01(0) ma(0) = marz mz01(0) = min(maccmb,marz,maiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mz01(kptimu) = min(maccmb,marz,maiz) kaccsw = kasave CALL zmeq2(mz01,mb,ndgsv2,ndsave,0) IF (mb(1)>=mexpov .OR. mb(1)<=-mexpov .OR. mb(kptimu+1)>=mexpov .OR. & mb(kptimu+1)<=-mexpov) THEN IF (mb(1)==munkno .OR. mb(kptimu+1)==munkno) THEN kflag = -4 ELSE IF (mb(1)==mexpov .OR. mb(kptimu+1)==mexpov) THEN kflag = -5 ELSE IF (mb(1)==mexpun .OR. mb(kptimu+1)==mexpun) THEN kflag = -6 END IF IF ((mb(1)==munkno) .OR. (mb(kptimu+1)==munkno) .OR. (mb(1)==mexpun & .AND. kovun==0) .OR. (mb(kptimu+1)==mexpun .AND. kovun==0) .OR. ( & mb(1)==mexpov .AND. kovun==0) .OR. (mb(kptimu+ & 1)==mexpov .AND. kovun==0)) THEN namest(ncall) = 'ZMSQR ' CALL zmwarn END IF END IF IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END SUBROUTINE zmsqr SUBROUTINE zmsqrt(ma,mb) ! MB = SQRT(MA). Principal Square Root. IMPLICIT NONE ! Scratch array usage during ZMSQRT: M01 - M03, MZ01 ! .. Intrinsic Functions .. INTRINSIC abs, max, min ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave INTEGER :: kasave, kovun, kreslt, kwrnsv, ndsave, ntrsav ! .. ! .. External Subroutines .. EXTERNAL fmabs, fmadd, fmdiv, fmdivi, fmeq, fmsqr, fmsqrt, zmentr, & zmeq2, zmi2m, zmntr, zmrslt, zmwarn ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. IF (abs(ma(1))>mexpab .OR. abs(ma(kptimu+1))>mexpab .OR. kdebug>=1) THEN CALL zmentr('ZMSQRT',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ELSE ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'ZMSQRT' CALL zmntr(2,ma,ma,1) END IF ndsave = ndig IF (ncall==1) THEN ndig = max(ndig+ngrd52,2) IF (ndig>ndg2mx) THEN namest(ncall) = 'ZMSQRT' kflag = -9 CALL zmwarn kreslt = 12 ndig = ndsave CALL zmrslt(mb,kreslt) IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END IF IF (mbase>=100*abs(ma(2)) .OR. mbase>=100*abs(ma(kptimu+2))) THEN ndig = min(ndig+1,ndg2mx) END IF END IF kasave = kaccsw kaccsw = 0 mxsave = mxexp mxexp = mxexp2 kovun = 0 END IF ntrsav = ntrace ntrace = 0 kwrnsv = kwarn kwarn = 0 marz = ma(0) maiz = ma(kptimu) CALL zmeq2(ma,ma,ndsave,ndig,1) ! Check for special cases. IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN CALL zmi2m(0,mz01) GO TO 10 ELSE IF (ma(2)==0) THEN CALL fmabs(ma(kptimu),m01) CALL fmdivi(m01,2,m03) CALL fmsqrt(m03,m03) ELSE IF (ma(kptimu+2)==0) THEN CALL fmabs(ma,m03) CALL fmsqrt(m03,m03) ELSE CALL fmsqr(ma,m01) CALL fmsqr(ma(kptimu),m02) CALL fmadd(m01,m02,m03) CALL fmsqrt(m03,m03) CALL fmabs(ma,m02) CALL fmadd(m02,m03,m03) CALL fmdivi(m03,2,m03) CALL fmsqrt(m03,m03) END IF CALL fmadd(m03,m03,m02) IF (ma(2)>=0) THEN CALL fmdiv(ma(kptimu),m02,mz01(kptimu)) CALL fmeq(m03,mz01) ELSE IF (ma(kptimu+2)>=0) THEN CALL fmdiv(ma(kptimu),m02,mz01) CALL fmeq(m03,mz01(kptimu)) ELSE CALL fmdiv(ma(kptimu),m02,mz01) CALL fmeq(m03,mz01(kptimu)) IF (mz01(1)/=munkno) mz01(2) = -mz01(2) IF (mz01(kptimu+1)/=munkno) mz01(kptimu+2) = -mz01(kptimu+2) END IF END IF 10 mxexp = mxsave maccmb = mz01(0) ma(0) = marz mz01(0) = min(maccmb,marz,maiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mz01(kptimu) = min(maccmb,marz,maiz) kaccsw = kasave CALL zmeq2(mz01,mb,ndig,ndsave,0) IF (mb(1)==munkno .OR. mb(kptimu+1)==munkno) THEN kflag = -4 ELSE IF (mb(1)==mexpov .OR. mb(kptimu+1)==mexpov) THEN kflag = -5 ELSE IF (mb(1)==mexpun .OR. mb(kptimu+1)==mexpun) THEN kflag = -6 END IF ntrace = ntrsav ndig = ndsave kwarn = kwrnsv IF ((mb(1)==munkno) .OR. (mb(kptimu+1)==munkno) .OR. (mb(1)==mexpun & .AND. kovun==0) .OR. (mb(kptimu+1)==mexpun .AND. kovun==0) .OR. (mb( & 1)==mexpov .AND. kovun==0) .OR. (mb(kptimu+ & 1)==mexpov .AND. kovun==0)) THEN namest(ncall) = 'ZMSQRT' CALL zmwarn END IF IF (ntrace/=0) CALL zmntr(1,mb,mb,1) ncall = ncall - 1 RETURN END SUBROUTINE zmsqrt SUBROUTINE zmst2m(string,ma) ! MA = STRING ! Convert a character string to FM format. ! This is often more convenient than using ZMINP, which converts an ! array of CHARACTER*1 values. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC len ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: 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 .. CHARACTER (*) :: string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz) ! .. ! .. Local Scalars .. INTEGER :: j, lb ! .. ! .. External Subroutines .. EXTERNAL zminp ! .. ! .. 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), cmbufz(lmbufz) 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 /zmbuff/cmbufz COMMON /zmuser/jformz, jprntz ! .. ncall = ncall + 1 namest(ncall) = 'ZMST2M' lb = len(string) DO 10 j = 1, lb cmbufz(j) = string(j:j) 10 CONTINUE CALL zminp(cmbufz,ma,1,lb) ncall = ncall - 1 RETURN END SUBROUTINE zmst2m SUBROUTINE zmsub(ma,mb,mc) ! MC = MA - MB IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC abs ! .. ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz), mc(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: mxsave INTEGER :: kasave, kf1, kovun, kreslt, kwrnsv, ndsave, ntrsav ! .. ! .. External Subroutines .. EXTERNAL fmsub, zmentr, zmntr, zmwarn ! .. ! .. 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 (abs(ma(1))>mexpab .OR. abs(ma(kptimu+1))>mexpab .OR. abs(mb(1))> & mexpab .OR. abs(mb(kptimu+1))>mexpab .OR. kdebug>=1) THEN CALL zmentr('ZMSUB ',ma,mb,2,mc,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN ndig = ndsave mxexp = mxsave kaccsw = kasave ELSE ncall = ncall + 1 IF (ntrace/=0) THEN namest(ncall) = 'ZMSUB ' CALL zmntr(2,ma,mb,2) END IF kovun = 0 END IF ! Force FMSUB to use more guard digits for user calls. ncall = ncall - 1 ntrsav = ntrace ntrace = 0 kwrnsv = kwarn kwarn = 0 CALL fmsub(ma,mb,mc) kf1 = kflag CALL fmsub(ma(kptimu),mb(kptimu),mc(kptimu)) ntrace = ntrsav kwarn = kwrnsv ncall = ncall + 1 IF (ntrace/=0) namest(ncall) = 'ZMSUB ' IF (kflag==1) kflag = kf1 IF (mc(1)==munkno .OR. mc(kptimu+1)==munkno) THEN kflag = -4 ELSE IF (mc(1)==mexpov .OR. mc(kptimu+1)==mexpov) THEN kflag = -5 ELSE IF (mc(1)==mexpun .OR. mc(kptimu+1)==mexpun) THEN kflag = -6 END IF IF ((mc(1)==munkno) .OR. (mc(kptimu+1)==munkno) .OR. (mc(1)==mexpun & .AND. kovun==0) .OR. (mc(kptimu+1)==mexpun .AND. kovun==0) .OR. (mc( & 1)==mexpov .AND. kovun==0) .OR. (mc(kptimu+ & 1)==mexpov .AND. kovun==0)) THEN namest(ncall) = 'ZMSUB ' CALL zmwarn END IF IF (ntrace/=0) CALL zmntr(1,mc,mc,1) ncall = ncall - 1 RETURN END SUBROUTINE zmsub SUBROUTINE zmtan(ma,mb) ! MB = TAN(MA). IMPLICIT NONE ! Scratch array usage during ZMTAN: M01 - M06, MZ01 - MZ03 ! .. Intrinsic Functions .. INTRINSIC int, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave INTEGER :: iextra, j, kasave, kovun, kreslt, krsave, ndsave, ngoal ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmchsh, fmcssn, fmdiv, fmdivd, fmi2m, fmim, fmtan, & fmtanh, zmentr, zmeq, zmeq2, zmexit, zmi2m, zmwarn ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. CALL zmentr('ZMTAN ',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN marz = ma(0) maiz = ma(kptimu) krsave = krad krad = 1 10 CALL zmeq2(ma,ma,ndsave,ndig,1) ! Check for special cases. IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN CALL zmi2m(0,mz01) GO TO 20 ELSE IF (ma(1)<(-ndig) .AND. ma(kptimu+1)<(-ndig)) THEN CALL zmeq(ma,mz01) GO TO 20 ELSE IF (ma(kptimu+2)==0) THEN CALL fmtan(ma,mz01) CALL fmi2m(0,mz01(kptimu)) GO TO 20 ELSE IF (ma(2)==0) THEN CALL fmtanh(ma(kptimu),mz01(kptimu)) CALL fmi2m(0,mz01) GO TO 20 END IF ! Find SIN(2*REAL(MA)) and COS(2*REAL(MA)). CALL fmadd(ma,ma,mz01) CALL fmcssn(mz01,mz01(kptimu),mz01) ! Find SINH(2*IMAG(MA)) and COSH(2*IMAG(MA)). CALL fmadd(ma(kptimu),ma(kptimu),m06) CALL fmchsh(m06,m05,m06) ! TAN(MA) = SIN(2*REAL(MA)) / ! (COS(2*REAL(MA))+COSH(2*IMAG(MA)) + ! SINH(2*IMAG(MA)) / ! (COS(2*REAL(MA))+COSH(2*IMAG(MA)) i CALL fmadd(mz01(kptimu),m05,m05) IF (m05(2)==0) THEN mz01(0) = 0 ngoal = int(real(ndsave)*alogm2) + 7 GO TO 30 ELSE IF (m05(1)==mexpov) THEN CALL fmdiv(mz01,m05,mz01) CALL fmim(1,mz01(kptimu)) IF (m06(2)<0) mz01(kptimu+2) = -mz01(kptimu+2) ELSE CALL fmdivd(mz01,m06,m05,mz01,mz01(kptimu)) END IF ! Check for too much cancellation. 20 IF (ncall<=1) THEN ngoal = int(real(ndsave)*alogm2) + 7 ELSE ngoal = int(-mxexp2) END IF 30 IF (mz01(0)<=ngoal .OR. mz01(kptimu)<=ngoal) THEN iextra = int(real(max(ngoal-mz01(0),ngoal-mz01(kptimu)))/alogm2+23.03/ & alogmb) + 1 ndig = ndig + iextra IF (ndig>ndg2mx) THEN kflag = -9 CALL zmwarn mz01(1) = munkno mz01(2) = 1 mz01(kptimu+1) = munkno mz01(kptimu+2) = 1 DO 40 j = 2, ndsave mz01(j+1) = 0 mz01(kptimu+j+1) = 0 40 CONTINUE ndig = ndig - iextra mz01(0) = nint(ndig*alogm2) mz01(kptimu) = nint(ndig*alogm2) GO TO 50 END IF GO TO 10 END IF 50 maccmb = mz01(0) ma(0) = marz mz01(0) = min(maccmb,marz,maiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mz01(kptimu) = min(maccmb,marz,maiz) CALL zmexit(mz01,mb,ndsave,mxsave,kasave,kovun,0) krad = krsave RETURN END SUBROUTINE zmtan SUBROUTINE zmtanh(ma,mb) ! MB = TANH(MA). IMPLICIT NONE ! Scratch array usage during ZMTANH: M01 - M06, MZ01 - MZ03 ! .. Intrinsic Functions .. INTRINSIC int, max, min, nint, real ! .. ! .. Parameters .. INTEGER, PARAMETER :: lhash1 = 0, lhash2 = 256, nbits = 64, ndigmx = 256 INTEGER, PARAMETER :: lpack = (ndigmx+1)/2 + 1 INTEGER, PARAMETER :: 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mb(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: maccmb, maiz, marz, mxsave INTEGER :: iextra, j, kasave, kovun, kreslt, krsave, ndsave, ngoal ! .. ! .. External Subroutines .. EXTERNAL fmadd, fmchsh, fmcssn, fmdiv, fmdivd, fmi2m, fmim, fmtan, & fmtanh, zmentr, zmeq, zmeq2, zmexit, zmi2m, zmwarn ! .. ! .. 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), mz01(0:lunpkz), mz02(0:lunpkz), & mz03(0:lunpkz), mz04(0:lunpkz) 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 COMMON /zm1/mz01, mz02, mz03, mz04 ! .. CALL zmentr('ZMTANH',ma,ma,1,mb,kreslt,ndsave,mxsave,kasave,kovun) IF (kreslt/=0) RETURN marz = ma(0) maiz = ma(kptimu) krsave = krad krad = 1 10 CALL zmeq2(ma,ma,ndsave,ndig,1) ! Check for special cases. IF (ma(2)==0 .AND. ma(kptimu+2)==0) THEN CALL zmi2m(0,mz01) GO TO 20 ELSE IF (ma(1)<(-ndig) .AND. ma(kptimu+1)<(-ndig)) THEN CALL zmeq(ma,mz01) GO TO 20 ELSE IF (ma(2)==0) THEN CALL fmtan(ma(kptimu),mz01(kptimu)) CALL fmi2m(0,mz01) GO TO 20 ELSE IF (ma(kptimu+2)==0) THEN CALL fmtanh(ma,mz01) CALL fmi2m(0,mz01(kptimu)) GO TO 20 END IF ! Find SIN(2*IMAG(MA)) and COS(2*IMAG(MA)). CALL fmadd(ma(kptimu),ma(kptimu),mz01) CALL fmcssn(mz01,mz01(kptimu),mz01) ! Find SINH(2*REAL(MA)) and COSH(2*REAL(MA)). CALL fmadd(ma,ma,m06) CALL fmchsh(m06,m05,m06) ! TANH(MA) = SINH(2*REAL(MA)) / ! (COS(2*IMAG(MA))+COSH(2*REAL(MA)) + ! SIN(2*IMAG(MA)) / ! (COS(2*IMAG(MA))+COSH(2*REAL(MA)) i CALL fmadd(mz01(kptimu),m05,m05) IF (m05(2)==0) THEN mz01(0) = 0 ngoal = int(real(ndsave)*alogm2) + 7 GO TO 30 ELSE IF (m05(1)==mexpov) THEN CALL fmdiv(mz01,m05,mz01(kptimu)) CALL fmim(1,mz01) IF (m06(2)<0) mz01(2) = -mz01(2) ELSE CALL fmdivd(mz01,m06,m05,mz01(kptimu),mz01) END IF ! Check for too much cancellation. 20 IF (ncall<=1) THEN ngoal = int(real(ndsave)*alogm2) + 7 ELSE ngoal = int(-mxexp2) END IF 30 IF (mz01(0)<=ngoal .OR. mz01(kptimu)<=ngoal) THEN iextra = int(real(max(ngoal-mz01(0),ngoal-mz01(kptimu)))/alogm2+23.03/ & alogmb) + 1 ndig = ndig + iextra IF (ndig>ndg2mx) THEN kflag = -9 CALL zmwarn mz01(1) = munkno mz01(2) = 1 mz01(kptimu+1) = munkno mz01(kptimu+2) = 1 DO 40 j = 2, ndsave mz01(j+1) = 0 mz01(kptimu+j+1) = 0 40 CONTINUE ndig = ndig - iextra mz01(0) = nint(ndig*alogm2) mz01(kptimu) = nint(ndig*alogm2) GO TO 50 END IF GO TO 10 END IF 50 maccmb = mz01(0) ma(0) = marz mz01(0) = min(maccmb,marz,maiz) maccmb = mz01(kptimu) ma(kptimu) = maiz mz01(kptimu) = min(maccmb,marz,maiz) CALL zmexit(mz01,mb,ndsave,mxsave,kasave,kovun,0) krad = krsave RETURN END SUBROUTINE zmtanh SUBROUTINE zmunpk(mp,ma) ! MP is unpacked and the value returned in MA. IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz), mp(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL fmunpk ! .. CALL fmunpk(mp,ma) CALL fmunpk(mp(kptimp),ma(kptimu)) RETURN END SUBROUTINE zmunpk SUBROUTINE zmwarn ! Called by one of the ZM routines to print a warning message ! if any error condition arises in that routine. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int ! .. ! .. 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 ! .. ! .. Local Scalars .. INTEGER :: ncs CHARACTER (6) :: name ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. IF (kflag>=0 .OR. ncall/=1 .OR. kwarn<=0) RETURN ncs = ncall name = namest(ncall) WRITE (kw,90000) kflag, name 10 ncall = ncall - 1 IF (ncall>0) THEN name = namest(ncall) WRITE (kw,90010) name GO TO 10 END IF IF (kflag==-1) THEN WRITE (kw,90020) ndigmx ELSE IF (kflag==-2) THEN WRITE (kw,90030) int(mxbase) ELSE IF (kflag==-3) THEN WRITE (kw,90040) WRITE (kw,90050) ELSE IF (kflag==-4 .OR. kflag==-7) THEN WRITE (kw,90060) WRITE (kw,90050) ELSE IF (kflag==-5) THEN WRITE (kw,90070) ELSE IF (kflag==-6) THEN WRITE (kw,90080) ELSE IF (kflag==-8 .AND. name=='ZMOUT ') THEN WRITE (kw,90090) ELSE IF (kflag==-8 .AND. name=='ZMREAD') THEN WRITE (kw,90100) ELSE IF (kflag==-9) THEN WRITE (kw,90110) WRITE (kw,90120) ndig, ndg2mx WRITE (kw,90050) END IF ncall = ncs IF (kwarn>=2) THEN STOP END IF RETURN 90000 FORMAT (/' Error of type KFLAG =',I3,' in FM package in routine ',A6/) 90010 FORMAT (' called from ',A6) 90020 FORMAT (' NDIG must be between 2 and',I10/) 90030 FORMAT (' MBASE must be between 2 and',I10/) 90040 FORMAT (' An input argument is not a valid FM number.', & ' Its exponent is out of range.'/) 90050 FORMAT (' UNKNOWN has been returned.'/) 90060 FORMAT (' Invalid input argument for this routine.'/) 90070 FORMAT (' The result has overflowed.'/) 90080 FORMAT (' The result has underflowed.'/) 90090 FORMAT (' The result array is not big enough to hold the', & ' output character string'/' in the current format.'/ & ' The result ''***...***'' has been returned.'/) 90100 FORMAT (' The CMBUFF array is not big enough to hold the', & ' input character string'/' UNKNOWN has been returned.'/) 90110 FORMAT (' Precision could not be raised enough to provide all', & ' requested guard digits.'/) 90120 FORMAT (I23,' digits were requested (NDIG).'/ & ' Maximum number of digits currently available',' (NDG2MX) is',I7, & '.'/) END SUBROUTINE zmwarn SUBROUTINE zmwrit(kwrite,ma) ! Write MA on unit KWRITE under the current format. Multi-line numbers ! will have '&' as the last nonblank character on all but the last ! line of the real part and the imaginary part. ! These numbers can then be read easily using FMREAD. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC int, log10, max, min, mod, real ! .. ! .. 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 :: kwrite ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz) ! .. ! .. Local Scalars .. INTEGER :: j, k, ksave, l, last, last1, last2, lb, nd, nexp ! .. ! .. External Subroutines .. EXTERNAL zmout ! .. ! .. 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), cmbufz(lmbufz) 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 COMMON /zmbuff/cmbufz ! .. ncall = ncall + 1 namest(ncall) = 'ZMWRIT' ksave = kflag nd = int(real(ndig)*log10(real(mbase))) + 1 IF (nd<2) nd = 2 nexp = int(2.0*log10(real(mxbase))) + 6 lb = 2*max(jform2+nexp,nd+nexp) + 3 lb = min(lb,lmbufz) CALL zmout(ma,cmbufz,lb,last1,last2) kflag = ksave last = last2 + 1 DO 10 j = 1, last2 IF (cmbufz(last-j)/=' ' .OR. j==last2) THEN l = last - j IF (mod(l,73)/=0) THEN WRITE (kwrite,90000) (cmbufz(k),k=1,l) ELSE WRITE (kwrite,90000) (cmbufz(k),k=1,l-73) WRITE (kwrite,90010) (cmbufz(k),k=l-72,l) END IF ncall = ncall - 1 RETURN END IF 10 CONTINUE ncall = ncall - 1 RETURN 90000 FORMAT (4X,73A1,' &') 90010 FORMAT (4X,73A1) END SUBROUTINE zmwrit SUBROUTINE zmz2m(zval,ma) ! MA = ZVAL ! ZVAL is complex and is converted to ZM form. IMPLICIT NONE ! .. Intrinsic Functions .. INTRINSIC aimag, dble ! .. ! .. 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 .. COMPLEX :: zval ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lunpkz) ! .. ! .. Local Scalars .. REAL (KIND(0.0D0)) :: dz ! .. ! .. External Subroutines .. EXTERNAL fmdp2m, zmntr, zmntrz ! .. ! .. Scalars in Common .. REAL (KIND(0.0D0)) :: dpmax REAL (KIND(0.0D0)) :: maxint, mbase, mexpov, mexpun, munkno, mxbase, mxexp, & mxexp2 REAL :: runkno, spmax INTEGER :: intmax, iunkno, jform1, jform2, kaccsw, kdebug, keswch, & kflag, krad, kround, ksub, kswide, kw, kwarn, lvltrc, ncall, ndg2mx, & ndig, ntrace CHARACTER (1) :: cmchar ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mwa(lmwa) CHARACTER (1) :: cmbuff(lmbuff) CHARACTER (6) :: namest(0:50) ! .. ! .. Common Blocks .. COMMON /fm/mwa, ncall, kaccsw, mxexp, mxexp2, mexpun, mexpov, munkno, & iunkno, runkno, mxbase, ndg2mx, spmax, dpmax, maxint, intmax, ksub COMMON /fmbuff/cmbuff, namest, cmchar COMMON /fmuser/mbase, ndig, jform1, jform2, krad, kw, ntrace, lvltrc, & kflag, kwarn, kround, kswide, keswch, kdebug ! .. ncall = ncall + 1 namest(ncall) = 'ZMZ2M ' IF (ntrace/=0) CALL zmntrz(2,zval,1) dz = dble(zval) CALL fmdp2m(dz,ma) dz = dble(aimag(zval)) CALL fmdp2m(dz,ma(kptimu)) IF (ntrace/=0) CALL zmntr(1,ma,ma,1) ncall = ncall - 1 RETURN END SUBROUTINE zmz2m ! Here are the routines which work with packed ZM numbers. All names ! are the same as unpacked versions with 'ZM' replaced by 'ZP'. ! To convert a program using the ZM package from unpacked calls to ! packed calls make these changes to the program: ! '(0:LUNPKZ)' to '(0:LUNPKZ)' in dimensions. ! 'CALL ZM' to 'CALL ZP' SUBROUTINE zpabs(ma,mbfm) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mbfm(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, zmabs, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mpa(0:lunpck), mpb(0:lunpck), mpc(0:lunpck), mx(0:lunpkz), & my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /fmpck/mpa, mpb, mpc COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmabs(mx,mpa) CALL fmpack(mpa,mbfm) RETURN END SUBROUTINE zpabs SUBROUTINE zpacos(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmacos, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmacos(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpacos SUBROUTINE zpadd(ma,mb,mc) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz), mc(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmadd, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmunpk(mb,my) CALL zmadd(mx,my,mx) CALL zmpack(mx,mc) RETURN END SUBROUTINE zpadd SUBROUTINE zpaddi(ma,integ) IMPLICIT NONE ! .. 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 :: integ ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmaddi, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmaddi(mx,integ) CALL zmpack(mx,ma) RETURN END SUBROUTINE zpaddi SUBROUTINE zparg(ma,mbfm) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mbfm(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, zmarg, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mpa(0:lunpck), mpb(0:lunpck), mpc(0:lunpck), mx(0:lunpkz), & my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /fmpck/mpa, mpb, mpc COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmarg(mx,mpa) CALL fmpack(mpa,mbfm) RETURN END SUBROUTINE zparg SUBROUTINE zpasin(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmasin, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmasin(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpasin SUBROUTINE zpatan(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmatan, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmatan(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpatan SUBROUTINE zpchsh(ma,mb,mc) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz), mc(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmchsh, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmchsh(mx,mx,my) CALL zmpack(mx,mb) CALL zmpack(my,mc) RETURN END SUBROUTINE zpchsh SUBROUTINE zpcmpx(mafm,mbfm,mc) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: mafm(0:lpack), mbfm(0:lpack), mc(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL fmunpk, zmcmpx, zmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mpa(0:lunpck), mpb(0:lunpck), mpc(0:lunpck), mx(0:lunpkz), & my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /fmpck/mpa, mpb, mpc COMMON /zmpck/mx, my ! .. CALL fmunpk(mafm,mpa) CALL fmunpk(mbfm,mpb) CALL zmcmpx(mpa,mpb,mx) CALL zmpack(mx,mc) RETURN END SUBROUTINE zpcmpx SUBROUTINE zpconj(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmconj, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmconj(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpconj SUBROUTINE zpcos(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmcos, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmcos(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpcos SUBROUTINE zpcosh(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmcosh, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmcosh(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpcosh SUBROUTINE zpcssn(ma,mb,mc) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz), mc(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmcssn, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmcssn(mx,mx,my) CALL zmpack(mx,mb) CALL zmpack(my,mc) RETURN END SUBROUTINE zpcssn SUBROUTINE zpdiv(ma,mb,mc) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz), mc(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmdiv, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmunpk(mb,my) CALL zmdiv(mx,my,mx) CALL zmpack(mx,mc) RETURN END SUBROUTINE zpdiv SUBROUTINE zpdivi(ma,integ,mb) IMPLICIT NONE ! .. 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 :: integ ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmdivi, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmdivi(mx,integ,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpdivi SUBROUTINE zpeq(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL fpeq ! .. CALL fpeq(ma,mb) CALL fpeq(ma(kptimp),mb(kptimp)) RETURN END SUBROUTINE zpeq SUBROUTINE zpequ(ma,mb,nda,ndb) IMPLICIT NONE ! .. 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 :: nda, ndb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL fpequ ! .. CALL fpequ(ma,mb,nda,ndb) CALL fpequ(ma(kptimp),mb(kptimp),nda,ndb) RETURN END SUBROUTINE zpequ SUBROUTINE zpexp(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmexp, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmexp(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpexp SUBROUTINE zpform(form1,form2,ma,string) IMPLICIT NONE ! .. 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 .. CHARACTER (*) :: form1, form2, string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmform, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmform(form1,form2,mx,string) RETURN END SUBROUTINE zpform SUBROUTINE zpfprt(form1,form2,ma) IMPLICIT NONE ! .. 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 .. CHARACTER (*) :: form1, form2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmfprt, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmfprt(form1,form2,mx) RETURN END SUBROUTINE zpfprt SUBROUTINE zp2i2m(integ1,integ2,ma) IMPLICIT NONE ! .. 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 :: integ1, integ2 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zm2i2m, zmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zm2i2m(integ1,integ2,mx) CALL zmpack(mx,ma) RETURN END SUBROUTINE zp2i2m SUBROUTINE zpi2m(integ,ma) IMPLICIT NONE ! .. 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 :: integ ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmi2m, zmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmi2m(integ,mx) CALL zmpack(mx,ma) RETURN END SUBROUTINE zpi2m SUBROUTINE zpimag(ma,mbfm) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mbfm(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, zmimag, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mpa(0:lunpck), mpb(0:lunpck), mpc(0:lunpck), mx(0:lunpkz), & my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /fmpck/mpa, mpb, mpc COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmimag(mx,mpa) CALL fmpack(mpa,mbfm) RETURN END SUBROUTINE zpimag SUBROUTINE zpint(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmint, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmint(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpint SUBROUTINE zpinp(line,ma,la,lb) IMPLICIT NONE ! .. 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 :: la, lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz) CHARACTER (1) :: line(lb) ! .. ! .. External Subroutines .. EXTERNAL zminp, zmpack ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zminp(line,mx,la,lb) CALL zmpack(mx,ma) RETURN END SUBROUTINE zpinp SUBROUTINE zpipwr(ma,integ,mb) IMPLICIT NONE ! .. 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 :: integ ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmipwr, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmipwr(mx,integ,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpipwr SUBROUTINE zplg10(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmlg10, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmlg10(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zplg10 SUBROUTINE zpln(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmln, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmln(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpln SUBROUTINE zpm2i(ma,integ) IMPLICIT NONE ! .. 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 :: integ ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmm2i, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmm2i(mx,integ) RETURN END SUBROUTINE zpm2i SUBROUTINE zpm2z(ma,zval) IMPLICIT NONE ! .. 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 .. COMPLEX :: zval ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmm2z, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmm2z(mx,zval) RETURN END SUBROUTINE zpm2z SUBROUTINE zpmpy(ma,mb,mc) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz), mc(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmmpy, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmunpk(mb,my) CALL zmmpy(mx,my,mx) CALL zmpack(mx,mc) RETURN END SUBROUTINE zpmpy SUBROUTINE zpmpyi(ma,integ,mb) IMPLICIT NONE ! .. 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 :: integ ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmmpyi, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmmpyi(mx,integ,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpmpyi SUBROUTINE zpnint(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmnint, zmpack, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmnint(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpnint SUBROUTINE zpout(ma,line,lb,last1,last2) IMPLICIT NONE ! .. 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 :: last1, last2, lb ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz) CHARACTER (1) :: line(lb) ! .. ! .. External Subroutines .. EXTERNAL zmout, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmout(mx,line,lb,last1,last2) RETURN END SUBROUTINE zpout SUBROUTINE zpprnt(ma) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmprnt, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmprnt(mx) RETURN END SUBROUTINE zpprnt SUBROUTINE zppwr(ma,mb,mc) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz), mc(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmpack, zmpwr, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmunpk(mb,my) CALL zmpwr(mx,my,mx) CALL zmpack(mx,mc) RETURN END SUBROUTINE zppwr SUBROUTINE zpread(kread,ma) IMPLICIT NONE ! .. 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 :: kread ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmpack, zmread ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmread(kread,mx) CALL zmpack(mx,ma) RETURN END SUBROUTINE zpread SUBROUTINE zpreal(ma,mbfm) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mbfm(0:lpack) ! .. ! .. External Subroutines .. EXTERNAL fmpack, zmreal, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mpa(0:lunpck), mpb(0:lunpck), mpc(0:lunpck), mx(0:lunpkz), & my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /fmpck/mpa, mpb, mpc COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmreal(mx,mpa) CALL fmpack(mpa,mbfm) RETURN END SUBROUTINE zpreal SUBROUTINE zprpwr(ma,ival,jval,mb) IMPLICIT NONE ! .. 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 :: ival, jval ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmpack, zmrpwr, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmrpwr(mx,ival,jval,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zprpwr SUBROUTINE zpset(nprec) ! .. Scalar Arguments .. INTEGER :: nprec ! .. ! .. External Subroutines .. EXTERNAL zmset ! .. CALL zmset(nprec) RETURN END SUBROUTINE zpset SUBROUTINE zpsin(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmpack, zmsin, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmsin(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpsin SUBROUTINE zpsinh(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmpack, zmsinh, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmsinh(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpsinh SUBROUTINE zpsqr(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmpack, zmsqr, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmsqr(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpsqr SUBROUTINE zpsqrt(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmpack, zmsqrt, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmsqrt(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zpsqrt SUBROUTINE zpst2m(string,ma) IMPLICIT NONE ! .. 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 .. CHARACTER (*) :: string ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmpack, zmst2m ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmst2m(string,mx) CALL zmpack(mx,ma) RETURN END SUBROUTINE zpst2m SUBROUTINE zpsub(ma,mb,mc) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz), mc(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmpack, zmsub, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmunpk(mb,my) CALL zmsub(mx,my,mx) CALL zmpack(mx,mc) RETURN END SUBROUTINE zpsub SUBROUTINE zptan(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmpack, zmtan, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmtan(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zptan SUBROUTINE zptanh(ma,mb) IMPLICIT NONE ! .. 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 ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz), mb(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmpack, zmtanh, zmunpk ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmtanh(mx,mx) CALL zmpack(mx,mb) RETURN END SUBROUTINE zptanh SUBROUTINE zpwrit(kwrite,ma) IMPLICIT NONE ! .. 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 :: kwrite ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmunpk, zmwrit ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmunpk(ma,mx) CALL zmwrit(kwrite,mx) RETURN END SUBROUTINE zpwrit SUBROUTINE zpz2m(zval,ma) IMPLICIT NONE ! .. 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 .. COMPLEX :: zval ! .. ! .. Array Arguments .. REAL (KIND(0.0D0)) :: ma(0:lpackz) ! .. ! .. External Subroutines .. EXTERNAL zmpack, zmz2m ! .. ! .. Arrays in Common .. REAL (KIND(0.0D0)) :: mx(0:lunpkz), my(0:lunpkz) ! .. ! .. Common Blocks .. COMMON /zmpck/mx, my ! .. CALL zmz2m(zval,mx) CALL zmpack(mx,ma) RETURN ! End of the ZM package. END SUBROUTINE zpz2m SHAR_EOF fi # end of overwriting check cd .. cd .. cd .. # End of shell archive exit 0