C C ZM 1.1 David M. Smith 5-19-97 C C C The ZM routines perform complex floating-point multiple-precision C arithmetic. C C These routines use the FMLIB package (version 1.1) for real C floating-point multiple-precision arithmetic. C FMLIB 1.0 is Algorithm 693, ACM Transactions on Mathematical C Software, Vol. 17, No. 2, June 1991, pages 273-283. C C This package and FMLIB 1.1 use double precision arithmetic and arrays C internally. This is usually faster at higher precision, and on many C machines it is also faster at lower precision. Both packages are C written so that the arithmetic used can easily be changed from double C precision to integer, or another available arithmetic type. See the C EFFICIENCY discussion in FMLIB 1.1 for details. C C C C 1. INITIALIZING THE PACKAGE C C Before calling any routine in the package, several variables in the C common blocks /FMUSER/, /FM/, /FMSAVE/, /FMBUFF/, and /ZMUSER/ must C be initialized. These common blocks contain information that is C saved between calls, so they should be declared in the main program. C C Subroutine ZMSET initializes these variables to default values and C defines all machine-dependent values in the package. After calling C ZMSET once at the start of a program, the user may sometimes want to C reset some of the variables in common blocks /FMUSER/ or /ZMUSER/. C C C 2. REPRESENTATION OF ZM NUMBERS C C The format for complex FM numbers (called ZM numbers below) is very C similar to that for real FM numbers in FMLIB. Each ZM array holds C two FM numbers to represent the real and imaginary parts of a complex C number. Each ZM array is twice as long as a corresponding FM array, C with the imaginary part starting at the midpoint of the array. As C with FM, there are packed and unpacked formats for the numbers. C C C 3. INPUT/OUTPUT ROUTINES C C All versions of the input routines perform free-format conversion C from characters to ZM numbers. C C a. Conversion to or from a character array C C ZMINP converts from a character*1 array to an ZM number. C C ZMOUT converts an ZM number to base 10 and formats it for output C as an array of type character*1. The output is left C justified in the array, and the format is defined by C variables in common, so that a separate format definition C does not have to be provided for each output call. C C For the output format of ZM numbers, JFORM1 and JFORM2 determine C the format for the individual parts of a complex number as C described in the FMLIB documentation. C C JFORMZ (in /ZMUSER/) determines the combined output format of the C real and imaginary parts. C C JFORMZ = 1 normal setting : 1.23 - 4.56 i C = 2 use capital I : 1.23 - 4.56 I C = 3 parenthesis format ( 1.23 , -4.56 ) C C JPRNTZ (in /ZMUSER/) controls whether to print real C and imaginary parts on one line whenever possible. C C JPRNTZ = 1 print both parts as a single string : C 1.23456789M+321 - 9.87654321M-123 i C = 2 print on separate lines without the 'i' : C 1.23456789M+321 C -9.87654321M-123 C C b. Conversion to or from a character string C C ZMST2M converts from a character string to an ZM number. C C ZMFORM converts an ZM number to a character string according to C a format provided in each call. The format descriptions C are more like that of a Fortran FORMAT statement, and C integer or fixed-point output is right justified. C C c. Direct read or write C C ZMPRNT uses ZMOUT to print one ZM number. C C ZMFPRT uses ZMFORM to print one ZM number. C C ZMWRIT writes ZM numbers for later input using ZMREAD. C C ZMREAD reads ZM numbers written by ZMWRIT. C C For further description of these routines, see section 5 below. C C C 4. ARRAY DIMENSIONS C C The parameters LPACKZ and LUNPKZ define the size of the packed and C unpacked ZM arrays. The real part starts at the beginning of the C array, and the imaginary part starts at word KPTIMP for packed format C or at word KPTIMU for unpacked format. C C C 5. LIST OF ROUTINES C C These are the routines in ZMLIB that are designed to be called by C the user. All are subroutines, and in each case the version of the C routine to handle packed ZM numbers has the same name, with 'ZM' C replaced by 'ZP'. C C MA, MB, MC refer to ZM format complex numbers. C MAFM, MBFM, MCFM refer to FM format real numbers. C INTEG is a Fortran INTEGER variable. C ZVAL is a Fortran COMPLEX variable. C C In each case it is permissible to use the same array more than C once in the calling sequence. The statement C MA = MA*MA may be written CALL ZMMPY(MA,MA,MA). C C ZMABS(MA,MBFM) MBFM = ABS(MA) Result is real. C C ZMACOS(MA,MB) MB = ACOS(MA) C C ZMADD(MA,MB,MC) MC = MA + MB C C ZMADDI(MA,INTEG) MA = MA + INTEG Increment an ZM number by a one C word integer. Note this call C does not have an "MB" result C like ZMDIVI and ZMMPYI. C C ZMARG(MA,MBFM) MBFM = Argument(MA) Result is real. C C ZMASIN(MA,MB) MB = ASIN(MA) C C ZMATAN(MA,MB) MB = ATAN(MA) C C ZMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA). C Faster than 2 calls. C C ZMCMPX(MAFM,MBFM,MC) MC = CMPLX(MAFM,MBFM) C C ZMCONJ(MA,MB) MB = CONJG(MA) C C ZMCOS(MA,MB) MB = COS(MA) C C ZMCOSH(MA,MB) MB = COSH(MA) C C ZMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA). C Faster than 2 calls. C C ZMDIV(MA,MB,MC) MC = MA / MB C C ZMDIVI(MA,INTEG,MB) MB = MA / INTEG C C ZMEQ(MA,MB) MB = MA C C ZMEQU(MA,MB,NDA,NDB) MB = MA Version for changing precision. C (NDA and NDB are as in FMEQU) C C ZMEXP(MA,MB) MB = EXP(MA) C C ZMFORM(FORM1,FORM2,MA,STRING) STRING = MA C MA is converted to a character string using C format FORM1 for the real part and FORM2 for C the imaginary part. The result is returned C in STRING. FORM1 and FORM2 can represent I, C F, E, or 1PE formats. Example: C CALL ZMFORM('F20.10','F15.10',MA,STRING) C C ZMFPRT(FORM1,FORM2,MA) Print MA on unit KW using C formats FORM1 and FORM2. C C ZMI2M(INTEG,MA) MA = CMPLX(INTEG,0) C C ZM2I2M(INTEG1,INTEG2,MA) MA = CMPLX(INTEG1,INTEG2) C C ZMIMAG(MA,MBFM) MBFM = IMAG(MA) Imaginary part. C C ZMINP(LINE,MA,LA,LB) MA = LINE Input conversion. C Convert LINE(LA) through LINE(LB) C from characters to ZM. LINE is a C character array of length at least LB. C C ZMINT(MA,MB) MB = INT(MA) Integer part of both Real C and Imaginary parts of MA. C C ZMIPWR(MA,INTEG,MB) MB = MA ** INTEG Integer power function. C C ZMLG10(MA,MB) MB = LOG10(MA) C C ZMLN(MA,MB) MB = LOG(MA) C C ZMM2I(MA,INTEG) INTEG = INT(REAL(MA)) C C ZMM2Z(MA,ZVAL) ZVAL = MA C C ZMMPY(MA,MB,MC) MC = MA * MB C C ZMMPYI(MA,INTEG,MB) MB = MA * INTEG C C ZMNINT(MA,MB) MB = NINT(MA) Nearest integer of both Real C and Imaginary. C C ZMOUT(MA,LINE,LB,LAST1,LAST2) LINE = MA C Convert from FM to character. C LINE is the returned character array. C LB is the dimensioned size of LINE. C LAST1 is returned as the position in LINE of C the last character of REAL(MA). C LAST2 is returned as the position in LINE C of the last character of AIMAG(MA). C C ZMPRNT(MA) Print MA on unit KW using current format. C C ZMPWR(MA,MB,MC) MC = MA ** MB C C ZMREAD(KREAD,MA) MA is returned after reading one (possibly C multi-line) ZM number on unit KREAD. This C routine reads numbers written by ZMWRIT. C C ZMREAL(MA,MBFM) MBFM = REAL(MA) Real part. C C ZMRPWR(MA,IVAL,JVAL,MB) MB = MA ** (IVAL/JVAL) C C ZMSET(NPREC) Initialize ZM package. Set precision to the C equivalent of at least NPREC base 10 digits. C C ZMSIN(MA,MB) MB = SIN(MA) C C ZMSINH(MA,MB) MB = SINH(MA) C C ZMSQR(MA,MB) MB = MA*MA Faster than ZMMPY. C C ZMSQRT(MA,MB) MB = SQRT(MA) C C ZMST2M(STRING,MA) MA = STRING C Convert from character string to ZM. C Often more convenient than ZMINP, which C converts an array of CHARACTER*1 values. C Example: CALL ZMST2M('123.4+5.67i',MA). C C ZMSUB(MA,MB,MC) MC = MA - MB C C ZMTAN(MA,MB) MB = TAN(MA) C C ZMTANH(MA,MB) MB = TANH(MA) C C ZMWRIT(KWRITE,MA) Write MA on unit KWRITE. Multi-line numbers C are formatted for automatic reading with ZMREAD. C C ZMZ2M(ZVAL,MA) MA = ZVAL C C C SUBROUTINE ZMSET(NPREC) C C Initialize common and set precision to at least NPREC significant C digits before using ZM arithmetic. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER NPREC C C Here are the common blocks used for complex arithmetic. C C /FMUSER/, /FM/, /FMBUFF/, /FMSAVE/, and /ZMUSER/ should also be C declared in the main program. C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER JFORMZ,JPRNTZ C COMMON /ZMUSER/ JFORMZ,JPRNTZ C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION MX,MY C COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) C CHARACTER CMBUFZ COMMON /ZMBUFF/ CMBUFZ(LMBUFZ) C C Set JFORMZ to ' 1.23 + 4.56 i ' format. C JFORMZ = 1 C C Set JPRNTZ to print real and imaginary parts on one C line whenever possible. C JPRNTZ = 1 C C Use FMSET to initialize the other common blocks. C CALL FMSET(NPREC) C RETURN END SUBROUTINE ZMABS(MA,MBFM) C C MBFM = ABS(MA) C C Complex absolute value. The result is a real FM number. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MBFM(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during ZMABS: M01 - M02, MZ01 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXEXP1,MXSAVE INTEGER KASAVE,KOVUN,KRESLT,NDSAVE C CALL ZMENTR('ZMABS ',MA,MA,1,MZ01,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) THEN CALL FMEQ(MZ01,MBFM) RETURN ENDIF MARZ = MA(0) MAIZ = MA(KPTIMU) KACCSW = 0 CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C C Check for special cases. C MXEXP1 = INT(MXEXP2/2.01D0) IF (MA(2).EQ.0) THEN CALL FMABS(MA(KPTIMU),MBFM) GO TO 110 ELSE IF (MA(KPTIMU+2).EQ.0) THEN CALL FMABS(MA,MBFM) GO TO 110 ELSE IF (MA(1).EQ.MEXPOV .OR. MA(KPTIMU+1).EQ.MEXPOV) THEN CALL FMI2M(1,MBFM) MBFM(1) = MAX(MA(1),MA(KPTIMU+1)) GO TO 110 ELSE IF (MA(1).EQ.MEXPUN) THEN IF (MA(KPTIMU+1).GT.-MXEXP1+NDIG+1) THEN CALL FMABS(MA(KPTIMU),MBFM) GO TO 110 ENDIF ELSE IF (MA(KPTIMU+1).EQ.MEXPUN) THEN IF (MA(1).GT.-MXEXP1+NDIG+1) THEN CALL FMABS(MA,MBFM) GO TO 110 ENDIF ELSE IF (MA(1).NE.MUNKNO .AND. MA(KPTIMU+1).NE.MUNKNO) THEN IF (MA(1).GT.MA(KPTIMU+1)+NDIG+1) THEN CALL FMABS(MA,MBFM) GO TO 110 ELSE IF (MA(KPTIMU+1).GT.MA(1)+NDIG+1) THEN CALL FMABS(MA(KPTIMU),MBFM) GO TO 110 ENDIF ENDIF C CALL FMSQR(MA,M01) CALL FMSQR(MA(KPTIMU),M02) CALL FMADD(M01,M02,MBFM) CALL FMSQRT(MBFM,MBFM) C 110 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 ZMACOS(MA,MB) C C MB = ACOS(MA). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMACOS: M01 - M06, MZ01 - MZ03 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE INTEGER J,KASAVE,KOVUN,KRESLT,NDSAVE C CALL ZMENTR('ZMACOS',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN MARZ = MA(0) MAIZ = MA(KPTIMU) KACCSW = 0 C CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C C Check for special cases. C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN CALL FMPI(MZ01) CALL FMDIVI(MZ01,2,MZ01) CALL FMI2M(0,MZ01(KPTIMU)) GO TO 160 ELSE IF (MA(KPTIMU+2).EQ.0) THEN CALL FMACOS(MA,MZ01) IF (KFLAG.EQ.0) THEN CALL FMI2M(0,MZ01(KPTIMU)) GO TO 160 ENDIF ENDIF IF ((MA(2).EQ.0 .OR. MA(1)*2.LE.-NDIG) .AND. * (MA(KPTIMU+2).EQ.0 .OR. MA(KPTIMU+1)*2.LE.-NDIG)) THEN CALL FMPI(MZ01) CALL FMDIVI(MZ01,2,MZ01) CALL FMI2M(0,MZ01(KPTIMU)) CALL ZMSUB(MZ01,MA,MZ01) GO TO 160 ENDIF C CALL ZMI2M(1,MZ03) CALL ZMSUB(MZ03,MA,MZ02) CALL ZMADD(MZ03,MA,MZ03) CALL ZMMPY(MZ02,MZ03,MZ02) CALL ZMSQRT(MZ02,MZ02) DO 110 J = 0, NDIG+1 MZ03(J) = MZ02(KPTIMU+J) MZ03(KPTIMU+J) = MZ02(J) 110 CONTINUE IF (MZ03(1).NE.MUNKNO) MZ03(2) = -MZ03(2) C IF ((MA(2).NE.0 .AND. MZ03(1).EQ.MA(1) .AND. * MZ03(2).EQ.MA(2)) .OR. * (MA(KPTIMU+2).NE.0 .AND. MZ03(KPTIMU+1).EQ.MA(KPTIMU+1) * .AND. MZ03(KPTIMU+2).EQ.MA(KPTIMU+2)) ) THEN CALL ZMADD(MA,MZ03,MZ03) C 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).LT.0) THEN NDIG = NDIG - INT(M03(1)) IF (NDIG.GT.NDG2MX) THEN NAMEST(NCALL) = 'ZMACOS' KFLAG = -9 CALL ZMWARN KRESLT = 12 NDIG = NDSAVE CALL ZMRSLT(MB,KRESLT) IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 MXEXP = MXSAVE KACCSW = KASAVE RETURN ENDIF 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 120 J = 0, NDIG+1 MZ03(J) = MZ02(KPTIMU+J) MZ03(KPTIMU+J) = MZ02(J) 120 CONTINUE IF (MZ03(1).NE.MUNKNO) MZ03(2) = -MZ03(2) CALL ZMADD(MA,MZ03,MZ03) ENDIF C CALL ZMLN(MZ03,MZ03) DO 130 J = 0, NDIG+1 MZ01(J) = MZ03(KPTIMU+J) MZ01(KPTIMU+J) = MZ03(J) 130 CONTINUE IF (MZ01(KPTIMU+1).NE.MUNKNO) MZ01(KPTIMU+2) = -MZ01(KPTIMU+2) ELSE CALL ZMSUB(MA,MZ03,MZ03) C 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).LT.0) THEN NDIG = NDIG - INT(M03(1)) IF (NDIG.GT.NDG2MX) THEN NAMEST(NCALL) = 'ZMACOS' KFLAG = -9 CALL ZMWARN KRESLT = 12 NDIG = NDSAVE CALL ZMRSLT(MB,KRESLT) IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 MXEXP = MXSAVE KACCSW = KASAVE RETURN ENDIF 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 140 J = 0, NDIG+1 MZ03(J) = MZ02(KPTIMU+J) MZ03(KPTIMU+J) = MZ02(J) 140 CONTINUE IF (MZ03(1).NE.MUNKNO) MZ03(2) = -MZ03(2) CALL ZMSUB(MA,MZ03,MZ03) ENDIF C CALL ZMLN(MZ03,MZ03) DO 150 J = 0, NDIG+1 MZ01(J) = MZ03(KPTIMU+J) MZ01(KPTIMU+J) = MZ03(J) 150 CONTINUE IF (MZ01(1).NE.MUNKNO) MZ01(2) = -MZ01(2) ENDIF C 160 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 ZMADD(MA,MB,MC) C C MC = MA + MB C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER KASAVE,KF1,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV DOUBLE PRECISION MAR,MAI,MBR,MBI,MXSAVE C IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MA(KPTIMU+1)).GT.MEXPAB .OR. * ABS(MB(1)).GT.MEXPAB .OR. ABS(MB(KPTIMU+1)).GT.MEXPAB .OR. * KDEBUG.GE.1) THEN CALL ZMENTR('ZMADD ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN NDIG = NDSAVE MXEXP = MXSAVE KACCSW = KASAVE NTRSAV = NTRACE ELSE NCALL = NCALL + 1 NTRSAV = NTRACE IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'ZMADD ' CALL ZMNTR(2,MA,MB,2) NTRACE = 0 ENDIF KOVUN = 0 ENDIF C C Force FMADD to use more guard digits for user calls. C NCALL = NCALL - 1 C KWRNSV = KWARN KWARN = 0 MAR = MA(1) IF (MA(2).EQ.0) MAR = MEXPUN - 1 MAI = MA(KPTIMU+1) IF (MA(KPTIMU+2).EQ.0) MAI = MEXPUN - 1 MBR = MB(1) IF (MB(2).EQ.0) MBR = MEXPUN - 1 MBI = MB(KPTIMU+1) IF (MB(KPTIMU+2).EQ.0) MBI = MEXPUN - 1 C CALL FMADD(MA,MB,MC) KF1 = KFLAG CALL FMADD(MA(KPTIMU),MB(KPTIMU),MC(KPTIMU)) C NCALL = NCALL + 1 IF (NTRSAV.NE.0) THEN NTRACE = NTRSAV NAMEST(NCALL) = 'ZMADD ' ENDIF KWARN = KWRNSV IF (KFLAG.EQ.1) KFLAG = KF1 IF (KFLAG.EQ.1) THEN KFLAG = 0 IF (MAR.LE.MBR .AND. MAI.LE.MBI) KFLAG = 1 IF (MAR.GE.MBR .AND. MAI.GE.MBI) KFLAG = 1 ENDIF C IF (MC(1).EQ.MUNKNO .OR. MC(KPTIMU+1).EQ.MUNKNO) THEN KFLAG = -4 ELSE IF (MC(1).EQ.MEXPOV .OR. MC(KPTIMU+1).EQ.MEXPOV) THEN KFLAG = -5 ELSE IF (MC(1).EQ.MEXPUN .OR. MC(KPTIMU+1).EQ.MEXPUN) THEN KFLAG = -6 ENDIF IF ((MC(1).EQ.MUNKNO) * .OR. (MC(KPTIMU+1).EQ.MUNKNO) * .OR. (MC(1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MC(KPTIMU+1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MC(1).EQ.MEXPOV .AND. KOVUN.EQ.0) * .OR. (MC(KPTIMU+1).EQ.MEXPOV .AND. KOVUN.EQ.0)) THEN NAMEST(NCALL) = 'ZMADD ' CALL ZMWARN ENDIF IF (NTRACE.NE.0) THEN CALL ZMNTR(1,MC,MC,1) ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE ZMADDI(MA,INTEG) C C MA = MA + INTEG Increment by one-word (real) integer. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ) INTEGER INTEG C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV DOUBLE PRECISION MXSAVE C IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MA(KPTIMU+1)).GT.MEXPAB .OR. * KDEBUG.GE.1) THEN CALL ZMENTR('ZMADDI',MA,MA,1,MA,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN NDIG = NDSAVE MXEXP = MXSAVE KACCSW = KASAVE NTRSAV = NTRACE ELSE NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'ZMADDI' CALL ZMNTR(2,MA,MA,1) CALL FMNTRI(2,INTEG,0) ENDIF KOVUN = 0 ENDIF C C Force FMADDI to use more guard digits for user calls. C NCALL = NCALL - 1 NTRSAV = NTRACE NTRACE = 0 KWRNSV = KWARN KWARN = 0 C CALL FMADDI(MA,INTEG) C NTRACE = NTRSAV KWARN = KWRNSV NCALL = NCALL + 1 IF (NTRACE.NE.0) NAMEST(NCALL) = 'ZMADDI' IF (MA(1).EQ.MUNKNO .OR. MA(KPTIMU+1).EQ.MUNKNO) THEN KFLAG = -4 ELSE IF (MA(1).EQ.MEXPOV .OR. MA(KPTIMU+1).EQ.MEXPOV) THEN KFLAG = -5 ELSE IF (MA(1).EQ.MEXPUN .OR. MA(KPTIMU+1).EQ.MEXPUN) THEN KFLAG = -6 ENDIF IF ((MA(1).EQ.MUNKNO) * .OR. (MA(KPTIMU+1).EQ.MUNKNO) * .OR. (MA(1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MA(KPTIMU+1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MA(1).EQ.MEXPOV .AND. KOVUN.EQ.0) * .OR. (MA(KPTIMU+1).EQ.MEXPOV .AND. KOVUN.EQ.0)) THEN NAMEST(NCALL) = 'ZMADDI' CALL ZMWARN ENDIF IF (NTRACE.NE.0) CALL ZMNTR(1,MA,MA,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMARG(MA,MBFM) C C MBFM = ARG(MA) C C Complex argument. The result is a real FM number. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MBFM(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during ZMARG: M01 - M06, MZ01 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MXSAVE INTEGER KASAVE,KOVUN,KRESLT,NDSAVE C CALL ZMENTR('ZMARG ',MA,MA,1,MZ01,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) THEN CALL FMEQ(MZ01,MBFM) RETURN ENDIF KACCSW = 0 CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C CALL FMATN2(MA(KPTIMU),MA,MBFM) C CALL ZMEXI2(MBFM,MBFM,NDSAVE,MXSAVE,KASAVE,KOVUN,1) RETURN END SUBROUTINE ZMASIN(MA,MB) C C MB = ASIN(MA). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMASIN: M01 - M06, MZ01 - MZ03 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE INTEGER J,KASAVE,KOVUN,KRESLT,NDSAVE C CALL ZMENTR('ZMASIN',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN MARZ = MA(0) MAIZ = MA(KPTIMU) KACCSW = 0 C CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C C Check for special cases. C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN CALL ZMI2M(0,MZ01) GO TO 160 ELSE IF ((MA(2).EQ.0 .OR. MA(1)*2.LE.-NDIG) .AND. * (MA(KPTIMU+2).EQ.0 .OR. MA(KPTIMU+1)*2.LE.-NDIG)) THEN CALL ZMEQ(MA,MZ01) GO TO 160 ELSE IF (MA(KPTIMU+2).EQ.0) THEN CALL FMASIN(MA,MZ01) IF (KFLAG.EQ.0) THEN CALL FMI2M(0,MZ01(KPTIMU)) GO TO 160 ENDIF ENDIF C CALL ZMI2M(1,MZ03) CALL ZMSUB(MZ03,MA,MZ02) CALL ZMADD(MZ03,MA,MZ03) CALL ZMMPY(MZ02,MZ03,MZ02) CALL ZMSQRT(MZ02,MZ02) DO 110 J = 0, NDIG+1 MZ03(J) = MA(KPTIMU+J) MZ03(KPTIMU+J) = MA(J) 110 CONTINUE IF (MZ03(1).NE.MUNKNO) MZ03(2) = -MZ03(2) C IF ((MZ02(2).NE.0 .AND. MZ03(1).EQ.MZ02(1) .AND. * MZ03(2).EQ.MZ02(2)) .OR. * (MZ02(KPTIMU+2).NE.0 .AND. MZ03(KPTIMU+1).EQ.MZ02(KPTIMU+1) * .AND. MZ03(KPTIMU+2).EQ.MZ02(KPTIMU+2)) ) THEN CALL ZMADD(MZ02,MZ03,MZ03) C 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).LT.0) THEN NDIG = NDIG - INT(M03(1)) IF (NDIG.GT.NDG2MX) THEN NAMEST(NCALL) = 'ZMASIN' KFLAG = -9 CALL ZMWARN KRESLT = 12 NDIG = NDSAVE CALL ZMRSLT(MB,KRESLT) IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 MXEXP = MXSAVE KACCSW = KASAVE RETURN ENDIF 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 120 J = 0, NDIG+1 MZ03(J) = MA(KPTIMU+J) MZ03(KPTIMU+J) = MA(J) 120 CONTINUE IF (MZ03(1).NE.MUNKNO) MZ03(2) = -MZ03(2) CALL ZMADD(MZ02,MZ03,MZ03) ENDIF C CALL ZMLN(MZ03,MZ03) DO 130 J = 0, NDIG+1 MZ01(J) = MZ03(KPTIMU+J) MZ01(KPTIMU+J) = MZ03(J) 130 CONTINUE IF (MZ01(KPTIMU+1).NE.MUNKNO) MZ01(KPTIMU+2) = -MZ01(KPTIMU+2) ELSE CALL ZMSUB(MZ02,MZ03,MZ03) C 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).LT.0) THEN NDIG = NDIG - INT(M03(1)) IF (NDIG.GT.NDG2MX) THEN NAMEST(NCALL) = 'ZMASIN' KFLAG = -9 CALL ZMWARN KRESLT = 12 NDIG = NDSAVE CALL ZMRSLT(MB,KRESLT) IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 MXEXP = MXSAVE KACCSW = KASAVE RETURN ENDIF 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 140 J = 0, NDIG+1 MZ03(J) = MA(KPTIMU+J) MZ03(KPTIMU+J) = MA(J) 140 CONTINUE IF (MZ03(1).NE.MUNKNO) MZ03(2) = -MZ03(2) CALL ZMSUB(MZ02,MZ03,MZ03) ENDIF CALL ZMLN(MZ03,MZ03) DO 150 J = 0, NDIG+1 MZ01(J) = MZ03(KPTIMU+J) MZ01(KPTIMU+J) = MZ03(J) 150 CONTINUE IF (MZ01(1).NE.MUNKNO) MZ01(2) = -MZ01(2) ENDIF C 160 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 ZMATAN(MA,MB) C C MB = ATAN(MA). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMATAN: M01 - M06, MZ01 - MZ04 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE INTEGER J,JTERM,KASAVE,KOVUN,KRESLT,NDSAVE LOGICAL FMCOMP REAL X C CALL ZMENTR('ZMATAN',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN MARZ = MA(0) MAIZ = MA(KPTIMU) KACCSW = 0 C CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C C Check for special cases. C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN CALL ZMI2M(0,MZ04) GO TO 130 ELSE IF ((MA(2).EQ.0 .OR. MA(1)*2.LE.-NDIG) .AND. * (MA(KPTIMU+2).EQ.0 .OR. MA(KPTIMU+1)*2.LE.-NDIG)) THEN CALL ZMEQ(MA,MZ04) GO TO 130 ELSE IF (MA(KPTIMU+2).EQ.0) THEN CALL FMATAN(MA,MZ04) IF (KFLAG.EQ.0) THEN CALL FMI2M(0,MZ04(KPTIMU)) GO TO 130 ENDIF ENDIF C X = 1.0E+5 CALL FMSP2M(X,M02) CALL FMABS(MA,M03) CALL FMABS(MA(KPTIMU),M04) CALL FMADD(M03,M04,M04) C IF (FMCOMP(M04,'GE',M02)) THEN CALL ZMI2M(0,MZ04) CALL FMPI(MZ04) CALL FMDIVI(MZ04,2,MZ04) IF (MA(2).LT.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).GT.NDIG .OR. MA(KPTIMU+1).GT.NDIG) GO TO 130 CALL ZMSQR(MZ02,MZ02) JTERM = 1 110 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.NE.0) GO TO 130 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.NE.0) GO TO 130 CALL FMEQ(M05,MZ03) CALL FMEQ(M06,MZ03(KPTIMU)) GO TO 110 ELSE CALL ZM2I2M(0,1,MZ02) CALL ZMSUB(MZ02,MA,MZ03) CALL ZMADD(MZ02,MA,MZ02) CALL ZMDIV(MZ02,MZ03,MZ03) C 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).LT.0) THEN NDIG = NDIG - INT(M03(1)) IF (NDIG.GT.NDG2MX) THEN NAMEST(NCALL) = 'ZMATAN' KFLAG = -9 CALL ZMWARN KRESLT = 12 NDIG = NDSAVE CALL ZMRSLT(MB,KRESLT) IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 MXEXP = MXSAVE KACCSW = KASAVE RETURN ENDIF 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) ENDIF C CALL ZMLN(MZ03,MZ03) CALL ZMDIVI(MZ03,2,MZ03) DO 120 J = 0, NDIG+1 MZ04(J) = MZ03(KPTIMU+J) MZ04(KPTIMU+J) = MZ03(J) 120 CONTINUE IF (MZ04(1).NE.MUNKNO) MZ04(2) = -MZ04(2) ENDIF C 130 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 ZMCHSH(MA,MB,MC) C C MB = COSH(MA), MC = SINH(MA). C C If both the hyperbolic sine and cosine are needed, this routine C is faster than calling both ZMCOS and ZMSIN. C C MB and MC must be distinct arrays. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMCHSH: M01 - M06, MZ01 - MZ04 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NCSAVE,NDSAVE C NCSAVE = NCALL CALL ZMENTR('ZMCHSH',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) NCALL = NCSAVE + 1 IF (KRESLT.NE.0) THEN CALL ZMEQ(MB,MC) IF (NTRACE.NE.0) THEN CALL ZMNTR(1,MB,MB,1) IF (ABS(NTRACE).GE.1 .AND. NCALL.LE.LVLTRC) THEN IF (NTRACE.LT.0) THEN CALL ZMNTRJ(MC,NDIG) ELSE CALL ZMPRNT(MC) ENDIF ENDIF ENDIF NCALL = NCALL - 1 RETURN ENDIF MARZ = MA(0) MAIZ = MA(KPTIMU) KACCSW = 0 KRSAVE = KRAD KRAD = 1 C CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C C Check for special cases. C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN CALL ZMI2M(1,MZ01) CALL ZMI2M(0,MC) GO TO 110 ELSE IF (MA(KPTIMU+2).EQ.0) THEN CALL FMCHSH(MA,MZ01,MC) CALL FMI2M(0,MZ01(KPTIMU)) CALL FMI2M(0,MC(KPTIMU)) GO TO 110 ELSE IF (MA(2).EQ.0) THEN CALL FMCSSN(MA(KPTIMU),MZ01,MC(KPTIMU)) CALL FMI2M(0,MZ01(KPTIMU)) CALL FMI2M(0,MC) GO TO 110 ENDIF C C Find SINH(REAL(MA)) and COSH(REAL(MA)). C CALL FMCHSH(MA,MZ02,MZ02(KPTIMU)) C C Find SIN(IMAG(MA)) and COS(IMAG(MA)). C CALL FMCSSN(MA(KPTIMU),MZ03,MZ03(KPTIMU)) C C COSH(MA) = COSH(REAL(MA))*COS(IMAG(MA)) + C SINH(REAL(MA))*SIN(IMAG(MA)) i C CALL FMMPY(MZ02,MZ03,MZ01) CALL FMMPY(MZ02(KPTIMU),MZ03(KPTIMU),MZ01(KPTIMU)) C C SINH(MA) = SINH(REAL(MA))*COS(IMAG(MA)) + C COSH(REAL(MA))*SIN(IMAG(MA)) i C CALL FMMPY(MZ02(KPTIMU),MZ03,MC) CALL FMMPY(MZ02,MZ03(KPTIMU),MC(KPTIMU)) C 110 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.NE.0) THEN IF (ABS(NTRACE).GE.1 .AND. NCALL+1.LE.LVLTRC) THEN IF (NTRACE.LT.0) THEN CALL ZMNTRJ(MC,NDIG) ELSE CALL ZMPRNT(MC) ENDIF ENDIF ENDIF KRAD = KRSAVE RETURN END SUBROUTINE ZMCMPX(MAFM,MBFM,MC) C C MC = COMPLEX( MAFM , MBFM ) C C MAFM and MBFM are real FM numbers, MC is a complex ZM number. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MAFM(0:LUNPCK),MBFM(0:LUNPCK),MC(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMCMPX' IF (NTRACE.NE.0) CALL FMNTR(2,MAFM,MBFM,2) C CALL FMEQ(MAFM,MC) CALL FMEQ(MBFM,MC(KPTIMU)) C IF (NTRACE.NE.0) CALL ZMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMCONJ(MA,MB) C C MB = CONJG(MA) C C Complex conjugate. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMCONJ' IF (NTRACE.NE.0) CALL ZMNTR(2,MA,MA,1) C CALL FMEQ(MA,MB) CALL FMEQ(MA(KPTIMU),MB(KPTIMU)) IF (MB(KPTIMU+1).NE.MUNKNO) MB(KPTIMU+2) = -MB(KPTIMU+2) C IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMCOS(MA,MB) C C MB = COS(MA). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMCOS: M01 - M06, MZ01 - MZ03 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE C CALL ZMENTR('ZMCOS ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN MARZ = MA(0) MAIZ = MA(KPTIMU) KACCSW = 0 KRSAVE = KRAD KRAD = 1 C CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C C Check for special cases. C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN CALL ZMI2M(1,MZ01) GO TO 110 ELSE IF (MA(KPTIMU+2).EQ.0) THEN CALL FMCOS(MA,MZ01) CALL FMI2M(0,MZ01(KPTIMU)) GO TO 110 ELSE IF (MA(2).EQ.0) THEN CALL FMCOSH(MA(KPTIMU),MZ01) CALL FMI2M(0,MZ01(KPTIMU)) GO TO 110 ENDIF C C Find COS(REAL(MA)) and SIN(REAL(MA)). C CALL FMCSSN(MA,MZ01,MZ01(KPTIMU)) C C Find COSH(IMAG(MA)) and SINH(IMAG(MA)). C CALL FMCHSH(MA(KPTIMU),M05,M06) C C COS(MA) = COS(REAL(MA))*COSH(IMAG(MA)) - C SIN(REAL(MA))*SINH(IMAG(MA)) i C CALL FMMPY(MZ01,M05,MZ01) IF (M06(1).NE.MUNKNO) M06(2) = -M06(2) CALL FMMPY(MZ01(KPTIMU),M06,MZ01(KPTIMU)) C 110 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(MA,MB) C C MB = COSH(MA). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMCOSH: M01 - M06, MZ01 - MZ03 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE C CALL ZMENTR('ZMCOSH',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN MARZ = MA(0) MAIZ = MA(KPTIMU) KACCSW = 0 KRSAVE = KRAD KRAD = 1 C CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C C Check for special cases. C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN CALL ZMI2M(1,MZ01) GO TO 110 ELSE IF (MA(2).EQ.0) THEN CALL FMCOS(MA(KPTIMU),MZ01) CALL FMI2M(0,MZ01(KPTIMU)) GO TO 110 ELSE IF (MA(KPTIMU+2).EQ.0) THEN CALL FMCOSH(MA,MZ01) CALL FMI2M(0,MZ01(KPTIMU)) GO TO 110 ENDIF C C Find COS(IMAG(MA)) and SIN(IMAG(MA)). C CALL FMCSSN(MA(KPTIMU),MZ01,MZ01(KPTIMU)) C C Find COSH(REAL(MA)) and SINH(REAL(MA)). C CALL FMCHSH(MA,M05,M06) C C COSH(MA) = COSH(REAL(MA))*COS(IMAG(MA)) + C SINH(REAL(MA))*SIN(IMAG(MA)) i C CALL FMMPY(MZ01,M05,MZ01) CALL FMMPY(MZ01(KPTIMU),M06,MZ01(KPTIMU)) C 110 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 ZMCSSN(MA,MB,MC) C C MB = COS(MA), MC = SIN(MA). C C If both the sine and cosine are needed, this routine is faster C than calling both ZMCOS and ZMSIN. C C MB and MC must be distinct arrays. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMCSSN: M01 - M06, MZ01 - MZ04 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NCSAVE,NDSAVE C NCSAVE = NCALL CALL ZMENTR('ZMCSSN',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) NCALL = NCSAVE + 1 IF (KRESLT.NE.0) THEN CALL ZMEQ(MB,MC) IF (NTRACE.NE.0) THEN CALL ZMNTR(1,MB,MB,1) IF (ABS(NTRACE).GE.1 .AND. NCALL.LE.LVLTRC) THEN IF (NTRACE.LT.0) THEN CALL ZMNTRJ(MC,NDIG) ELSE CALL ZMPRNT(MC) ENDIF ENDIF ENDIF NCALL = NCALL - 1 RETURN ENDIF MARZ = MA(0) MAIZ = MA(KPTIMU) KACCSW = 0 KRSAVE = KRAD KRAD = 1 C CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C C Check for special cases. C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN CALL ZMI2M(1,MZ01) CALL ZMI2M(0,MC) GO TO 110 ELSE IF (MA(KPTIMU+2).EQ.0) THEN CALL FMCSSN(MA,MZ01,MC) CALL FMI2M(0,MZ01(KPTIMU)) CALL FMI2M(0,MC(KPTIMU)) GO TO 110 ELSE IF (MA(2).EQ.0) THEN CALL FMCHSH(MA(KPTIMU),MZ01,MC(KPTIMU)) CALL FMI2M(0,MZ01(KPTIMU)) CALL FMI2M(0,MC) GO TO 110 ENDIF C C Find SIN(REAL(MA)) and COS(REAL(MA)). C CALL FMCSSN(MA,MZ02,MZ02(KPTIMU)) C C Find SINH(IMAG(MA)) and COSH(IMAG(MA)). C CALL FMCHSH(MA(KPTIMU),MZ03,MZ03(KPTIMU)) C C COS(MA) = COS(REAL(MA))*COSH(IMAG(MA)) - C SIN(REAL(MA))*SINH(IMAG(MA)) i C CALL FMMPY(MZ02,MZ03,MZ01) CALL FMMPY(MZ02(KPTIMU),MZ03(KPTIMU),MZ01(KPTIMU)) IF (MZ01(KPTIMU+1).NE.MUNKNO) MZ01(KPTIMU+2) = -MZ01(KPTIMU+2) C C SIN(MA) = SIN(REAL(MA))*COSH(IMAG(MA)) + C COS(REAL(MA))*SINH(IMAG(MA)) i C CALL FMMPY(MZ02(KPTIMU),MZ03,MC) CALL FMMPY(MZ02,MZ03(KPTIMU),MC(KPTIMU)) C 110 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.NE.0) THEN IF (ABS(NTRACE).GE.1 .AND. NCALL+1.LE.LVLTRC) THEN IF (NTRACE.LT.0) THEN CALL ZMNTRJ(MC,NDIG) ELSE CALL ZMPRNT(MC) ENDIF ENDIF ENDIF KRAD = KRSAVE RETURN END SUBROUTINE ZMDIV(MA,MB,MC) C C MC = MA / MB C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMDIV: M01 - M04, MZ01 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MBIZ,MBRZ,MXSAVE,MZ11SV,MZ1KSV, * MZERO INTEGER IEXTRA,J,KASAVE,KOVUN,KRESLT,KWRNSV,NDGSV2,NDSAVE,NGOAL, * NTRSAV C IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MA(KPTIMU+1)).GT.MEXPAB .OR. * ABS(MB(1)).GT.MEXPAB .OR. ABS(MB(KPTIMU+1)).GT.MEXPAB .OR. * KDEBUG.GE.1) THEN CALL ZMENTR('ZMDIV ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'ZMDIV ' CALL ZMNTR(2,MA,MB,2) ENDIF NDSAVE = NDIG IF (NCALL.EQ.1) THEN NDIG = MAX(NDIG+NGRD52,2) IF (NDIG.GT.NDG2MX) THEN NAMEST(NCALL) = 'ZMDIV ' KFLAG = -9 CALL ZMWARN KRESLT = 12 NDIG = NDSAVE CALL ZMRSLT(MC,KRESLT) IF (NTRACE.NE.0) CALL ZMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN ENDIF IF (MBASE.GE.100*ABS(MA(2)) .OR. * MBASE.GE.100*ABS(MA(KPTIMU+2))) THEN NDIG = MIN(NDIG+1,NDG2MX) ELSE IF (MBASE.GE.100*ABS(MB(2)) .OR. * MBASE.GE.100*ABS(MB(KPTIMU+2))) THEN NDIG = MIN(NDIG+1,NDG2MX) ENDIF ENDIF KASAVE = KACCSW KACCSW = 1 MXSAVE = MXEXP MXEXP = MXEXP2 KOVUN = 0 ENDIF C 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 C 110 DO 120 J = NDSAVE+2, NDIG+1 MA(J) = MZERO MB(J) = MZERO MA(KPTIMU+J) = MZERO MB(KPTIMU+J) = MZERO 120 CONTINUE IF (NCALL.EQ.1) THEN MA(0) = NINT(NDIG*ALOGM2) MB(0) = MA(0) MA(KPTIMU) = MA(0) MB(KPTIMU) = MA(0) ENDIF C C Check for special cases. C IF (MB(KPTIMU+2).EQ.0) THEN CALL FMDIVD(MA,MA(KPTIMU),MB,MZ01,MZ01(KPTIMU)) GO TO 170 ELSE IF (MB(2).EQ.0) THEN CALL FMDIVD(MA(KPTIMU),MA,MB(KPTIMU),MZ01,MZ01(KPTIMU)) IF (MZ01(KPTIMU+1).NE.MUNKNO) MZ01(KPTIMU+2) = -MZ01(KPTIMU+2) GO TO 170 ENDIF IF (MA(1).EQ.MB(1) .AND. MA(2).EQ.MB(2)) THEN IF (MA(KPTIMU+1).EQ.MB(KPTIMU+1) .AND. * MA(KPTIMU+2).EQ.MB(KPTIMU+2)) THEN DO 130 J = 3, NDSAVE+1 IF (MA(J).NE.MB(J)) GO TO 150 IF (MA(KPTIMU+J).NE.MB(KPTIMU+J)) GO TO 150 130 CONTINUE IF (ABS(MA(1)).LT.MEXPOV .AND. ABS(MA(KPTIMU+1)).LT.MEXPOV * .AND. ABS(MB(1)).LT.MEXPOV .AND. * ABS(MB(KPTIMU+1)).LT.MEXPOV) THEN CALL ZMI2M(1,MZ01) GO TO 170 ENDIF ENDIF ENDIF IF (MA(1).EQ.MB(1) .AND. (-MA(2)).EQ.MB(2)) THEN IF (MA(KPTIMU+1).EQ.MB(KPTIMU+1) .AND. * (-MA(KPTIMU+2)).EQ.MB(KPTIMU+2)) THEN DO 140 J = 3, NDSAVE+1 IF (MA(J).NE.MB(J)) GO TO 150 IF (MA(KPTIMU+J).NE.MB(KPTIMU+J)) GO TO 150 140 CONTINUE IF (ABS(MA(1)).LT.MEXPOV .AND. ABS(MA(KPTIMU+1)).LT.MEXPOV * .AND. ABS(MB(1)).LT.MEXPOV .AND. * ABS(MB(KPTIMU+1)).LT.MEXPOV) THEN CALL ZMI2M(-1,MZ01) GO TO 170 ENDIF ENDIF ENDIF 150 IF (MZ11SV.NE.-MUNKNO) THEN C C If a retry is being done due to cancellation, try a slower C but more stable form of the division formula. C CALL FMMPYE(MB,MA,MA(KPTIMU),MB,MZ01,MZ01(KPTIMU),M03) CALL FMMPYE(MB(KPTIMU),MA(KPTIMU),MA,MB(KPTIMU),M01,M02,M04) CALL FMADD(M03,M04,M04) CALL FMADD(MZ01,M01,MZ01) CALL FMSUB(MZ01(KPTIMU),M02,MZ01(KPTIMU)) CALL FMDIVD(MZ01,MZ01(KPTIMU),M04,MZ01,MZ01(KPTIMU)) IF (ABS(MZ01(1)).LT.MEXPOV .AND. * ABS(MZ01(KPTIMU+1)).LT.MEXPOV) GO TO 170 ENDIF C C Normal method for ( a + b i ) / ( c + d i ): C C If abs(c) << abs(d) Then C C P = c / d C result = ( a*P + b )/( c*P + d ) + C ( b*P - a )/( c*P + d ) i C C Else C C P = d / c C result = ( b*P + a )/( d*P + c ) + C ( b - a*P )/( d*P + c ) i C KACCSW = 0 IF (MB(1).LE.MB(KPTIMU+1)) THEN CALL FMDIV(MB,MB(KPTIMU),M04) CALL FMMPYE(M04,MA,MA(KPTIMU),MB,MZ01,MZ01(KPTIMU),M03) IF (MA(KPTIMU+2)*MZ01(2).LT.0) THEN KACCSW = 1 ELSE KACCSW = 0 ENDIF CALL FMADD(MA(KPTIMU),MZ01,MZ01) IF (M03(2)*MB(KPTIMU+2).LT.0) THEN KACCSW = 1 ELSE KACCSW = 0 ENDIF CALL FMADD(M03,MB(KPTIMU),M03) IF (MZ01(KPTIMU+2)*MA(2).LT.0) THEN KACCSW = 0 ELSE KACCSW = 1 ENDIF CALL FMSUB(MZ01(KPTIMU),MA,MZ01(KPTIMU)) KACCSW = 0 CALL FMDIVD(MZ01,MZ01(KPTIMU),M03,MZ01,MZ01(KPTIMU)) ELSE CALL FMDIV(MB(KPTIMU),MB,M04) CALL FMMPYE(M04,MA(KPTIMU),MA,MB(KPTIMU), * MZ01,MZ01(KPTIMU),M03) IF (MA(2)*MZ01(2).LT.0) THEN KACCSW = 1 ELSE KACCSW = 0 ENDIF CALL FMADD(MA,MZ01,MZ01) IF (M03(2)*MB(2).LT.0) THEN KACCSW = 1 ELSE KACCSW = 0 ENDIF CALL FMADD(M03,MB,M03) IF (MZ01(KPTIMU+2)*MA(KPTIMU+2).LT.0) THEN KACCSW = 0 ELSE KACCSW = 1 ENDIF CALL FMSUB(MA(KPTIMU),MZ01(KPTIMU),MZ01(KPTIMU)) KACCSW = 0 CALL FMDIVD(MZ01,MZ01(KPTIMU),M03,MZ01,MZ01(KPTIMU)) ENDIF KACCSW = 1 C C Check for too much cancellation. C IF (NCALL.LE.1) THEN NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7 ELSE NGOAL = INT(-MXEXP2) ENDIF IF (MZ01(0).LE.NGOAL .OR. MZ01(KPTIMU).LE.NGOAL) THEN IF (MZ11SV-MZ01(1).GE.IEXTRA-1 .AND. MZ01(KPTIMU).GT.NGOAL) * GO TO 170 IF (MZ1KSV-MZ01(KPTIMU+1).GE.IEXTRA-1 .AND. MZ01(0).GT.NGOAL) * GO TO 170 IF (MZ11SV.GT.-MUNKNO .AND. MZ01(0).GT.NGOAL .AND. * MZ01(KPTIMU+2).EQ.0) GO TO 170 IF (MZ11SV.GT.-MUNKNO .AND. MZ01(KPTIMU).GT.NGOAL .AND. * MZ01(2).EQ.0) GO TO 170 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.GT.NDG2MX) THEN NAMEST(NCALL) = 'ZMDIV ' KFLAG = -9 CALL ZMWARN MZ01(1) = MUNKNO MZ01(2) = 1 MZ01(KPTIMU+1) = MUNKNO MZ01(KPTIMU+2) = 1 DO 160 J = 2, NDSAVE MZ01(J+1) = 0 MZ01(KPTIMU+J+1) = 0 160 CONTINUE NDIG = NDIG - IEXTRA MZ01(0) = NINT(NDIG*ALOGM2) MZ01(KPTIMU) = NINT(NDIG*ALOGM2) GO TO 170 ENDIF GO TO 110 ENDIF C 170 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).GE.MEXPOV .OR. MC(1).LE.-MEXPOV .OR. * MC(KPTIMU+1).GE.MEXPOV .OR. MC(KPTIMU+1).LE.-MEXPOV) THEN IF (MC(1).EQ.MUNKNO .OR. MC(KPTIMU+1).EQ.MUNKNO) THEN KFLAG = -4 ELSE IF (MC(1).EQ.MEXPOV .OR. MC(KPTIMU+1).EQ.MEXPOV) THEN KFLAG = -5 ELSE IF (MC(1).EQ.MEXPUN .OR. MC(KPTIMU+1).EQ.MEXPUN) THEN KFLAG = -6 ENDIF IF ((MC(1).EQ.MUNKNO) * .OR. (MC(KPTIMU+1).EQ.MUNKNO) * .OR. (MC(1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MC(KPTIMU+1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MC(1).EQ.MEXPOV .AND. KOVUN.EQ.0) * .OR. (MC(KPTIMU+1).EQ.MEXPOV .AND. KOVUN.EQ.0)) THEN NAMEST(NCALL) = 'ZMDIV ' CALL ZMWARN ENDIF ENDIF IF (NTRACE.NE.0) CALL ZMNTR(1,MC,MC,1) KACCSW = KASAVE NCALL = NCALL - 1 RETURN END SUBROUTINE ZMDIVI(MA,INTEG,MB) C C MB = MA / INTEG Divide by one-word (real) integer. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) INTEGER INTEG C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV DOUBLE PRECISION MXSAVE C IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MA(KPTIMU+1)).GT.MEXPAB .OR. * KDEBUG.GE.1) THEN CALL ZMENTR('ZMDIVI',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN NDIG = NDSAVE MXEXP = MXSAVE KACCSW = KASAVE NTRSAV = NTRACE ELSE NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'ZMDIVI' CALL ZMNTR(2,MA,MA,1) CALL FMNTRI(2,INTEG,0) ENDIF KOVUN = 0 ENDIF C C Force FMDIVI to use more guard digits for user calls. C NCALL = NCALL - 1 NTRSAV = NTRACE NTRACE = 0 KWRNSV = KWARN KWARN = 0 C CALL FMDIVI(MA,INTEG,MB) CALL FMDIVI(MA(KPTIMU),INTEG,MB(KPTIMU)) C NTRACE = NTRSAV KWARN = KWRNSV NCALL = NCALL + 1 IF (NTRACE.NE.0) NAMEST(NCALL) = 'ZMDIVI' IF (MB(1).EQ.MUNKNO .OR. MB(KPTIMU+1).EQ.MUNKNO) THEN KFLAG = -4 ELSE IF (MB(1).EQ.MEXPOV .OR. MB(KPTIMU+1).EQ.MEXPOV) THEN KFLAG = -5 ELSE IF (MB(1).EQ.MEXPUN .OR. MB(KPTIMU+1).EQ.MEXPUN) THEN KFLAG = -6 ENDIF IF ((MB(1).EQ.MUNKNO) * .OR. (MB(KPTIMU+1).EQ.MUNKNO) * .OR. (MB(1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MB(KPTIMU+1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MB(1).EQ.MEXPOV .AND. KOVUN.EQ.0) * .OR. (MB(KPTIMU+1).EQ.MEXPOV .AND. KOVUN.EQ.0)) THEN NAMEST(NCALL) = 'ZMDIVI' CALL ZMWARN ENDIF IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMENTR(NROUTN,MA,MB,NARGS,MC,KRESLT,NDSAVE,MXSAVE, * KASAVE,KOVUN) C C Do the argument checking and increasing of precision, overflow C threshold, etc., upon entry to a ZM routine. C C NROUTN - routine name of calling routine C MA - first input argument C MB - second input argument (optional) C NARGS - number of input arguments C MC - result argument C KRESLT - returned nonzero if the input arguments give the result C immediately (e.g., MA*0 or OVERFLOW*MB) C NDSAVE - saves the value of NDIG after NDIG is increased C MXSAVE - saves the value of MXEXP C KASAVE - saves the value of KACCSW C KOVUN - returned nonzero if an input argument is (+ or -) overflow C or underflow. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C CHARACTER *6 NROUTN DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ),MXSAVE INTEGER NARGS,KRESLT,NDSAVE,KASAVE,KOVUN C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MBS INTEGER J,KWRNSV,NDS C KRESLT = 0 NCALL = NCALL + 1 KFLAG = 0 NAMEST(NCALL) = NROUTN IF (NTRACE.NE.0) CALL ZMNTR(2,MA,MB,NARGS) C IF (MBLOGS.NE.MBASE) CALL FMCONS KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN .OR. * MA(KPTIMU+1).EQ.MEXPOV .OR. MA(KPTIMU+1).EQ.MEXPUN) KOVUN = 1 IF (NARGS.EQ.2) THEN IF (MB(1).EQ.MEXPOV .OR. MB(1).EQ.MEXPUN .OR. * MB(KPTIMU+1).EQ.MEXPOV .OR. MB(KPTIMU+1).EQ.MEXPUN) KOVUN = 1 ENDIF KASAVE = KACCSW MXSAVE = MXEXP C C Check the validity of parameters if this is a user call. C IF (NCALL.GT.1 .AND. KDEBUG.EQ.0) GO TO 190 C C Check NDIG. C IF (NDIG.LT.2 .OR. NDIG.GT.NDIGMX) THEN KFLAG = -1 CALL ZMWARN NDS = NDIG IF (NDIG.LT.2) NDIG = 2 IF (NDIG.GT.NDIGMX) NDIG = NDIGMX WRITE (KW,110) NDS,NDIG 110 FORMAT(' NDIG was',I10,'. It has been changed to',I10,'.') KRESLT = 12 GO TO 190 ENDIF C C Check MBASE. C IF (MBASE.LT.2 .OR. MBASE.GT.MXBASE) THEN KFLAG = -2 CALL ZMWARN MBS = MBASE IF (MBASE.LT.2) MBASE = 2 IF (MBASE.GT.MXBASE) MBASE = MXBASE WRITE (KW,120) INT(MBS),INT(MBASE) 120 FORMAT(' MBASE was',I10,'. It has been changed to',I10,'.') CALL FMCONS KRESLT = 12 GO TO 190 ENDIF C C Check exponent range. C IF (MA(1).GT.MXEXP+1 .OR. MA(1).LT.-MXEXP) THEN IF ((ABS(MA(1)).NE.MEXPOV .AND. ABS(MA(1)).NE.MUNKNO) .OR. * ABS(MA(2)).NE.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 190 ENDIF ENDIF IF (MA(KPTIMU+1).GT.MXEXP+1 .OR. MA(KPTIMU+1).LT.-MXEXP) THEN IF ((ABS(MA(KPTIMU+1)).NE.MEXPOV .AND. * ABS(MA(KPTIMU+1)).NE.MUNKNO) .OR. * ABS(MA(KPTIMU+2)).NE.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 190 ENDIF ENDIF IF (NARGS.EQ.2) THEN IF (MB(1).GT.MXEXP+1 .OR. MB(1).LT.-MXEXP) THEN IF ((ABS(MB(1)).NE.MEXPOV .AND. ABS(MB(1)).NE.MUNKNO) .OR. * ABS(MB(2)).NE.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 190 ENDIF ENDIF IF (MB(KPTIMU+1).GT.MXEXP+1 .OR. MB(KPTIMU+1).LT.-MXEXP) THEN IF ((ABS(MB(KPTIMU+1)).NE.MEXPOV .AND. * ABS(MB(KPTIMU+1)).NE.MUNKNO) .OR. * ABS(MB(KPTIMU+2)).NE.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 190 ENDIF ENDIF ENDIF C C Check for properly normalized digits in the C input arguments. C IF (ABS(MA(1)-INT(MA(1))).NE.0) KFLAG = 1 IF (ABS(MA(KPTIMU+1)-INT(MA(KPTIMU+1))).NE.0) KFLAG = KPTIMU + 1 IF (MA(2).LE.(-MBASE) .OR. MA(2).GE.MBASE .OR. * ABS(MA(2)-INT(MA(2))).NE.0) KFLAG = 2 IF (MA(KPTIMU+2).LE.(-MBASE) .OR. MA(KPTIMU+2).GE.MBASE .OR. * ABS(MA(KPTIMU+2)-INT(MA(KPTIMU+2))).NE.0) KFLAG = KPTIMU + 2 IF (KDEBUG.EQ.0) GO TO 150 DO 130 J = 3, NDIG+1 IF (MA(J).LT.0 .OR. MA(J).GE.MBASE .OR. * ABS(MA(J)-INT(MA(J))).NE.0) THEN KFLAG = J GO TO 150 ENDIF 130 CONTINUE DO 140 J = KPTIMU+3, KPTIMU+NDIG+1 IF (MA(J).LT.0 .OR. MA(J).GE.MBASE .OR. * ABS(MA(J)-INT(MA(J))).NE.0) THEN KFLAG = J GO TO 150 ENDIF 140 CONTINUE 150 IF (KFLAG.NE.0) THEN J = KFLAG MBS = MA(J) CALL ZMI2M(0,MA) KFLAG = -4 KWRNSV = KWARN IF (KWARN.GE.2) KWARN = 1 CALL ZMWARN KWARN = KWRNSV IF (KWARN.GE.1) THEN IF (J.LT.KPTIMU) THEN WRITE (KW,*) ' First invalid array element: MA(', * J,') = ',MBS ELSE WRITE (KW,*) ' First invalid array element: MA(', * KPTIMU,'+',J-KPTIMU,') = ',MBS ENDIF ENDIF MA(1) = MUNKNO MA(2) = 1 MA(KPTIMU+1) = MUNKNO MA(KPTIMU+2) = 1 MA(0) = NINT(NDIG*ALOGM2) MA(KPTIMU) = NINT(NDIG*ALOGM2) IF (KWARN.GE.2) THEN STOP ENDIF KRESLT = 12 GO TO 190 ENDIF IF (NARGS.EQ.2) THEN IF (ABS(MB(1)-INT(MB(1))).NE.0) KFLAG = 1 IF (ABS(MB(KPTIMU+1)-INT(MB(KPTIMU+1))).NE.0) * KFLAG = KPTIMU + 1 IF (MB(2).LE.(-MBASE) .OR. MB(2).GE.MBASE .OR. * ABS(MB(2)-INT(MB(2))).NE.0) KFLAG = 2 IF (MB(KPTIMU+2).LE.(-MBASE) .OR. MB(KPTIMU+2).GE.MBASE .OR. * ABS(MB(KPTIMU+2)-INT(MB(KPTIMU+2))).NE.0) * KFLAG = KPTIMU + 2 IF (KDEBUG.EQ.0) GO TO 180 DO 160 J = 3, NDIG+1 IF (MB(J).LT.0 .OR. MB(J).GE.MBASE .OR. * ABS(MB(J)-INT(MB(J))).NE.0) THEN KFLAG = J GO TO 180 ENDIF 160 CONTINUE DO 170 J = KPTIMU+3, KPTIMU+NDIG+1 IF (MB(J).LT.0 .OR. MB(J).GE.MBASE .OR. * ABS(MB(J)-INT(MB(J))).NE.0) THEN KFLAG = J GO TO 180 ENDIF 170 CONTINUE 180 IF (KFLAG.NE.0) THEN J = KFLAG MBS = MB(J) CALL ZMI2M(0,MB) KFLAG = -4 KWRNSV = KWARN IF (KWARN.GE.2) KWARN = 1 CALL ZMWARN KWARN = KWRNSV IF (KWARN.GE.1) THEN IF (J.LT.KPTIMU) THEN WRITE (KW,*) ' First invalid array element: MB(', * J,') = ',MBS ELSE WRITE (KW,*) ' First invalid array element: MB(', * KPTIMU,'+',J-KPTIMU,') = ',MBS ENDIF ENDIF MB(1) = MUNKNO MB(2) = 1 MB(KPTIMU+1) = MUNKNO MB(KPTIMU+2) = 1 MB(0) = NINT(NDIG*ALOGM2) MB(KPTIMU) = NINT(NDIG*ALOGM2) IF (KWARN.GE.2) THEN STOP ENDIF KRESLT = 12 GO TO 190 ENDIF ENDIF C C Increase the working precision. C 190 NDSAVE = NDIG IF (NCALL.EQ.1) THEN NDIG = MAX(NDIG+NGRD52,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL ZMWARN KRESLT = 12 NDIG = NDSAVE ENDIF IF (MBASE.GE.100*ABS(MA(2)) .OR. * MBASE.GE.100*ABS(MA(KPTIMU+2))) THEN NDIG = MIN(NDIG+1,NDG2MX) ELSE IF (NARGS.EQ.2 .AND. (MBASE.GE.100*ABS(MB(2)) .OR. * MBASE.GE.100*ABS(MB(KPTIMU+2)))) THEN NDIG = MIN(NDIG+1,NDG2MX) ENDIF ENDIF IF ((MA(1).EQ.MUNKNO .AND. MA(KPTIMU+1).EQ.MUNKNO) .OR. * (MB(1).EQ.MUNKNO .AND. MB(KPTIMU+1).EQ.MUNKNO)) THEN KFLAG = -4 KRESLT = 12 ENDIF IF (KRESLT.NE.0) THEN NDIG = NDSAVE CALL ZMRSLT(MC,KRESLT) IF (NTRACE.NE.0) CALL ZMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN ENDIF C KACCSW = 1 C C Extend the overflow/underflow threshold. C MXEXP = MXEXP2 RETURN END SUBROUTINE ZMEQ(MA,MB) C C MB = MA C C This is the standard form of equality, where MA and MB both C have precision NDIG. Use ZMEQU for assignments that also C change precision. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C CALL FMEQ(MA,MB) CALL FMEQ(MA(KPTIMU),MB(KPTIMU)) RETURN END SUBROUTINE ZMEQ2(MA,MB,NDA,NDB,KSAME) C C Set MB (having NDB digits) equal to MA (having NDA digits). C C If MA and MB are the same array, setting KSAME = 1 before calling C ZMEQ2 gives faster performance. C C If MB has less precision than MA, the result is rounded to C NDB digits. C C If MB has more precision, the result has zero digits padded on the C right. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) INTEGER NDA,NDB,KSAME C CALL FMEQ2(MA,MB,NDA,NDB,KSAME) CALL FMEQ2(MA(KPTIMU),MB(KPTIMU),NDA,NDB,KSAME) RETURN END SUBROUTINE ZMEQU(MA,MB,NDA,NDB) C C Set MB (having NDB digits) equal to MA (having NDA digits). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) INTEGER NDA,NDB C CALL FMEQ2(MA,MB,NDA,NDB,0) CALL FMEQ2(MA(KPTIMU),MB(KPTIMU),NDA,NDB,0) RETURN END SUBROUTINE ZMEXIT(MT,MC,NDSAVE,MXSAVE,KASAVE,KOVUN,KSAME) C C Upon exit from an ZM routine the result MT (having precision NDIG) C is rounded and returned in MC (having precision NDSAVE). C The values of NDIG, MXEXP, and KACCSW are restored to the values C NDSAVE,MXSAVE,KASAVE. C KSAME is 1 if MT and MC are the same array in the calling routine. C KOVUN is nonzero if one of the routine's input arguments was overflow C or underflow. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MT(0:LUNPKZ),MC(0:LUNPKZ),MXSAVE INTEGER NDSAVE,KASAVE,KOVUN,KSAME C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER KFSAVE,KWRNSV C KWRNSV = KWARN KWARN = 0 MXEXP = MXSAVE KFSAVE = KFLAG KACCSW = KASAVE CALL ZMEQ2(MT,MC,NDIG,NDSAVE,KSAME) IF (KFLAG.NE.-5 .AND. KFLAG.NE.-6) KFLAG = KFSAVE NDIG = NDSAVE KWARN = KWRNSV IF (KFLAG.EQ.1) KFLAG = 0 IF (MC(1).EQ.MEXPUN .OR. MC(KPTIMU+1).EQ.MEXPUN) KFLAG = -6 IF (MC(1).EQ.MEXPOV .OR. MC(KPTIMU+1).EQ.MEXPOV) KFLAG = -5 IF (MC(1).EQ.MUNKNO .OR. MC(KPTIMU+1).EQ.MUNKNO) THEN IF (KFLAG.NE.-9) KFLAG = -4 ENDIF IF ((MC(1).EQ.MUNKNO .AND. KFLAG.NE.-9) .OR. * (MC(KPTIMU+1).EQ.MUNKNO .AND. KFLAG.NE.-9) .OR. * (MC(1).EQ.MEXPUN .AND. KOVUN.EQ.0) .OR. * (MC(KPTIMU+1).EQ.MEXPUN .AND. KOVUN.EQ.0) .OR. * (MC(1).EQ.MEXPOV .AND. KOVUN.EQ.0) .OR. * (MC(KPTIMU+1).EQ.MEXPOV .AND. KOVUN.EQ.0)) CALL ZMWARN IF (NTRACE.NE.0) CALL ZMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMEXI2(MTFM,MCFM,NDSAVE,MXSAVE,KASAVE,KOVUN,KSAME) C C This routine is used upon exit for complex functions that C return real FM results. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MTFM(0:LUNPCK),MCFM(0:LUNPCK),MXSAVE INTEGER NDSAVE,KASAVE,KOVUN,KSAME C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER KFSAVE,KWRNSV C KWRNSV = KWARN KWARN = 0 MXEXP = MXSAVE KFSAVE = KFLAG KACCSW = KASAVE CALL FMEQ2(MTFM,MCFM,NDIG,NDSAVE,KSAME) IF (KFLAG.NE.-5 .AND. KFLAG.NE.-6) KFLAG = KFSAVE NDIG = NDSAVE KWARN = KWRNSV IF (KFLAG.EQ.1) KFLAG = 0 IF (MCFM(1).EQ.MUNKNO) THEN IF (KFLAG.GE.0) KFLAG = -4 ELSE IF (MCFM(1).EQ.MEXPOV) THEN KFLAG = -5 ELSE IF (MCFM(1).EQ.MEXPUN) THEN KFLAG = -6 ENDIF IF ((MCFM(1).EQ.MUNKNO .AND. KFLAG.NE.-9) * .OR. (MCFM(1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MCFM(1).EQ.MEXPOV .AND. KOVUN.EQ.0)) CALL ZMWARN IF (NTRACE.NE.0) CALL ZMNTR2(1,MCFM,MCFM,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMEXP(MA,MB) C C MB = EXP(MA). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMEXP: M01 - M06, MZ01 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,KWRNSV,NDSAVE C CALL ZMENTR('ZMEXP ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN MARZ = MA(0) MAIZ = MA(KPTIMU) KACCSW = 0 KRSAVE = KRAD KRAD = 1 C CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C C Check for special cases. C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN CALL ZMI2M(1,MZ01) GO TO 110 ELSE IF (MA(2).EQ.0) THEN CALL FMI2M(1,M06) ELSE CALL FMEXP(MA,M06) ENDIF C CALL FMCSSN(MA(KPTIMU),MZ01,MZ01(KPTIMU)) C KWRNSV = KWARN KWARN = 0 CALL FMMPYD(M06,MZ01,MZ01(KPTIMU),MZ01,MZ01(KPTIMU)) KWARN = KWRNSV C 110 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 ZMFORM(FORM1,FORM2,MA,STRING) C C Convert MA to STRING using FORM1 format for the real part and C FORM2 format for the imaginary part. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C CHARACTER *(*) FORM1,FORM2,STRING DOUBLE PRECISION MA(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER JFORMZ,JPRNTZ C COMMON /ZMUSER/ JFORMZ,JPRNTZ CHARACTER CMBUFZ COMMON /ZMBUFF/ CMBUFZ(LMBUFZ) C INTEGER J,KWIDIM,KWIDRE,LAST,LSIGN C NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMFORM' STRING = ' ' CALL ZMFPCM(FORM1,MA,KWIDRE,CMBUFZ) CALL FMEQ(MA(KPTIMU),M02) IF (M02(2).GE.0) THEN LSIGN = 1 ELSE LSIGN = -1 M02(2) = -M02(2) ENDIF CALL ZMFPCM(FORM2,M02,KWIDIM,CMBUFF) C CMBUFZ(KWIDRE+1) = ' ' IF (LSIGN.EQ.1) THEN CMBUFZ(KWIDRE+2) = '+' ELSE CMBUFZ(KWIDRE+2) = '-' ENDIF CMBUFZ(KWIDRE+3) = ' ' DO 110 J = 1, KWIDIM CMBUFZ(KWIDRE+3+J) = CMBUFF(J) 110 CONTINUE CMBUFZ(KWIDRE+4+KWIDIM) = ' ' CMBUFZ(KWIDRE+5+KWIDIM) = 'i' IF (JFORMZ.EQ.2) CMBUFZ(KWIDRE+5+KWIDIM) = 'I' LAST = KWIDRE + KWIDIM + 5 C IF (LAST.LE.LEN(STRING)) THEN DO 120 J = 1, LAST STRING(J:J) = CMBUFZ(J) 120 CONTINUE ELSE DO 130 J = 1, LAST STRING(J:J) = '*' 130 CONTINUE ENDIF NCALL = NCALL - 1 RETURN END SUBROUTINE ZMFPCM(FORM,MA,KWI,CMB) C C Internal routine to convert MA to base 10 using FORM format. C The result is returned in CMB and the field width is KWI. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C CHARACTER *(*) FORM DOUBLE PRECISION MA(0:LUNPKZ) INTEGER KWI CHARACTER CMB(LMBUFF) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER *20 FORMB INTEGER J,JF1SAV,JF2SAV,JPT,K1,K2,K3,KD,KWD,KSAVE,LAST,LB, * LENGFM,LFIRST,ND,NEXP C KSAVE = KFLAG JF1SAV = JFORM1 JF2SAV = JFORM2 LENGFM = LEN(FORM) KWI = 75 KWD = 40 IF (INDEX(FORM,'I').GT.0 .OR. INDEX(FORM,'i').GT.0) THEN K1 = MAX(INDEX(FORM,'I'),INDEX(FORM,'i')) + 1 K2 = LENGFM WRITE (FORMB,110) K2-K1+1 110 FORMAT('(I',I5,')') IF (K2.GE.K1) THEN READ (FORM(K1:K2),FORMB) KWI ELSE KWI = 50 ENDIF KWI = MAX(1,MIN(KWI,LMBUFF-11)) JFORM1 = 2 JFORM2 = 0 KWD = KWI + 11 CALL FMNINT(MA,M03) IF (M03(2).NE.0) THEN CALL FMOUT(M03,CMB,KWD) ELSE DO 120 J = 1, KWD CMB(J) = ' ' 120 CONTINUE CMB(2) = '0' ENDIF LFIRST = 1 LAST = 1 DO 130 J = 1, KWD IF (CMB(KWD+1-J).NE.' ') LFIRST = KWD+1-J IF (CMB(J).NE.' ') LAST = J 130 CONTINUE JPT = 1 IF (LAST-LFIRST+1.GT.KWI) GO TO 220 IF (LAST.LE.KWI) THEN DO 140 J = LAST, LFIRST, -1 JPT = KWI - LAST + J CMB(JPT) = CMB(J) 140 CONTINUE DO 150 J = 1, JPT-1 CMB(J) = ' ' 150 CONTINUE ELSE DO 160 J = LFIRST, LAST JPT = KWI - LAST + J CMB(JPT) = CMB(J) 160 CONTINUE ENDIF ELSE IF (INDEX(FORM,'F').GT.0 .OR. INDEX(FORM,'f').GT.0) THEN K1 = MAX(INDEX(FORM,'F'),INDEX(FORM,'f')) + 1 K2 = INDEX(FORM(1:LENGFM),'.') K3 = LENGFM IF (K2.GT.K1) THEN WRITE (FORMB,110) K2-K1 READ (FORM(K1:K2-1),FORMB) KWI ELSE KWI = 50 ENDIF IF (K3.GT.K2) THEN WRITE (FORMB,110) K3-K2 READ (FORM(K2+1:K3),FORMB) KD ELSE KD = 0 ENDIF KWI = MAX(1,MIN(KWI,LMBUFF)) KD = MAX(0,MIN(KD,KWI-2)) JFORM1 = 2 JFORM2 = KD ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1 IF (ND.LT.2) ND = 2 NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6 LB = MAX(JFORM2+NEXP,ND+NEXP) LB = MIN(LB,LMBUFF) KWD = LB CALL FMOUT(MA,CMB,KWD) LFIRST = 1 LAST = 1 DO 170 J = 1, KWD IF (CMB(KWD+1-J).NE.' ') LFIRST = KWD+1-J IF (CMB(J).NE.' ') LAST = J 170 CONTINUE IF (LAST-LFIRST+1.GT.KWI) THEN C C Not enough room for this F format, or FMOUT converted C it to E format to avoid showing no significant digits. C See if a shortened form will fit in E format. C NEXP = INT(LOG10((ABS(MA(1))+1)*LOG10(DBLE(MBASE))+1)+1) ND = KWI - NEXP - 5 IF (ND.LT.1) THEN GO TO 220 ELSE JFORM1 = 0 JFORM2 = ND CALL FMOUT(MA,CMB,KWI) LFIRST = 1 LAST = 1 DO 180 J = 1, KWI IF (CMB(KWI+1-J).NE.' ') LFIRST = KWI+1-J IF (CMB(J).NE.' ') LAST = J 180 CONTINUE ENDIF ENDIF JPT = 1 IF (LAST.LE.KWI) THEN DO 190 J = LAST, LFIRST, -1 JPT = KWI - LAST + J CMB(JPT) = CMB(J) 190 CONTINUE DO 200 J = 1, JPT-1 CMB(J) = ' ' 200 CONTINUE ELSE DO 210 J = LFIRST, LAST JPT = KWI - LAST + J CMB(JPT) = CMB(J) 210 CONTINUE ENDIF ELSE IF (INDEX(FORM,'1PE').GT.0 .OR. INDEX(FORM,'1pe').GT.0) THEN K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1 K2 = INDEX(FORM(1:LENGFM),'.') K3 = LENGFM IF (K2.GT.K1) THEN WRITE (FORMB,110) K2-K1 READ (FORM(K1:K2-1),FORMB) KWI ELSE KWI = 50 ENDIF IF (K3.GT.K2) THEN WRITE (FORMB,110) K3-K2 READ (FORM(K2+1:K3),FORMB) KD ELSE KD = 0 ENDIF KWI = MAX(1,MIN(KWI,LMBUFF)) KD = MAX(0,MIN(KD,KWI-2)) JFORM1 = 1 JFORM2 = KD CALL FMOUT(MA,CMB,KWI) ELSE IF (INDEX(FORM,'E').GT.0 .OR. INDEX(FORM,'e').GT.0) THEN K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1 K2 = INDEX(FORM(1:LENGFM),'.') K3 = LENGFM IF (K2.GT.K1) THEN WRITE (FORMB,110) K2-K1 READ (FORM(K1:K2-1),FORMB) KWI ELSE KWI = 50 ENDIF IF (K3.GT.K2) THEN WRITE (FORMB,110) K3-K2 READ (FORM(K2+1:K3),FORMB) KD ELSE KD = 0 ENDIF KWI = MAX(1,MIN(KWI,LMBUFF)) KD = MAX(0,MIN(KD,KWI-2)) JFORM1 = 0 JFORM2 = KD CALL FMOUT(MA,CMB,KWI) ELSE GO TO 220 ENDIF C JFORM1 = JF1SAV JFORM2 = JF2SAV KFLAG = KSAVE RETURN C C Error condition. C 220 KFLAG = -8 DO 230 J = 1, KWI CMB(J) = '*' 230 CONTINUE JFORM1 = JF1SAV JFORM2 = JF2SAV KFLAG = KSAVE RETURN END SUBROUTINE ZMFPRT(FORM1,FORM2,MA) C C Print MA in base 10 using FORM1 format for the real part and C FORM2 format for the imaginary part. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C CHARACTER *(*) FORM1,FORM2 DOUBLE PRECISION MA(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER JFORMZ,JPRNTZ C COMMON /ZMUSER/ JFORMZ,JPRNTZ CHARACTER CMBUFZ COMMON /ZMBUFF/ CMBUFZ(LMBUFZ) C CHARACTER *20 FORM INTEGER J,K,KWIDIM,KWIDRE,LAST,LSIGN C NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMFPRT' C CALL ZMFPCM(FORM1,MA,KWIDRE,CMBUFZ) CALL FMEQ(MA(KPTIMU),M02) IF (M02(2).GE.0) THEN LSIGN = 1 ELSE LSIGN = -1 M02(2) = -M02(2) ENDIF CALL ZMFPCM(FORM2,M02,KWIDIM,CMBUFF) C CMBUFZ(KWIDRE+1) = ' ' IF (LSIGN.EQ.1) THEN CMBUFZ(KWIDRE+2) = '+' ELSE CMBUFZ(KWIDRE+2) = '-' ENDIF CMBUFZ(KWIDRE+3) = ' ' DO 110 J = 1, KWIDIM CMBUFZ(KWIDRE+3+J) = CMBUFF(J) 110 CONTINUE CMBUFZ(KWIDRE+4+KWIDIM) = ' ' CMBUFZ(KWIDRE+5+KWIDIM) = 'i' IF (JFORMZ.EQ.2) CMBUFZ(KWIDRE+5+KWIDIM) = 'I' LAST = KWIDRE + KWIDIM + 5 C IF (M02(1).EQ.MEXPOV .OR. M02(1).EQ.MEXPUN) THEN DO 120 J = KWIDRE+3, LAST IF (CMBUFZ(J).EQ.'O' .OR. CMBUFZ(J).EQ.'U') THEN CMBUFZ(J-2) = ' ' GO TO 130 ENDIF 120 CONTINUE ENDIF C 130 WRITE (FORM,140) KSWIDE-7 140 FORMAT(' (6X,',I3,'A1) ') WRITE (KW,FORM) (CMBUFZ(K),K=1,LAST) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMI2M(INTEG,MA) C C MA = INTEG C C The real part of MA is set to the one word integer value INTEG. C The imaginary part is set to zero. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER INTEG DOUBLE PRECISION MA(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMI2M ' IF (NTRACE.NE.0) CALL ZMNTRI(2,INTEG,1) C CALL FMI2M(INTEG,MA) CALL FMI2M(0,MA(KPTIMU)) C IF (NTRACE.NE.0) CALL ZMNTR(1,MA,MA,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZM2I2M(INTEG1,INTEG2,MA) C C MA = INTEG1 + INTEG2 i C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER INTEG1,INTEG2 DOUBLE PRECISION MA(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C NCALL = NCALL + 1 NAMEST(NCALL) = 'ZM2I2M' IF (NTRACE.NE.0) THEN CALL ZMNTRI(2,INTEG1,1) CALL ZMNTRI(2,INTEG2,0) ENDIF C CALL FMI2M(INTEG1,MA) CALL FMI2M(INTEG2,MA(KPTIMU)) C IF (NTRACE.NE.0) CALL ZMNTR(1,MA,MA,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMIMAG(MA,MBFM) C C MBFM = IMAG(MA) imaginary part of MA C C MA is a complex ZM number, MBFM is a real FM number. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MBFM(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMIMAG' IF (NTRACE.NE.0) CALL ZMNTR(2,MA,MA,1) C CALL FMEQ(MA(KPTIMU),MBFM) C IF (NTRACE.NE.0) CALL FMNTR(1,MBFM,MBFM,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMINP(LINE,MA,LA,LB) C C Convert an A1 character string to floating point multiple precision C complex format. C C LINE is an A1 character array of length LB to be converted C to ZM format and returned in MA. C LA is a pointer telling the routine where in the array to begin C the conversion. This allows more than one number to be stored C in an array and converted in place. C LB is a pointer to the last character of the field for that number. C C The input numbers may be in integer or any real format. C In exponential format the 'E' may also be 'D', 'Q', or 'M'. C C The following are all valid input strings: C C 1.23 + 4.56 I C 1.23 + 4.56*I C 2 + i C -i C 1.23 C 4.56i C ( 1.23 , 4.56 ) C C So that ZMINP will convert any output from ZMOUT, LINE is tested C to see if the input contains any of the special symbols +OVERFLOW, C -OVERFLOW, +UNDERFLOW, -UNDERFLOW, or UNKNOWN. C For user input the abbreviations OVFL, UNFL, UNKN may be used. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER LA,LB CHARACTER LINE(LB) DOUBLE PRECISION MA(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C C Scratch array usage during ZMINP: M01 - M05 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER JTRANS(16,4),J,JSTATE,K,KASAVE,KDIGFL,KFLAG1,KIFLAG,KPT, * KRSAVE,KSIGN,KSTART,KSTOP,KSTOPI,KSTOPR,KSTRTI,KSTRTR, * KTYPE,KVAL,NDSAVE,NTRSAV C C Simulate a finite-state automaton to scan the input line C and build the number. States 2-8 refer to the real part, C states 10-16 refer to the imaginary part. C States of the machine: C C 1. Initial entry to the subroutine C 2. Sign of the number C 3. Scanning digits before a decimal point C 4. Decimal point C 5. Scanning digits after a decimal point C 6. E, D, Q, or M - precision indicator before the exponent C 7. Sign of the exponent C 8. Scanning exponent C 9. Comma between the real and imaginary part C 10. Sign of the number C 11. Scanning digits before a decimal point C 12. Decimal point C 13. Scanning digits after a decimal point C 14. E, D, Q, or M - precision indicator before the exponent C 15. Sign of the exponent C 16. Scanning exponent C 17. Syntax error C C Character types recognized by the machine: C C 1. Sign (+,-) C 2. Numeral (0,1,...,9) C 3. Decimal point (.) C 4. Precision indicator (E,D,Q,M) C 5. Illegal character for number C 6. Comma (,) C 7. Character to be ignored ' ' '(' ')' '*' C C All blanks are ignored. The analysis of the number proceeds as C follows: If the simulated machine is in state JSTATE and a character C of type JTYPE is encountered the new state of the machine is given by C JTRANS(JSTATE,JTYPE). C C State 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 C DATA JTRANS/ S 2, 17, 10, 10, 10, 7, 17, 10, 10, 17, 17, 17, 17, 15, 17, 17, N 3, 3, 3, 5, 5, 8, 8, 8, 11, 11, 11, 13, 13, 16, 16, 16, D 4, 4, 4, 17, 17, 17, 17, 17, 12, 12, 12, 17, 17, 17, 17, 17, P 6, 6, 6, 6, 6, 8, 17, 17, 14, 14, 14, 14, 14, 16, 17, 17/ C IF (MBLOGS.NE.MBASE) CALL FMCONS NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMINP ' NDSAVE = NDIG KASAVE = KACCSW KRSAVE = KROUND KROUND = 1 KFLAG = 0 C C Since arithmetic tracing is not usually desired during C I/O conversion, disable tracing during this routine. C NTRSAV = NTRACE NTRACE = 0 C C Increase the working precision. C IF (NCALL.LE.2) THEN K = NGRD52 NDIG = MAX(NDIG+K,2) IF (NDIG.GT.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 110 J = 2, NDSAVE MA(J+1) = 0 MA(KPTIMU+J+1) = 0 110 CONTINUE GO TO 140 ENDIF ENDIF KSTART = LA KSTOP = LB JSTATE = 1 KSTRTR = 0 KSTOPR = 0 KSTRTI = 0 KSTOPI = 0 KDIGFL = 0 KIFLAG = 0 KSIGN = 1 C C Scan the number. C DO 130 J = KSTART, KSTOP IF (LINE(J).EQ.' ' .OR. LINE(J).EQ.'(' .OR. LINE(J).EQ.')' * .OR. LINE(J).EQ.'*') GO TO 130 IF (LINE(J).EQ.'I' .OR. LINE(J).EQ.'i') THEN KIFLAG = 1 IF (KSTRTI.EQ.0) THEN KSTRTI = KSTRTR KSTOPI = KSTOPR KSTRTR = 0 KSTOPR = 0 ENDIF GO TO 130 ENDIF C KPT = ICHAR(LINE(J)) IF (KPT.LT.LHASH1 .OR. KPT.GT.LHASH2) THEN WRITE (KW,120) LINE(J),KPT,LHASH1,LHASH2 120 FORMAT(/' Error in input conversion.'/ * ' ICHAR function was out of range for the current', * ' dimensions.'/' ICHAR(''',A,''') gave the value ', * I12,', which is outside the currently'/' dimensioned', * ' bounds of (',I5,':',I5,') for variables KHASHT ', * 'and KHASHV.'/' Re-define the two parameters ', * 'LHASH1 and LHASH2 so the dimensions will'/' contain', * ' all possible output values from ICHAR.'//) KTYPE = 5 KVAL = 0 ELSE KTYPE = KHASHT(KPT) KVAL = KHASHV(KPT) ENDIF IF (KTYPE.EQ.2 .OR. KTYPE.EQ.5) KDIGFL = 1 IF (LINE(J).EQ.',') THEN IF (JSTATE.LT.9) THEN JSTATE = 9 ELSE GO TO 150 ENDIF ELSE IF (KTYPE.GE.5) KTYPE = 2 IF (JSTATE.LT.17) JSTATE = JTRANS(JSTATE,KTYPE) ENDIF IF (JSTATE.EQ.9 .OR. JSTATE.EQ.10) KDIGFL = 0 IF (JSTATE.EQ.2 .OR. JSTATE.EQ.10) KSIGN = KVAL C IF (JSTATE.GE.2 .AND. JSTATE.LE.8) THEN IF (KSTRTR.EQ.0) KSTRTR = J KSTOPR = J ENDIF IF (JSTATE.GE.10 .AND. JSTATE.LE.16) THEN IF (KSTRTI.EQ.0) KSTRTI = J KSTOPI = J ENDIF C 130 CONTINUE C C Form the number and return. C IF (KSTRTR.GT.0) THEN CALL FMINP(LINE,MA,KSTRTR,KSTOPR) ELSE CALL FMIM(0,MA) ENDIF KFLAG1 = KFLAG C IF (KSTRTI.GT.0) THEN IF (KIFLAG.EQ.1 .AND. KDIGFL.EQ.0) THEN CALL FMIM(KSIGN,MA(KPTIMU)) ELSE CALL FMINP(LINE,MA(KPTIMU),KSTRTI,KSTOPI) ENDIF ELSE IF (KIFLAG.EQ.1) THEN CALL FMIM(1,MA(KPTIMU)) ELSE CALL FMIM(0,MA(KPTIMU)) ENDIF C IF (KFLAG1.NE.0 .OR. KFLAG.NE.0 .OR. JSTATE.EQ.17) GO TO 150 C 140 NDIG = NDSAVE KACCSW = KASAVE NTRACE = NTRSAV KROUND = KRSAVE IF (KFLAG.EQ.1) KFLAG = 0 MA(0) = NINT(NDIG*ALOGM2) MA(KPTIMU) = MA(0) NCALL = NCALL - 1 RETURN C C Error in converting the number. C 150 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 160 J = 2, NDSAVE MA(J+1) = 0 MA(KPTIMU+J+1) = 0 160 CONTINUE GO TO 140 END SUBROUTINE ZMINT(MA,MB) C C MB = INT(MA) C C The integer parts of both real and imaginary values are returned. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMINT ' IF (NTRACE.NE.0) CALL ZMNTR(2,MA,MA,1) C CALL FMINT(MA,MB) CALL FMINT(MA(KPTIMU),MB(KPTIMU)) C IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMIPWR(MA,IVAL,MB) C C MB = MA ** IVAL C C Raise a ZM number to an integer power. C The binary multiplication method used requires an average of C 1.5 * LOG2(IVAL) multiplications. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER IVAL DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMIPWR: M01 - M03, MZ01 - MZ02 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MA2,MACCMB,MAIZ,MARZ,MXSAVE INTEGER I2N,J,K,KASAVE,KOVUN,KWRNSV,LVLSAV,NDSAVE REAL XVAL C NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMIPWR' NDSAVE = NDIG IF (NTRACE.NE.0) THEN CALL ZMNTR(2,MA,MA,1) CALL FMNTRI(2,IVAL,0) ENDIF KOVUN = 0 MARZ = MA(0) MAIZ = MA(KPTIMU) IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN .OR. * MA(KPTIMU+1).EQ.MEXPOV .OR. MA(KPTIMU+1).EQ.MEXPUN) KOVUN = 1 C IF (MBLOGS.NE.MBASE) CALL FMCONS KFLAG = 0 KASAVE = KACCSW MXSAVE = MXEXP MXEXP = MXEXP2 C C Check for special cases. C IF (MA(1).EQ.MUNKNO .OR. MA(KPTIMU+1).EQ.MUNKNO .OR. * (IVAL.LE.0 .AND. MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.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 110 J = 2, NDSAVE MB(J+1) = 0 MB(KPTIMU+J+1) = 0 110 CONTINUE KFLAG = -4 IF (IVAL.LE.0 .AND. MA2.EQ.0) CALL ZMWARN IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 MXEXP = MXSAVE RETURN ENDIF C IF (IVAL.EQ.0) THEN CALL ZMI2M(1,MB) IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 MXEXP = MXSAVE RETURN ENDIF C IF (ABS(IVAL).EQ.1) THEN KWRNSV = KWARN KWARN = 0 IF (IVAL.EQ.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 ENDIF IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 KWARN = KWRNSV MXEXP = MXSAVE RETURN ENDIF C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN CALL ZMI2M(0,MB) IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 MXEXP = MXSAVE RETURN ENDIF C IF (MA(KPTIMU+2).EQ.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.NE.0) THEN NAMEST(NCALL) = 'ZMIPWR' CALL ZMNTR(1,MB,MB,1) ENDIF NCALL = NCALL - 1 MXEXP = MXSAVE RETURN ENDIF C IF (MA(2).EQ.0) THEN NCALL = NCALL - 1 LVLSAV = LVLTRC LVLTRC = LVLTRC - 1 IF (IVAL.GE.0) THEN I2N = MOD(IVAL,4) ELSE I2N = MOD(4 - MOD(ABS(IVAL),4),4) ENDIF IF (I2N.EQ.0) THEN CALL FMIPWR(MA(KPTIMU),IVAL,MB) CALL FMIM(0,MB(KPTIMU)) ELSE IF (I2N.EQ.1) THEN CALL FMIPWR(MA(KPTIMU),IVAL,MB(KPTIMU)) CALL FMIM(0,MB) ELSE IF (I2N.EQ.2) THEN CALL FMIPWR(MA(KPTIMU),IVAL,MB) CALL FMIM(0,MB(KPTIMU)) IF (MB(1).NE.MUNKNO) MB(2) = -MB(2) ELSE IF (I2N.EQ.3) THEN CALL FMIPWR(MA(KPTIMU),IVAL,MB(KPTIMU)) CALL FMIM(0,MB) IF (MB(KPTIMU+1).NE.MUNKNO) MB(KPTIMU+2) = -MB(KPTIMU+2) ENDIF NCALL = NCALL + 1 LVLTRC = LVLSAV IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'ZMIPWR' CALL ZMNTR(1,MB,MB,1) ENDIF NCALL = NCALL - 1 MXEXP = MXSAVE RETURN ENDIF C C Increase the working precision. C IF (NCALL.EQ.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 ENDIF IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL ZMWARN MB(1) = MUNKNO MB(2) = 1 MB(KPTIMU+1) = MUNKNO MB(KPTIMU+2) = 1 DO 120 J = 2, NDSAVE MB(J+1) = 0 MB(KPTIMU+J+1) = 0 120 CONTINUE NDIG = NDSAVE MB(0) = NINT(NDIG*ALOGM2) MB(KPTIMU) = NINT(NDIG*ALOGM2) NDIG = NDSAVE IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) MXEXP = MXSAVE KACCSW = KASAVE NCALL = NCALL - 1 RETURN ENDIF C C Initialize. C KWRNSV = KWARN KWARN = 0 K = ABS(IVAL) C CALL ZMEQ2(MA,MZ02,NDSAVE,NDIG,0) C IF (MOD(K,2).EQ.0) THEN CALL ZMI2M(1,MB) ELSE CALL ZMEQ(MZ02,MB) ENDIF C C This is the multiplication loop. C 130 K = K/2 CALL ZMSQR(MZ02,MZ02) IF (MOD(K,2).EQ.1) CALL ZMMPY(MZ02,MB,MB) IF (K.GT.1) GO TO 130 C C Invert if the exponent is negative. C IF (IVAL.LT.0) THEN CALL ZMI2M(1,MZ02) CALL ZMDIV(MZ02,MB,MB) ENDIF KWARN = KWRNSV C C Round the result and return. C 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 ZMLG10(MA,MB) C C MB = LOG10(MA). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMLG10: M01 - M05, MZ01 - MZ02 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE C CALL ZMENTR('ZMLG10',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN MARZ = MA(0) MAIZ = MA(KPTIMU) KACCSW = 0 KRSAVE = KRAD KRAD = 1 C CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) CALL ZMLN(MA,MZ02) CALL FMLNI(10,M03) CALL FMDIVD(MZ02,MZ02(KPTIMU),M03,MZ01,MZ01(KPTIMU)) C 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(MA,MB) C C MB = LN(MA). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMLN: M01 - M05, MZ01 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE INTEGER J,KASAVE,KF1,KOVUN,KRESLT,KRSAVE,NDSAVE LOGICAL FMCOMP C CALL ZMENTR('ZMLN ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN MARZ = MA(0) MAIZ = MA(KPTIMU) KACCSW = 0 KRSAVE = KRAD KRAD = 1 C CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C C Check for special cases. C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN KFLAG = -4 MZ01(1) = MUNKNO MZ01(2) = 1 MZ01(KPTIMU+1) = MUNKNO MZ01(KPTIMU+2) = 1 DO 110 J = 2, NDSAVE MZ01(J+1) = 0 MZ01(KPTIMU+J+1) = 0 110 CONTINUE MZ01(0) = NINT(NDIG*ALOGM2) MZ01(KPTIMU) = NINT(NDIG*ALOGM2) GO TO 120 ELSE IF (MA(KPTIMU+2).EQ.0) THEN IF (MA(2).LT.0) THEN CALL FMEQ(MA,MZ01) IF (MZ01(1).NE.MUNKNO) MZ01(2) = -MZ01(2) CALL FMLN(MZ01,MZ01) CALL FMPI(MZ01(KPTIMU)) ELSE CALL FMLN(MA,MZ01) CALL FMI2M(0,MZ01(KPTIMU)) ENDIF GO TO 120 ELSE IF (MA(2).EQ.0) THEN IF (MA(KPTIMU+2).LT.0) THEN CALL FMEQ(MA(KPTIMU),MZ01) IF (MZ01(1).NE.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)) ENDIF GO TO 120 ENDIF C C Ln(a + b i) = Ln(Abs(a + b i)) + Arg(a + b i) i. C CALL FMABS(MA,M03) CALL FMABS(MA(KPTIMU),M04) C C Check for cancellation in Ln(x). C CALL FMI2M(1,M05) KF1 = 0 IF (FMCOMP(M03,'EQ',M05) .AND. M04(1).LE.(-NDIG)) KF1 = 1 IF (FMCOMP(M04,'EQ',M05) .AND. M03(1).LE.(-NDIG)) KF1 = 1 C 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) ENDIF CALL ZMABS(MA,MZ01) CALL FMADD(MZ01,M05,M03) CALL FMDIV(M04,M03,M03) IF (KF1.EQ.1) THEN CALL FMEQ(M03,MZ01) CALL FMATN2(MA(KPTIMU),MA,MZ01(KPTIMU)) GO TO 120 ELSE IF (M03(1).LT.0) THEN NDIG = NDIG - INT(M03(1)) IF (NDIG.GT.NDG2MX) THEN NAMEST(NCALL) = 'ZMLN ' KFLAG = -9 CALL ZMWARN KRESLT = 12 NDIG = NDSAVE CALL ZMRSLT(MB,KRESLT) IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 MXEXP = MXSAVE KACCSW = KASAVE RETURN ENDIF CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) CALL ZMABS(MA,MZ01) ENDIF C CALL FMLN(MZ01,MZ01) CALL FMATN2(MA(KPTIMU),MA,MZ01(KPTIMU)) C 120 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 ZMM2I(MA,INTEG) C C INTEG = MA C C INTEG is set to the integer value of the real part of MA C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ) INTEGER INTEG C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMM2I ' IF (NTRACE.NE.0) CALL ZMNTR(2,MA,MA,1) C CALL FMM2I(MA,INTEG) C IF (NTRACE.NE.0) CALL ZMNTRI(1,INTEG,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMM2Z(MA,ZVAL) C C ZVAL = MA C C Complex variable ZVAL is set to MA. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ) COMPLEX ZVAL C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C REAL DI,DR C NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMM2Z ' IF (NTRACE.NE.0) CALL ZMNTR(2,MA,MA,1) C CALL FMM2SP(MA,DR) CALL FMM2SP(MA(KPTIMU),DI) ZVAL = CMPLX(DR,DI) C IF (NTRACE.NE.0) CALL ZMNTRZ(1,ZVAL,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMMPY(MA,MB,MC) C C MC = MA * MB C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMMPY: M01 - M03, MZ01 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MBIZ,MBRZ,MXSAVE,MZERO,MZ11SV INTEGER IEXTRA,J,KASAVE,KMETHD,KOVUN,KRESLT,KWRNSV,NDGSV2,NDSAVE, * NGOAL,NTRSAV C IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MA(KPTIMU+1)).GT.MEXPAB .OR. * ABS(MB(1)).GT.MEXPAB .OR. ABS(MB(KPTIMU+1)).GT.MEXPAB .OR. * KDEBUG.GE.1) THEN CALL ZMENTR('ZMMPY ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'ZMMPY ' CALL ZMNTR(2,MA,MB,2) ENDIF NDSAVE = NDIG IF (NCALL.EQ.1) THEN NDIG = MAX(NDIG+NGRD52,2) IF (NDIG.GT.NDG2MX) THEN NAMEST(NCALL) = 'ZMMPY ' KFLAG = -9 CALL ZMWARN KRESLT = 12 NDIG = NDSAVE CALL ZMRSLT(MC,KRESLT) IF (NTRACE.NE.0) CALL ZMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN ENDIF IF (MBASE.GE.100*ABS(MA(2)) .OR. * MBASE.GE.100*ABS(MA(KPTIMU+2))) THEN NDIG = MIN(NDIG+1,NDG2MX) ELSE IF (MBASE.GE.100*ABS(MB(2)) .OR. * MBASE.GE.100*ABS(MB(KPTIMU+2))) THEN NDIG = MIN(NDIG+1,NDG2MX) ENDIF ENDIF KASAVE = KACCSW KACCSW = 1 MXSAVE = MXEXP MXEXP = MXEXP2 KOVUN = 0 ENDIF C MARZ = MA(0) MBRZ = MB(0) MAIZ = MA(KPTIMU) MBIZ = MB(KPTIMU) MZ11SV = -MUNKNO MZERO = 0 NTRSAV = NTRACE NTRACE = 0 KWRNSV = KWARN KWARN = 0 C 110 DO 120 J = NDSAVE+2, NDIG+1 MA(J) = MZERO MB(J) = MZERO MA(KPTIMU+J) = MZERO MB(KPTIMU+J) = MZERO 120 CONTINUE IF (NCALL.EQ.1) THEN MA(0) = NINT(NDIG*ALOGM2) MB(0) = MA(0) MA(KPTIMU) = MA(0) MB(KPTIMU) = MA(0) ENDIF C C Check for special cases. C KMETHD = 1 IF (NDIG.GE.35) KMETHD = 2 C IF (MB(KPTIMU+2).EQ.0) THEN CALL FMMPYD(MB,MA,MA(KPTIMU),MZ01,MZ01(KPTIMU)) ELSE IF (MB(2).EQ.0) THEN CALL FMMPYD(MB(KPTIMU),MA(KPTIMU),MA,MZ01,MZ01(KPTIMU)) IF (MZ01(1).NE.MUNKNO) MZ01(2) = -MZ01(2) ELSE IF (MA(KPTIMU+2).EQ.0) THEN CALL FMMPYD(MA,MB,MB(KPTIMU),MZ01,MZ01(KPTIMU)) ELSE IF (MA(2).EQ.0) THEN CALL FMMPYD(MA(KPTIMU),MB(KPTIMU),MB,MZ01,MZ01(KPTIMU)) IF (MZ01(1).NE.MUNKNO) MZ01(2) = -MZ01(2) ELSE IF (KMETHD.EQ.1) THEN C C Method 1 for ( a + b i ) * ( c + d i ) C C result = a*c - b*d + ( a*d + b*c ) i C 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).LT.0) THEN KACCSW = 0 ELSE KACCSW = 1 ENDIF CALL FMSUB(MZ01,M01,MZ01) IF (MZ01(KPTIMU+2)*M02(2).LT.0) THEN KACCSW = 1 ELSE KACCSW = 0 ENDIF CALL FMADD(MZ01(KPTIMU),M02,MZ01(KPTIMU)) KACCSW = 1 ELSE C C Method 2 for ( a + b i ) * ( c + d i ) C C P = ( a + b )*( c + d ) C result = a*c - b*d + ( P - a*c - b*d ) i C CALL FMADD(MA,MA(KPTIMU),M01) CALL FMADD(MB,MB(KPTIMU),M02) CALL FMMPY(M01,M02,M01) C CALL FMMPY(MA,MB,M02) CALL FMMPY(MA(KPTIMU),MB(KPTIMU),M03) C CALL FMSUB(M02,M03,MZ01) CALL FMSUB(M01,M02,MZ01(KPTIMU)) CALL FMSUB(MZ01(KPTIMU),M03,MZ01(KPTIMU)) ENDIF C C Check for too much cancellation. C IF (NCALL.LE.1) THEN NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7 ELSE NGOAL = INT(-MXEXP2) ENDIF IF (MZ01(0).LE.NGOAL .OR. MZ01(KPTIMU).LE.NGOAL) THEN IF (MZ11SV.GT.-MUNKNO .AND. MZ01(0).GT.NGOAL .AND. * MZ01(KPTIMU+2).EQ.0) GO TO 140 IF (MZ11SV.GT.-MUNKNO .AND. MZ01(KPTIMU).GT.NGOAL .AND. * MZ01(2).EQ.0) GO TO 140 IEXTRA = INT(REAL(MAX(NGOAL-MZ01(0),NGOAL-MZ01(KPTIMU))) * /ALOGM2 + 23.03/ALOGMB) + 1 NDIG = NDIG + IEXTRA IF (NDIG.GT.NDG2MX) THEN NAMEST(NCALL) = 'ZMMPY ' KFLAG = -9 CALL ZMWARN MZ01(1) = MUNKNO MZ01(2) = 1 MZ01(KPTIMU+1) = MUNKNO MZ01(KPTIMU+2) = 1 DO 130 J = 2, NDSAVE MZ01(J+1) = 0 MZ01(KPTIMU+J+1) = 0 130 CONTINUE NDIG = NDIG - IEXTRA MZ01(0) = NINT(NDIG*ALOGM2) MZ01(KPTIMU) = NINT(NDIG*ALOGM2) GO TO 140 ENDIF MZ11SV = MZ01(1) GO TO 110 ENDIF C 140 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).GE.MEXPOV .OR. MC(1).LE.-MEXPOV .OR. * MC(KPTIMU+1).GE.MEXPOV .OR. MC(KPTIMU+1).LE.-MEXPOV) THEN IF (MC(1).EQ.MUNKNO .OR. MC(KPTIMU+1).EQ.MUNKNO) THEN KFLAG = -4 ELSE IF (MC(1).EQ.MEXPOV .OR. MC(KPTIMU+1).EQ.MEXPOV) THEN KFLAG = -5 ELSE IF (MC(1).EQ.MEXPUN .OR. MC(KPTIMU+1).EQ.MEXPUN) THEN KFLAG = -6 ENDIF IF ((MC(1).EQ.MUNKNO) * .OR. (MC(KPTIMU+1).EQ.MUNKNO) * .OR. (MC(1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MC(KPTIMU+1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MC(1).EQ.MEXPOV .AND. KOVUN.EQ.0) * .OR. (MC(KPTIMU+1).EQ.MEXPOV .AND. KOVUN.EQ.0)) THEN NAMEST(NCALL) = 'ZMMPY ' CALL ZMWARN ENDIF ENDIF IF (NTRACE.NE.0) CALL ZMNTR(1,MC,MC,1) KACCSW = KASAVE NCALL = NCALL - 1 RETURN END SUBROUTINE ZMMPYI(MA,INTEG,MB) C C MB = MA * INTEG Multiply by one-word (real) integer. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) INTEGER INTEG C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV DOUBLE PRECISION MXSAVE C IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MA(KPTIMU+1)).GT.MEXPAB .OR. * KDEBUG.GE.1) THEN CALL ZMENTR('ZMMPYI',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN NDIG = NDSAVE MXEXP = MXSAVE KACCSW = KASAVE NTRSAV = NTRACE ELSE NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'ZMMPYI' CALL ZMNTR(2,MA,MA,1) CALL FMNTRI(2,INTEG,0) ENDIF KOVUN = 0 ENDIF C C Force FMMPYI to use more guard digits for user calls. C NCALL = NCALL - 1 NTRSAV = NTRACE NTRACE = 0 KWRNSV = KWARN KWARN = 0 C CALL FMMPYI(MA,INTEG,MB) CALL FMMPYI(MA(KPTIMU),INTEG,MB(KPTIMU)) C NTRACE = NTRSAV KWARN = KWRNSV NCALL = NCALL + 1 IF (NTRACE.NE.0) NAMEST(NCALL) = 'ZMMPYI' IF (MB(1).EQ.MUNKNO .OR. MB(KPTIMU+1).EQ.MUNKNO) THEN KFLAG = -4 ELSE IF (MB(1).EQ.MEXPOV .OR. MB(KPTIMU+1).EQ.MEXPOV) THEN KFLAG = -5 ELSE IF (MB(1).EQ.MEXPUN .OR. MB(KPTIMU+1).EQ.MEXPUN) THEN KFLAG = -6 ENDIF IF ((MB(1).EQ.MUNKNO) * .OR. (MB(KPTIMU+1).EQ.MUNKNO) * .OR. (MB(1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MB(KPTIMU+1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MB(1).EQ.MEXPOV .AND. KOVUN.EQ.0) * .OR. (MB(KPTIMU+1).EQ.MEXPOV .AND. KOVUN.EQ.0)) THEN NAMEST(NCALL) = 'ZMMPYI' CALL ZMWARN ENDIF IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMNINT(MA,MB) C C MB = NINT(MA) C C The nearest integers to both real and imaginary parts are returned. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMNINT' IF (NTRACE.NE.0) CALL ZMNTR(2,MA,MA,1) C CALL FMNINT(MA,MB) CALL FMNINT(MA(KPTIMU),MB(KPTIMU)) C IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMNTR(NTR,MA,MB,NARG) C C Print ZM numbers in base 10 format using ZMOUT for conversion. C This is used for trace output from the ZM routines. C C NTR = 1 if a result of an ZM call is to be printed. C = 2 to print input argument(s) to an ZM call. C C MA - the ZM number to be printed. C C MB - an optional second ZM number to be printed. C C NARG - the number of arguments. NARG = 1 if only MA is to be C printed, and NARG = 2 if both MA and MB are to be printed. C C C NTRACE and LVLTRC (in COMMON /FMUSER/) control trace printout. C C NTRACE = 0 No printout except warnings and errors. C C NTRACE = 1 The result of each call to one of the routines C is printed in base 10, using ZMOUT. C C NTRACE = -1 The result of each call to one of the routines C is printed in internal base MBASE format. C C NTRACE = 2 The input arguments and result of each call to one C of the routines is printed in base 10, using ZMOUT. C C NTRACE = -2 The input arguments and result of each call to one C of the routines is printed in base MBASE format. C C LVLTRC defines the call level to which the trace is done. LVLTRC = 1 C means only FM routines called directly by the user are traced, C LVLTRC = K prints traces for ZM or FM routines with call C levels up to and including level K. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) INTEGER NTR,NARG C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C CHARACTER *6 NAME C IF (NTRACE.EQ.0) RETURN IF (NCALL.GT.LVLTRC) RETURN IF (NTR.EQ.2 .AND. ABS(NTRACE).EQ.1) RETURN C IF (NTR.EQ.2) THEN NAME = NAMEST(NCALL) WRITE (KW,110) NAME 110 FORMAT(' Input to ',A6) ELSE NAME = NAMEST(NCALL) IF (KFLAG.EQ.0) THEN WRITE (KW,120) NAME,NCALL,INT(MBASE),NDIG 120 FORMAT(' ',A6,15X,'Call level =',I2,5X,'MBASE =', * I10,5X,'NDIG =',I6) ELSE WRITE (KW,130) NAME,NCALL,INT(MBASE),NDIG,KFLAG 130 FORMAT(' ',A6,6X,'Call level =',I2,4X,'MBASE =', * I10,4X,'NDIG =',I6,4X,'KFLAG =',I3) ENDIF ENDIF C C Check for base MBASE internal format trace. C IF (NTRACE.LT.0) THEN CALL ZMNTRJ(MA,NDIG) IF (NARG.EQ.2) CALL ZMNTRJ(MB,NDIG) ENDIF C C Check for base 10 trace using ZMOUT. C IF (NTRACE.GT.0) THEN CALL ZMPRNT(MA) C IF (NARG.EQ.2) THEN CALL ZMPRNT(MB) ENDIF ENDIF C RETURN END SUBROUTINE ZMNTR2(NTR,MAFM,MBFM,NARG) C C Print real FM numbers in base 10 format using FMOUT for conversion. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MAFM(0:LUNPCK),MBFM(0:LUNPCK) INTEGER NTR,NARG C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C CHARACTER *6 NAME C IF (NTRACE.EQ.0) RETURN IF (NCALL.GT.LVLTRC) RETURN IF (NTR.EQ.2 .AND. ABS(NTRACE).EQ.1) RETURN C IF (NTR.EQ.2) THEN NAME = NAMEST(NCALL) WRITE (KW,110) NAME 110 FORMAT(' Input to ',A6) ELSE NAME = NAMEST(NCALL) IF (KFLAG.EQ.0) THEN WRITE (KW,120) NAME,NCALL,INT(MBASE),NDIG 120 FORMAT(' ',A6,15X,'Call level =',I2,5X,'MBASE =', * I10,5X,'NDIG =',I6) ELSE WRITE (KW,130) NAME,NCALL,INT(MBASE),NDIG,KFLAG 130 FORMAT(' ',A6,6X,'Call level =',I2,4X,'MBASE =', * I10,4X,'NDIG =',I6,4X,'KFLAG =',I3) ENDIF ENDIF C C Check for base MBASE internal format trace. C IF (NTRACE.LT.0) THEN CALL FMNTRJ(MAFM,NDIG) IF (NARG.EQ.2) CALL FMNTRJ(MBFM,NDIG) ENDIF C C Check for base 10 trace using FMOUT. C IF (NTRACE.GT.0) THEN CALL FMPRNT(MAFM) C IF (NARG.EQ.2) THEN CALL FMPRNT(MBFM) ENDIF ENDIF C RETURN END SUBROUTINE ZMNTRI(NTR,N,KNAM) C C Internal routine for trace output of integer variables. C C NTR = 1 for output values C 2 for input values C C N Integer to be printed. C C KNAM is positive if the routine name is to be printed. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER NTR,N,KNAM C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C CHARACTER *6 NAME C IF (NTRACE.EQ.0) RETURN IF (NCALL.GT.LVLTRC) RETURN IF (NTR.EQ.2 .AND. ABS(NTRACE).EQ.1) RETURN C IF (NTR.EQ.2 .AND. KNAM.GT.0) THEN NAME = NAMEST(NCALL) WRITE (KW,110) NAME 110 FORMAT(' Input to ',A6) ENDIF IF (NTR.EQ.1 .AND. KNAM.GT.0) THEN NAME = NAMEST(NCALL) IF (KFLAG.EQ.0) THEN WRITE (KW,120) NAME,NCALL,INT(MBASE),NDIG 120 FORMAT(' ',A6,15X,'Call level =',I2,5X,'MBASE =', * I10,5X,'NDIG =',I6) ELSE WRITE (KW,130) NAME,NCALL,INT(MBASE),NDIG,KFLAG 130 FORMAT(' ',A6,6X,'Call level =',I2,4X,'MBASE =', * I10,4X,'NDIG =',I6,4X,'KFLAG =',I3) ENDIF ENDIF C WRITE (KW,140) N 140 FORMAT(1X,I18) C RETURN END SUBROUTINE ZMNTRJ(MA,ND) C C Print trace output in internal base MBASE format. The number to C be printed is in MA. C C ND is the number of base MBASE digits to be printed. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ) INTEGER ND C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER *50 FORM INTEGER J,L,N,N1 C N1 = ND + 1 C L = INT(LOG10(DBLE(MBASE-1))) + 2 N = (KSWIDE-23)/L IF (N.GT.10) N = 5*(N/5) IF (ND.LE.N) THEN WRITE (FORM,110) L+2, N-1, L 110 FORMAT(' (1X,I19,I',I2,',',I3,'I',I2,') ') ELSE WRITE (FORM,120) L+2, N-1, L, N, L 120 FORMAT(' (1X,I19,I',I2,',',I3,'I',I2, * '/(22X,',I3,'I',I2,')) ') ENDIF WRITE (KW,FORM) (INT(MA(J)),J=1,N1) WRITE (KW,FORM) (INT(MA(J+KPTIMU)),J=1,N1) C RETURN END SUBROUTINE ZMNTRZ(NTR,X,KNAM) C C Internal routine for trace output of complex variables. C C NTR - 1 for output values C 2 for input values C C X - Complex value to be printed if NX.EQ.1 C C KNAM - Positive if the routine name is to be printed. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER NTR,KNAM COMPLEX X C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C CHARACTER *6 NAME DOUBLE PRECISION XREAL,XIMAG C IF (NTRACE.EQ.0) RETURN IF (NCALL.GT.LVLTRC) RETURN IF (NTR.EQ.2 .AND. ABS(NTRACE).EQ.1) RETURN C IF (NTR.EQ.2 .AND. KNAM.GT.0) THEN NAME = NAMEST(NCALL) WRITE (KW,110) NAME 110 FORMAT(' Input to ',A6) ENDIF IF (NTR.EQ.1 .AND. KNAM.GT.0) THEN NAME = NAMEST(NCALL) IF (KFLAG.EQ.0) THEN WRITE (KW,120) NAME,NCALL,INT(MBASE),NDIG 120 FORMAT(' ',A6,15X,'Call level =',I2,5X,'MBASE =', * I10,5X,'NDIG =',I6) ELSE WRITE (KW,130) NAME,NCALL,INT(MBASE),NDIG,KFLAG 130 FORMAT(' ',A6,6X,'Call level =',I2,4X,'MBASE =', * I10,4X,'NDIG =',I6,4X,'KFLAG =',I3) ENDIF ENDIF C XREAL = DBLE(X) XIMAG = DBLE(AIMAG(X)) IF (XIMAG.GE.0.0D0) THEN WRITE (KW,140) XREAL,XIMAG 140 FORMAT(1X,D30.20,' +',D30.20,' i') ELSE WRITE (KW,150) XREAL,ABS(XIMAG) 150 FORMAT(1X,D30.20,' -',D30.20,' i') ENDIF C RETURN END SUBROUTINE ZMOUT(MA,LINE,LB,LAST1,LAST2) C C Convert a floating multiple precision number to a character array C for output. C C MA is an ZM number to be converted to an A1 character C array in base 10 format C LINE is the CHARACTER*1 array in which the result is returned. C LB is the length of LINE. C LAST1 is the position of the last nonblank character of the C real part of the number in LINE. C LAST2 is the position of the last nonblank character of the C imaginary part of the number in LINE. C C JFORM1 and JFORM2 determine the format of the two FM numbers C making up the complex value MA. See FMOUT for details. C C JFORMZ determines the format of the real and imaginary parts. C C JFORMZ = 1 normal setting : 1.23 - 4.56 i C = 2 use capital I : 1.23 - 4.56 I C = 3 parenthesis format ( 1.23 , -4.56 ) C C LINE should be dimensioned at least 4*(LOG10(MBASE)*NDIG + 15) on a C 32-bit machine to allow for up to 10 digit exponents. Replace C 15 by 20 if 48-bit integers are used, 25 for 64-bit integers, etc. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ) INTEGER LB,LAST1,LAST2 CHARACTER LINE(LB) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER JFORMZ,JPRNTZ C COMMON /ZMUSER/ JFORMZ,JPRNTZ C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MAIM2 INTEGER J,KPT,LB2,ND,NEXP C NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMOUT ' DO 110 J = 1, LB LINE(J) = ' ' 110 CONTINUE ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1 IF (ND.LT.2) ND = 2 NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6 KPT = 1 IF (JFORMZ.EQ.3) KPT = 3 LB2 = MAX(JFORM2+NEXP,ND+NEXP) LB2 = MIN(LB+1-KPT,LB2) CALL FMOUT(MA,LINE(KPT),LB2) C IF (JFORMZ.EQ.3) LINE(1) = '(' LAST1 = 1 DO 120 J = LB2, 1, -1 IF (LINE(J).NE.' ') THEN LAST1 = J GO TO 130 ENDIF 120 CONTINUE C 130 MAIM2 = MA(KPTIMU+2) LINE(LAST1+1) = ' ' IF (JFORMZ.EQ.3) THEN LINE(LAST1+2) = ',' ELSE IF (MAIM2.LT.0) THEN MA(KPTIMU+2) = -MA(KPTIMU+2) LINE(LAST1+2) = '-' ELSE LINE(LAST1+2) = '+' ENDIF ENDIF C 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 140 J = LB2+KPT-1, KPT, -1 IF (LINE(J).NE.' ') THEN LAST2 = J GO TO 150 ENDIF 140 CONTINUE C 150 LAST2 = LAST2 + 2 LINE(LAST2) = 'i' IF (JFORMZ.EQ.2) LINE(LAST2) = 'I' IF (JFORMZ.EQ.3) LINE(LAST2) = ')' C IF (LINE(KPT).EQ.' ' .AND. LINE(KPT+1).EQ.'+') THEN DO 160 J = KPT+2, LAST2 LINE(J-2) = LINE(J) 160 CONTINUE LINE(LAST2-1) = ' ' LINE(LAST2) = ' ' LAST2 = LAST2 - 2 ENDIF C MA(KPTIMU+2) = MAIM2 NCALL = NCALL - 1 RETURN END SUBROUTINE ZMPACK(MA,MP) C C MA is packed two base NDIG digits per word and returned in MP. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MP(0:LPACKZ) CALL FMPACK(MA,MP) CALL FMPACK(MA(KPTIMU),MP(KPTIMP)) RETURN END SUBROUTINE ZMPRNT(MA) C C Print MA in base 10 format. C C ZMPRNT can be called directly by the user for easy output C in M format. MA is converted using ZMOUT and printed. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER JFORMZ,JPRNTZ C COMMON /ZMUSER/ JFORMZ,JPRNTZ CHARACTER CMBUFZ COMMON /ZMBUFF/ CMBUFZ(LMBUFZ) C CHARACTER *20 FORM INTEGER K,KSAVE,LAST1,LAST2,LB,LBZ,ND,NEXP C KSAVE = KFLAG ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1 IF (ND.LT.2) ND = 2 NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6 LB = MAX(JFORM2+NEXP,ND+NEXP) C IF (2*LB+7.LE.LMBUFZ .AND. JPRNTZ.EQ.1) THEN LBZ = 2*LB + 7 CALL ZMOUT(MA,CMBUFZ,LBZ,LAST1,LAST2) WRITE (FORM,110) KSWIDE-7 110 FORMAT(' (6X,',I3,'A1) ') WRITE (KW,FORM) (CMBUFZ(K),K=1,LAST2) ELSE CALL FMPRNT(MA) CALL FMPRNT(MA(KPTIMU)) ENDIF KFLAG = KSAVE RETURN END SUBROUTINE ZMPWR(MA,MB,MC) C C MC = MA ** MB. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMPWR: M01 - M06, MZ01 - MZ03 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MBIZ,MBRZ,MXSAVE,MTEMP INTEGER IEXTRA,INTMB,J,JSIN,JCOS,JSWAP,K,KASAVE,KOVUN, * KRADSV,KRESLT,KWRNSV,NDSAVE LOGICAL FMCOMP REAL XVAL C CALL ZMENTR('ZMPWR ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN MARZ = MA(0) MBRZ = MB(0) MAIZ = MA(KPTIMU) MBIZ = MB(KPTIMU) KACCSW = 0 NDIG = MIN(NDIG+1,NDG2MX) C CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) CALL ZMEQ2(MB,MB,NDSAVE,NDIG,1) C C Check for special cases. C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN IF (MB(2).GT.0 .AND. MB(KPTIMU+2).EQ.0) THEN CALL ZMI2M(0,MZ02) GO TO 160 ELSE KFLAG = -4 MZ02(1) = MUNKNO MZ02(2) = 1 MZ02(KPTIMU+1) = MUNKNO MZ02(KPTIMU+2) = 1 DO 110 J = 2, NDSAVE MZ02(J+1) = 0 MZ02(KPTIMU+J+1) = 0 110 CONTINUE MZ02(0) = NINT(NDIG*ALOGM2) MZ02(KPTIMU) = NINT(NDIG*ALOGM2) GO TO 160 ENDIF ENDIF IF (MB(KPTIMU+2).EQ.0) THEN KWRNSV = KWARN KWARN = 0 CALL FMMI(MB,INTMB) KWARN = KWRNSV IF (KFLAG.EQ.0) THEN IF (NCALL.EQ.1) THEN XVAL = ABS(INTMB) + 1 K = INT((1.5*LOG(XVAL))/ALOGMB + 2.0) NDIG = MAX(NDIG+K,2) IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL ZMWARN MB(1) = MUNKNO MB(2) = 1 MB(KPTIMU+1) = MUNKNO MB(KPTIMU+2) = 1 DO 120 J = 2, NDSAVE MB(J+1) = 0 MB(KPTIMU+J+1) = 0 120 CONTINUE NDIG = NDSAVE IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF IF (MBASE.GE.100*ABS(MA(2)) .OR. * MBASE.GE.100*ABS(MA(KPTIMU+2))) THEN NDIG = MIN(NDIG+1,NDG2MX) ENDIF ENDIF CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) CALL ZMIPWR(MA,INTMB,MZ03) CALL ZMEQ(MZ03,MZ02) GO TO 160 ENDIF ENDIF C C Check for cases where ABS(MA) is very close to 1, and C avoid cancellation. C CALL FMABS(MA,M03) CALL FMABS(MA(KPTIMU),M04) CALL FMI2M(1,M05) IF (FMCOMP(M03,'EQ',M05) .AND. * (M04(1).LE.(-NDIG).OR.M04(2).EQ.0)) THEN IF (MA(2).GT.0) THEN C C (1+c)**b = 1 + b*c + ... C CALL ZMI2M(1,MZ02) CALL ZMSUB(MA,MZ02,MZ02) CALL ZMMPY(MB,MZ02,MZ02) CALL FMADD(MZ02,M05,MZ02) ELSE C C (-1+c)**b = (-1)**b * (1 - b*c + ... ) 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).GE.0) THEN CALL FMMPYI(MB,180,M06) ELSE CALL FMMPYI(MB,-180,M06) ENDIF CALL FMCSSN(M06,MZ03,MZ03(KPTIMU)) KRAD = KRADSV CALL FMPI(M05) CALL FMMPY(M05,MB(KPTIMU),M05) IF (MA(KPTIMU+2).GE.0) CALL FMMPYI(M05,-1,M05) CALL FMEXP(M05,M05) CALL FMMPYD(M05,MZ03,MZ03(KPTIMU),MZ03,MZ03(KPTIMU)) CALL ZMMPY(MZ02,MZ03,MZ02) ENDIF GO TO 160 ENDIF IF (FMCOMP(M04,'EQ',M05) .AND. * (M03(1).LE.(-NDIG).OR.M03(2).EQ.0)) THEN IF (MA(KPTIMU+2).GT.0) THEN C C (i+c)**b = i**b * (1 - b*c*i - ... ) C CALL ZM2I2M(0,1,MZ02) CALL ZMSUB(MA,MZ02,MZ02) CALL ZMMPY(MB,MZ02,MZ02) DO 130 J = 0, NDIG+1 MTEMP = MZ02(J) MZ02(J) = MZ02(KPTIMU+J) MZ02(KPTIMU+J) = MTEMP 130 CONTINUE IF (MZ02(KPTIMU+1).NE.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 C C (-i+c)**b = (-i)**b * (1 + b*c*i - ... ) C CALL ZM2I2M(0,-1,MZ02) CALL ZMSUB(MA,MZ02,MZ02) CALL ZMMPY(MB,MZ02,MZ02) DO 140 J = 0, NDIG+1 MTEMP = MZ02(J) MZ02(J) = MZ02(KPTIMU+J) MZ02(KPTIMU+J) = MTEMP 140 CONTINUE IF (MZ02(1).NE.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) ENDIF GO TO 160 ENDIF C 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.EQ.-9) THEN IEXTRA = INT(MZ01(1)) ELSE IEXTRA = INT(MZ02(KPTIMU+1) - MZ01(1)) ENDIF IF (IEXTRA.GT.1) THEN NDIG = NDIG + IEXTRA IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL ZMWARN MZ02(1) = MUNKNO MZ02(2) = 1 MZ02(KPTIMU+1) = MUNKNO MZ02(KPTIMU+2) = 1 DO 150 J = 2, NDSAVE MZ02(J+1) = 0 MZ02(KPTIMU+J+1) = 0 150 CONTINUE NDIG = NDIG - IEXTRA MZ02(0) = NINT(NDIG*ALOGM2) MZ02(KPTIMU) = NINT(NDIG*ALOGM2) GO TO 160 ENDIF CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) CALL ZMEQ2(MB,MB,NDSAVE,NDIG,1) CALL ZMLN(MA,MZ02) CALL ZMMPY(MB,MZ02,MZ02) ENDIF C CALL ZMEXP(MZ02,MZ02) C 160 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 ZMREAD(KREAD,MA) C C Read MA on unit KREAD. Multi-line numbers will have '&' as the C last nonblank character on all but the last line. Only one C number is allowed on the line(s). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER KREAD DOUBLE PRECISION MA(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C CHARACTER CMBUFZ COMMON /ZMBUFF/ CMBUFZ(LMBUFZ) C CHARACTER LINE(80) INTEGER J,LB C NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMREAD' LB = 0 C 110 READ (KREAD,120,ERR=140,END=140) LINE 120 FORMAT(80A1) C C Scan the line and look for '&' C DO 130 J = 1, 80 IF (LINE(J).EQ.'&') GO TO 110 IF (LINE(J).NE.' ') THEN LB = LB + 1 IF (LB.GT.LMBUFZ) THEN KFLAG = -8 GO TO 150 ENDIF CMBUFZ(LB) = LINE(J) ENDIF 130 CONTINUE C CALL ZMINP(CMBUFZ,MA,1,LB) C NCALL = NCALL - 1 RETURN C C If there is an error, return UNKNOWN. C 140 KFLAG = -4 150 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 160 J = 2, NDIG MA(J+1) = 0 MA(KPTIMU+J+1) = 0 160 CONTINUE NCALL = NCALL - 1 RETURN END SUBROUTINE ZMREAL(MA,MBFM) C C MBFM = REAL(MA) C C MA is a complex ZM number, MBFM is a real FM number. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MBFM(0:LUNPCK) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C KFLAG = 0 NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMREAL' IF (NTRACE.NE.0) CALL ZMNTR(2,MA,MA,1) C CALL FMEQ(MA,MBFM) C IF (NTRACE.NE.0) CALL FMNTR(1,MBFM,MBFM,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMRPWR(MA,IVAL,JVAL,MB) C C MB = MA ** (IVAL/JVAL) C C Raise a ZM number to a rational power. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) INTEGER IVAL,JVAL C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMRPWR: M01 - M03, MZ01 - MZ04 C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MA2,MACCMB,MAIZ,MARZ,MR1,MXSAVE INTEGER IJSIGN,INVERT,IVAL2,J,JVAL2,K,KASAVE,KOVUN,KST,L,LVAL, * NDSAVE REAL XVAL C DOUBLE PRECISION AR,BR,F,THETA,X INTEGER NSTACK(19) C NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMRPWR' NDSAVE = NDIG IF (NTRACE.NE.0) THEN CALL ZMNTR(2,MA,MA,1) CALL FMNTRI(2,IVAL,0) CALL FMNTRI(2,JVAL,0) ENDIF MARZ = MA(0) MAIZ = MA(KPTIMU) KOVUN = 0 IF (MA(1).EQ.MEXPOV .OR. MA(1).EQ.MEXPUN .OR. * MA(KPTIMU+1).EQ.MEXPOV .OR. MA(KPTIMU+1).EQ.MEXPUN) KOVUN = 1 C IF (MBLOGS.NE.MBASE) CALL FMCONS KFLAG = 0 IJSIGN = 1 IVAL2 = ABS(IVAL) JVAL2 = ABS(JVAL) IF (IVAL.GT.0 .AND. JVAL.LT.0) IJSIGN = -1 IF (IVAL.LT.0 .AND. JVAL.GT.0) IJSIGN = -1 IF (IVAL2.GT.0 .AND. JVAL2.GT.0) CALL FMGCDI(IVAL2,JVAL2) C C Check for special cases. C IF (MA(1).EQ.MUNKNO .OR. MA(KPTIMU+1).EQ.MUNKNO .OR. * (IJSIGN.LE.0 .AND. MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) .OR. * JVAL.EQ.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 110 J = 2, NDSAVE MB(J+1) = 0 MB(KPTIMU+J+1) = 0 110 CONTINUE KFLAG = -4 IF (IVAL.LE.0 .AND. MA2.EQ.0) CALL ZMWARN IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF C IF (IVAL.EQ.0) THEN CALL ZMI2M(1,MB) IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF C C Increase the working precision. C IF (NCALL.EQ.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 ENDIF IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL ZMWARN MB(1) = MUNKNO MB(2) = 1 MB(KPTIMU+1) = MUNKNO MB(KPTIMU+2) = 1 DO 120 J = 2, NDSAVE MB(J+1) = 0 MB(KPTIMU+J+1) = 0 120 CONTINUE NDIG = NDSAVE MB(0) = NINT(NDIG*ALOGM2) MB(KPTIMU) = NINT(NDIG*ALOGM2) NDIG = NDSAVE IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF IF (MBASE.GE.100*ABS(MA(2)) .OR. * MBASE.GE.100*ABS(MA(KPTIMU+2))) THEN NDIG = MIN(NDIG+1,NDG2MX) ENDIF KASAVE = KACCSW MXSAVE = MXEXP MXEXP = MXEXP2 C CALL ZMEQ2(MA,MZ04,NDSAVE,NDIG,0) IF (IVAL2.EQ.1 .AND. JVAL2.EQ.2) THEN CALL ZMSQRT(MZ04,MB) GO TO 150 ENDIF C C Generate the first approximation to MA**(1/JVAL2). C 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).GE.MEXPOV) THEN KFLAG = -4 CALL ZMWARN MB(1) = MUNKNO MB(2) = 1 MB(KPTIMU+1) = MUNKNO MB(KPTIMU+2) = 1 DO 130 J = 2, NDSAVE MB(J+1) = 0 MB(KPTIMU+J+1) = 0 130 CONTINUE NDIG = NDSAVE MB(0) = NINT(NDIG*ALOGM2) MB(KPTIMU) = NINT(NDIG*ALOGM2) MXEXP = MXSAVE KACCSW = KASAVE NDIG = NDSAVE IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF C C Invert MA if ABS(MA) > 1 and IVAL or JVAL is large. C INVERT = 0 IF (IVAL.GT.5 .OR. JVAL.GT.5) THEN IF (MZ03(1).GT.0) THEN INVERT = 1 NDIG = NSTACK(KST) CALL ZMI2M(1,MB) CALL ZMDIV(MB,MZ04,MZ04) NDIG = NSTACK(1) CALL FMDIV(MB,MZ03,MZ03) ENDIF ENDIF C 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 C 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)) C C Newton iteration. C DO 140 J = 1, KST NDIG = NSTACK(J) IF (J.LT.KST) NDIG = NDIG + 1 LVAL = JVAL2 - 1 CALL ZMIPWR(MB,LVAL,MZ03) CALL ZMDIV(MZ04,MZ03,MZ03) CALL ZMMPYI(MB,LVAL,MB) CALL ZMADD(MB,MZ03,MB) CALL ZMDIVI(MB,JVAL2,MB) 140 CONTINUE C CALL ZMIPWR(MB,IJSIGN*IVAL2,MB) IF (INVERT.EQ.1) THEN CALL ZMI2M(1,MZ03) CALL ZMDIV(MZ03,MB,MB) ENDIF C C Round the result and return. C 150 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 ZMRSLT(MC,KRESLT) C C Handle results that are special cases, such as overflow, C underflow, and unknown. C C MC is the result that is returned C C KRESLT is the result code. Result codes handled here: C C 0 - Perform the normal operation C 12 - The result is 'UNKNOWN' C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MC(0:LUNPKZ) INTEGER KRESLT C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER KFSAVE C KFSAVE = KFLAG C IF (KRESLT.EQ.12 .OR. KRESLT.LT.0 .OR. KRESLT.GT.15) 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 ENDIF C RETURN END SUBROUTINE ZMSIN(MA,MB) C C MB = SIN(MA). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMSIN: M01 - M06, MZ01 - MZ03 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE C CALL ZMENTR('ZMSIN ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN MARZ = MA(0) MAIZ = MA(KPTIMU) KACCSW = 0 KRSAVE = KRAD KRAD = 1 C CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C C Check for special cases. C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN CALL ZMI2M(0,MZ01) GO TO 110 ELSE IF (MA(1).LT.(-NDIG) .AND. MA(KPTIMU+1).LT.(-NDIG)) THEN CALL ZMEQ(MA,MZ01) GO TO 110 ELSE IF (MA(KPTIMU+2).EQ.0) THEN CALL FMSIN(MA,MZ01) CALL FMI2M(0,MZ01(KPTIMU)) GO TO 110 ELSE IF (MA(2).EQ.0) THEN CALL FMSINH(MA(KPTIMU),MZ01(KPTIMU)) CALL FMI2M(0,MZ01) GO TO 110 ENDIF C C Find COS(REAL(MA)) and SIN(REAL(MA)). C CALL FMCSSN(MA,MZ01(KPTIMU),MZ01) C C Find COSH(IMAG(MA)) and SINH(IMAG(MA)). C CALL FMCHSH(MA(KPTIMU),M05,M06) C C SIN(MA) = SIN(REAL(MA))*COSH(IMAG(MA)) + C COS(REAL(MA))*SINH(IMAG(MA)) i C CALL FMMPY(MZ01,M05,MZ01) CALL FMMPY(MZ01(KPTIMU),M06,MZ01(KPTIMU)) C 110 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(MA,MB) C C MB = SINH(MA). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMSINH: M01 - M06, MZ01 - MZ03 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE C CALL ZMENTR('ZMSINH',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN MARZ = MA(0) MAIZ = MA(KPTIMU) KACCSW = 0 KRSAVE = KRAD KRAD = 1 C CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C C Check for special cases. C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN CALL ZMI2M(0,MZ01) GO TO 110 ELSE IF (MA(1).LT.(-NDIG) .AND. MA(KPTIMU+1).LT.(-NDIG)) THEN CALL ZMEQ(MA,MZ01) GO TO 110 ELSE IF (MA(2).EQ.0) THEN CALL FMSIN(MA(KPTIMU),MZ01(KPTIMU)) CALL FMI2M(0,MZ01) GO TO 110 ELSE IF (MA(KPTIMU+2).EQ.0) THEN CALL FMSINH(MA,MZ01) CALL FMI2M(0,MZ01(KPTIMU)) GO TO 110 ENDIF C C Find SIN(IMAG(MA)) and COS(IMAG(MA)). C CALL FMCSSN(MA(KPTIMU),MZ01,MZ01(KPTIMU)) C C Find SINH(REAL(MA)) and COSH(REAL(MA)). C CALL FMCHSH(MA,M05,M06) C C SINH(MA) = SINH(REAL(MA))*COS(IMAG(MA)) + C COSH(REAL(MA))*SIN(IMAG(MA)) i C CALL FMMPY(MZ01,M06,MZ01) CALL FMMPY(MZ01(KPTIMU),M05,MZ01(KPTIMU)) C 110 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 ZMSQR(MA,MB) C C MB = MA * MA C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMSQR: M01 - M03, MZ01 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE,MZERO INTEGER J,KASAVE,KOVUN,KRESLT,KWRNSV,NDGSV2,NDSAVE,NTRSAV C IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MA(KPTIMU+1)).GT.MEXPAB .OR. * KDEBUG.GE.1) THEN CALL ZMENTR('ZMSQR ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'ZMSQR ' CALL ZMNTR(2,MA,MA,1) ENDIF NDSAVE = NDIG IF (NCALL.EQ.1) THEN NDIG = MAX(NDIG+NGRD52,2) IF (NDIG.GT.NDG2MX) THEN NAMEST(NCALL) = 'ZMSQR ' KFLAG = -9 CALL ZMWARN KRESLT = 12 NDIG = NDSAVE CALL ZMRSLT(MB,KRESLT) IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF IF (MBASE.GE.100*ABS(MA(2)) .OR. * MBASE.GE.100*ABS(MA(KPTIMU+2))) THEN NDIG = MIN(NDIG+1,NDG2MX) ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 KOVUN = 0 ENDIF C MARZ = MA(0) MAIZ = MA(KPTIMU) MZERO = 0 NTRSAV = NTRACE NTRACE = 0 KWRNSV = KWARN KWARN = 0 C DO 110 J = NDSAVE+2, NDIG+1 MA(J) = MZERO MA(KPTIMU+J) = MZERO 110 CONTINUE IF (NCALL.EQ.1) THEN MA(0) = NINT(NDIG*ALOGM2) MA(KPTIMU) = MA(0) ENDIF C C Check for special cases. C IF (MA(KPTIMU+2).EQ.0) THEN CALL FMSQR(MA,MZ01) CALL FMI2M(0,MZ01(KPTIMU)) ELSE IF (MA(2).EQ.0) THEN CALL FMSQR(MA(KPTIMU),MZ01) IF (MZ01(1).NE.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)) ENDIF C MXEXP = MXSAVE NTRACE = NTRSAV NDGSV2 = NDIG NDIG = NDSAVE KWARN = KWRNSV IF (NCALL.EQ.1) THEN MA(0) = MARZ MA(KPTIMU) = MAIZ ENDIF 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).GE.MEXPOV .OR. MB(1).LE.-MEXPOV .OR. * MB(KPTIMU+1).GE.MEXPOV .OR. MB(KPTIMU+1).LE.-MEXPOV) THEN IF (MB(1).EQ.MUNKNO .OR. MB(KPTIMU+1).EQ.MUNKNO) THEN KFLAG = -4 ELSE IF (MB(1).EQ.MEXPOV .OR. MB(KPTIMU+1).EQ.MEXPOV) THEN KFLAG = -5 ELSE IF (MB(1).EQ.MEXPUN .OR. MB(KPTIMU+1).EQ.MEXPUN) THEN KFLAG = -6 ENDIF IF ((MB(1).EQ.MUNKNO) * .OR. (MB(KPTIMU+1).EQ.MUNKNO) * .OR. (MB(1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MB(KPTIMU+1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MB(1).EQ.MEXPOV .AND. KOVUN.EQ.0) * .OR. (MB(KPTIMU+1).EQ.MEXPOV .AND. KOVUN.EQ.0)) THEN NAMEST(NCALL) = 'ZMSQR ' CALL ZMWARN ENDIF ENDIF IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMSQRT(MA,MB) C C MB = SQRT(MA). Principal Square Root. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMSQRT: M01 - M03, MZ01 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV C IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MA(KPTIMU+1)).GT.MEXPAB .OR. * KDEBUG.GE.1) THEN CALL ZMENTR('ZMSQRT',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN ELSE NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'ZMSQRT' CALL ZMNTR(2,MA,MA,1) ENDIF NDSAVE = NDIG IF (NCALL.EQ.1) THEN NDIG = MAX(NDIG+NGRD52,2) IF (NDIG.GT.NDG2MX) THEN NAMEST(NCALL) = 'ZMSQRT' KFLAG = -9 CALL ZMWARN KRESLT = 12 NDIG = NDSAVE CALL ZMRSLT(MB,KRESLT) IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN ENDIF IF (MBASE.GE.100*ABS(MA(2)) .OR. * MBASE.GE.100*ABS(MA(KPTIMU+2))) THEN NDIG = MIN(NDIG+1,NDG2MX) ENDIF ENDIF KASAVE = KACCSW KACCSW = 0 MXSAVE = MXEXP MXEXP = MXEXP2 KOVUN = 0 ENDIF C NTRSAV = NTRACE NTRACE = 0 KWRNSV = KWARN KWARN = 0 MARZ = MA(0) MAIZ = MA(KPTIMU) C CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C C Check for special cases. C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN CALL ZMI2M(0,MZ01) GO TO 110 ELSE IF (MA(2).EQ.0) THEN CALL FMABS(MA(KPTIMU),M01) CALL FMDIVI(M01,2,M03) CALL FMSQRT(M03,M03) ELSE IF (MA(KPTIMU+2).EQ.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) ENDIF C CALL FMADD(M03,M03,M02) IF (MA(2).GE.0) THEN CALL FMDIV(MA(KPTIMU),M02,MZ01(KPTIMU)) CALL FMEQ(M03,MZ01) ELSE IF (MA(KPTIMU+2).GE.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).NE.MUNKNO) MZ01(2) = -MZ01(2) IF (MZ01(KPTIMU+1).NE.MUNKNO) MZ01(KPTIMU+2) = * -MZ01(KPTIMU+2) ENDIF ENDIF C 110 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) C IF (MB(1).EQ.MUNKNO .OR. MB(KPTIMU+1).EQ.MUNKNO) THEN KFLAG = -4 ELSE IF (MB(1).EQ.MEXPOV .OR. MB(KPTIMU+1).EQ.MEXPOV) THEN KFLAG = -5 ELSE IF (MB(1).EQ.MEXPUN .OR. MB(KPTIMU+1).EQ.MEXPUN) THEN KFLAG = -6 ENDIF NTRACE = NTRSAV NDIG = NDSAVE KWARN = KWRNSV IF ((MB(1).EQ.MUNKNO) * .OR. (MB(KPTIMU+1).EQ.MUNKNO) * .OR. (MB(1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MB(KPTIMU+1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MB(1).EQ.MEXPOV .AND. KOVUN.EQ.0) * .OR. (MB(KPTIMU+1).EQ.MEXPOV .AND. KOVUN.EQ.0)) THEN NAMEST(NCALL) = 'ZMSQRT' CALL ZMWARN ENDIF IF (NTRACE.NE.0) CALL ZMNTR(1,MB,MB,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMST2M(STRING,MA) C C MA = STRING C C Convert a character string to FM format. C This is often more convenient than using ZMINP, which converts an C array of CHARACTER*1 values. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C CHARACTER *(*) STRING DOUBLE PRECISION MA(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER JFORMZ,JPRNTZ C COMMON /ZMUSER/ JFORMZ,JPRNTZ CHARACTER CMBUFZ COMMON /ZMBUFF/ CMBUFZ(LMBUFZ) C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C INTEGER J,LB C NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMST2M' LB = LEN(STRING) C DO 110 J = 1, LB CMBUFZ(J) = STRING(J:J) 110 CONTINUE C CALL ZMINP(CMBUFZ,MA,1,LB) C NCALL = NCALL - 1 RETURN END SUBROUTINE ZMSUB(MA,MB,MC) C C MC = MA - MB C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ),MC(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER KASAVE,KF1,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV DOUBLE PRECISION MXSAVE C IF (ABS(MA(1)).GT.MEXPAB .OR. ABS(MA(KPTIMU+1)).GT.MEXPAB .OR. * ABS(MB(1)).GT.MEXPAB .OR. ABS(MB(KPTIMU+1)).GT.MEXPAB .OR. * KDEBUG.GE.1) THEN CALL ZMENTR('ZMSUB ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN NDIG = NDSAVE MXEXP = MXSAVE KACCSW = KASAVE ELSE NCALL = NCALL + 1 IF (NTRACE.NE.0) THEN NAMEST(NCALL) = 'ZMSUB ' CALL ZMNTR(2,MA,MB,2) ENDIF KOVUN = 0 ENDIF C C Force FMSUB to use more guard digits for user calls. C NCALL = NCALL - 1 NTRSAV = NTRACE NTRACE = 0 KWRNSV = KWARN KWARN = 0 C CALL FMSUB(MA,MB,MC) KF1 = KFLAG CALL FMSUB(MA(KPTIMU),MB(KPTIMU),MC(KPTIMU)) C NTRACE = NTRSAV KWARN = KWRNSV NCALL = NCALL + 1 IF (NTRACE.NE.0) NAMEST(NCALL) = 'ZMSUB ' IF (KFLAG.EQ.1) KFLAG = KF1 C IF (MC(1).EQ.MUNKNO .OR. MC(KPTIMU+1).EQ.MUNKNO) THEN KFLAG = -4 ELSE IF (MC(1).EQ.MEXPOV .OR. MC(KPTIMU+1).EQ.MEXPOV) THEN KFLAG = -5 ELSE IF (MC(1).EQ.MEXPUN .OR. MC(KPTIMU+1).EQ.MEXPUN) THEN KFLAG = -6 ENDIF IF ((MC(1).EQ.MUNKNO) * .OR. (MC(KPTIMU+1).EQ.MUNKNO) * .OR. (MC(1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MC(KPTIMU+1).EQ.MEXPUN .AND. KOVUN.EQ.0) * .OR. (MC(1).EQ.MEXPOV .AND. KOVUN.EQ.0) * .OR. (MC(KPTIMU+1).EQ.MEXPOV .AND. KOVUN.EQ.0)) THEN NAMEST(NCALL) = 'ZMSUB ' CALL ZMWARN ENDIF IF (NTRACE.NE.0) CALL ZMNTR(1,MC,MC,1) NCALL = NCALL - 1 RETURN END SUBROUTINE ZMTAN(MA,MB) C C MB = TAN(MA). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMTAN: M01 - M06, MZ01 - MZ03 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE INTEGER IEXTRA,J,KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE,NGOAL C CALL ZMENTR('ZMTAN ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN MARZ = MA(0) MAIZ = MA(KPTIMU) KRSAVE = KRAD KRAD = 1 C 110 CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C C Check for special cases. C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN CALL ZMI2M(0,MZ01) GO TO 120 ELSE IF (MA(1).LT.(-NDIG) .AND. MA(KPTIMU+1).LT.(-NDIG)) THEN CALL ZMEQ(MA,MZ01) GO TO 120 ELSE IF (MA(KPTIMU+2).EQ.0) THEN CALL FMTAN(MA,MZ01) CALL FMI2M(0,MZ01(KPTIMU)) GO TO 120 ELSE IF (MA(2).EQ.0) THEN CALL FMTANH(MA(KPTIMU),MZ01(KPTIMU)) CALL FMI2M(0,MZ01) GO TO 120 ENDIF C C Find SIN(2*REAL(MA)) and COS(2*REAL(MA)). C CALL FMADD(MA,MA,MZ01) CALL FMCSSN(MZ01,MZ01(KPTIMU),MZ01) C C Find SINH(2*IMAG(MA)) and COSH(2*IMAG(MA)). C CALL FMADD(MA(KPTIMU),MA(KPTIMU),M06) CALL FMCHSH(M06,M05,M06) C C TAN(MA) = SIN(2*REAL(MA)) / C (COS(2*REAL(MA))+COSH(2*IMAG(MA)) + C SINH(2*IMAG(MA)) / C (COS(2*REAL(MA))+COSH(2*IMAG(MA)) i C CALL FMADD(MZ01(KPTIMU),M05,M05) IF (M05(2).EQ.0) THEN MZ01(0) = 0 NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7 GO TO 130 ELSE IF (M05(1).EQ.MEXPOV) THEN CALL FMDIV(MZ01,M05,MZ01) CALL FMIM(1,MZ01(KPTIMU)) IF (M06(2).LT.0) MZ01(KPTIMU+2) = -MZ01(KPTIMU+2) ELSE CALL FMDIVD(MZ01,M06,M05,MZ01,MZ01(KPTIMU)) ENDIF C C Check for too much cancellation. C 120 IF (NCALL.LE.1) THEN NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7 ELSE NGOAL = INT(-MXEXP2) ENDIF 130 IF (MZ01(0).LE.NGOAL .OR. MZ01(KPTIMU).LE.NGOAL) THEN IEXTRA = INT(REAL(MAX(NGOAL-MZ01(0),NGOAL-MZ01(KPTIMU))) * /ALOGM2 + 23.03/ALOGMB) + 1 NDIG = NDIG + IEXTRA IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL ZMWARN MZ01(1) = MUNKNO MZ01(2) = 1 MZ01(KPTIMU+1) = MUNKNO MZ01(KPTIMU+2) = 1 DO 140 J = 2, NDSAVE MZ01(J+1) = 0 MZ01(KPTIMU+J+1) = 0 140 CONTINUE NDIG = NDIG - IEXTRA MZ01(0) = NINT(NDIG*ALOGM2) MZ01(KPTIMU) = NINT(NDIG*ALOGM2) GO TO 150 ENDIF GO TO 110 ENDIF C 150 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(MA,MB) C C MB = TANH(MA). C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MB(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C INTEGER LHASH1,LHASH2 PARAMETER (LHASH1=0 , LHASH2=256) DOUBLE PRECISION DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB INTEGER NDIGPI,NDIGE,NDIGLB,NDIGLI,KHASHT,KHASHV, * NGRD21,NGRD52,NGRD22 DOUBLE PRECISION MBSPI,MBSE,MBSLB,MBSLI,MPISAV,MESAV,MLBSAV, * MLN1,MLN2,MLN3,MLN4,MBLOGS,MEXPAB REAL ALOGMB,ALOGMT,ALOGM2,ALOGMX C COMMON /FMSAVE/ NDIGPI,NDIGE,NDIGLB,NDIGLI,MBSPI,MBSE,MBSLB,MBSLI, * MPISAV(0:LUNPCK),MESAV(0:LUNPCK),MLBSAV(0:LUNPCK), * MLN1(0:LUNPCK),MLN2(0:LUNPCK),MLN3(0:LUNPCK), * MLN4(0:LUNPCK),MBLOGS,MEXPAB,ALOGMB,ALOGM2,ALOGMX, * ALOGMT,DLOGMB,DLOGTN,DLOGTW,DLOGTP,DLOGPI,DPPI, * DPEPS,DLOGEB,KHASHT(LHASH1:LHASH2), * KHASHV(LHASH1:LHASH2),NGRD21,NGRD52,NGRD22 C C Scratch array usage during ZMTANH: M01 - M06, MZ01 - MZ03 C DOUBLE PRECISION MZ01,MZ02,MZ03,MZ04 C COMMON /ZM1/ MZ01(0:LUNPKZ),MZ02(0:LUNPKZ),MZ03(0:LUNPKZ), * MZ04(0:LUNPKZ) C DOUBLE PRECISION M01,M02,M03,M04,M05,M06 C COMMON /FM1/ M01(0:LUNPCK),M02(0:LUNPCK),M03(0:LUNPCK), * M04(0:LUNPCK),M05(0:LUNPCK),M06(0:LUNPCK) C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION MACCMB,MAIZ,MARZ,MXSAVE INTEGER IEXTRA,J,KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE,NGOAL C CALL ZMENTR('ZMTANH',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, * KOVUN) IF (KRESLT.NE.0) RETURN MARZ = MA(0) MAIZ = MA(KPTIMU) KRSAVE = KRAD KRAD = 1 C 110 CALL ZMEQ2(MA,MA,NDSAVE,NDIG,1) C C Check for special cases. C IF (MA(2).EQ.0 .AND. MA(KPTIMU+2).EQ.0) THEN CALL ZMI2M(0,MZ01) GO TO 120 ELSE IF (MA(1).LT.(-NDIG) .AND. MA(KPTIMU+1).LT.(-NDIG)) THEN CALL ZMEQ(MA,MZ01) GO TO 120 ELSE IF (MA(2).EQ.0) THEN CALL FMTAN(MA(KPTIMU),MZ01(KPTIMU)) CALL FMI2M(0,MZ01) GO TO 120 ELSE IF (MA(KPTIMU+2).EQ.0) THEN CALL FMTANH(MA,MZ01) CALL FMI2M(0,MZ01(KPTIMU)) GO TO 120 ENDIF C C Find SIN(2*IMAG(MA)) and COS(2*IMAG(MA)). C CALL FMADD(MA(KPTIMU),MA(KPTIMU),MZ01) CALL FMCSSN(MZ01,MZ01(KPTIMU),MZ01) C C Find SINH(2*REAL(MA)) and COSH(2*REAL(MA)). C CALL FMADD(MA,MA,M06) CALL FMCHSH(M06,M05,M06) C C TANH(MA) = SINH(2*REAL(MA)) / C (COS(2*IMAG(MA))+COSH(2*REAL(MA)) + C SIN(2*IMAG(MA)) / C (COS(2*IMAG(MA))+COSH(2*REAL(MA)) i C CALL FMADD(MZ01(KPTIMU),M05,M05) IF (M05(2).EQ.0) THEN MZ01(0) = 0 NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7 GO TO 130 ELSE IF (M05(1).EQ.MEXPOV) THEN CALL FMDIV(MZ01,M05,MZ01(KPTIMU)) CALL FMIM(1,MZ01) IF (M06(2).LT.0) MZ01(2) = -MZ01(2) ELSE CALL FMDIVD(MZ01,M06,M05,MZ01(KPTIMU),MZ01) ENDIF C C Check for too much cancellation. C 120 IF (NCALL.LE.1) THEN NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7 ELSE NGOAL = INT(-MXEXP2) ENDIF 130 IF (MZ01(0).LE.NGOAL .OR. MZ01(KPTIMU).LE.NGOAL) THEN IEXTRA = INT(REAL(MAX(NGOAL-MZ01(0),NGOAL-MZ01(KPTIMU))) * /ALOGM2 + 23.03/ALOGMB) + 1 NDIG = NDIG + IEXTRA IF (NDIG.GT.NDG2MX) THEN KFLAG = -9 CALL ZMWARN MZ01(1) = MUNKNO MZ01(2) = 1 MZ01(KPTIMU+1) = MUNKNO MZ01(KPTIMU+2) = 1 DO 140 J = 2, NDSAVE MZ01(J+1) = 0 MZ01(KPTIMU+J+1) = 0 140 CONTINUE NDIG = NDIG - IEXTRA MZ01(0) = NINT(NDIG*ALOGM2) MZ01(KPTIMU) = NINT(NDIG*ALOGM2) GO TO 150 ENDIF GO TO 110 ENDIF C 150 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 ZMUNPK(MP,MA) C C MP is unpacked and the value returned in MA. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C DOUBLE PRECISION MA(0:LUNPKZ),MP(0:LPACKZ) C CALL FMUNPK(MP,MA) CALL FMUNPK(MP(KPTIMP),MA(KPTIMU)) RETURN END SUBROUTINE ZMWARN C C Called by one of the ZM routines to print a warning message C if any error condition arises in that routine. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C CHARACTER *6 NAME C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C INTEGER NCS C IF (KFLAG.GE.0 .OR. NCALL.NE.1 .OR. KWARN.LE.0) RETURN NCS = NCALL NAME = NAMEST(NCALL) WRITE (KW,110) KFLAG,NAME 110 FORMAT(/' Error of type KFLAG =',I3, * ' in FM package in routine ',A6/) C 120 NCALL = NCALL - 1 IF (NCALL.GT.0) THEN NAME = NAMEST(NCALL) WRITE (KW,130) NAME 130 FORMAT( ' called from ',A6) GO TO 120 ENDIF C IF (KFLAG.EQ.-1) THEN WRITE (KW,140) NDIGMX 140 FORMAT(' NDIG must be between 2 and',I10/) ELSE IF (KFLAG.EQ.-2) THEN WRITE (KW,150) INT(MXBASE) 150 FORMAT(' MBASE must be between 2 and',I10/) ELSE IF (KFLAG.EQ.-3) THEN WRITE (KW,160) 160 FORMAT(' An input argument is not a valid FM number.', * ' Its exponent is out of range.'/) WRITE (KW,170) 170 FORMAT(' UNKNOWN has been returned.'/) ELSE IF (KFLAG.EQ.-4 .OR. KFLAG.EQ.-7) THEN WRITE (KW,180) 180 FORMAT(' Invalid input argument for this routine.'/) WRITE (KW,170) ELSE IF (KFLAG.EQ.-5) THEN WRITE (KW,190) 190 FORMAT(' The result has overflowed.'/) ELSE IF (KFLAG.EQ.-6) THEN WRITE (KW,200) 200 FORMAT(' The result has underflowed.'/) ELSE IF (KFLAG.EQ.-8 .AND. NAME.EQ.'ZMOUT ') THEN WRITE (KW,210) 210 FORMAT(' The result array is not big enough to hold the', * ' output character string'/' in the current format.'/ * ' The result ''***...***'' has been returned.'/) ELSE IF (KFLAG.EQ.-8 .AND. NAME.EQ.'ZMREAD') THEN WRITE (KW,220) 220 FORMAT(' The CMBUFF array is not big enough to hold the', * ' input character string'/ * ' UNKNOWN has been returned.'/) ELSE IF (KFLAG.EQ.-9) THEN WRITE (KW,230) 230 FORMAT(' Precision could not be raised enough to provide all' * ,' requested guard digits.'/) WRITE (KW,240) NDIG,NDG2MX 240 FORMAT(I23,' digits were requested (NDIG).'/ * ' Maximum number of digits currently available', * ' (NDG2MX) is',I7,'.'/) WRITE (KW,170) ENDIF C NCALL = NCS IF (KWARN.GE.2) THEN STOP ENDIF RETURN END SUBROUTINE ZMWRIT(KWRITE,MA) C C Write MA on unit KWRITE under the current format. Multi-line numbers C will have '&' as the last nonblank character on all but the last C line of the real part and the imaginary part. C These numbers can then be read easily using FMREAD. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C INTEGER KWRITE DOUBLE PRECISION MA(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C CHARACTER CMBUFZ COMMON /ZMBUFF/ CMBUFZ(LMBUFZ) C INTEGER J,K,KSAVE,L,LAST,LAST1,LAST2,LB,ND,NEXP C NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMWRIT' KSAVE = KFLAG ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1 IF (ND.LT.2) ND = 2 NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6 LB = 2*MAX(JFORM2+NEXP,ND+NEXP) + 3 LB = MIN(LB,LMBUFZ) CALL ZMOUT(MA,CMBUFZ,LB,LAST1,LAST2) KFLAG = KSAVE LAST = LAST2 + 1 DO 130 J = 1, LAST2 IF (CMBUFZ(LAST-J).NE.' ' .OR. J.EQ.LAST2) THEN L = LAST - J IF (MOD(L,73).NE.0) THEN WRITE (KWRITE,110) (CMBUFZ(K),K=1,L) 110 FORMAT(4X,73A1,' &') ELSE WRITE (KWRITE,110) (CMBUFZ(K),K=1,L-73) WRITE (KWRITE,120) (CMBUFZ(K),K=L-72,L) 120 FORMAT(4X,73A1) ENDIF NCALL = NCALL - 1 RETURN ENDIF 130 CONTINUE NCALL = NCALL - 1 RETURN END SUBROUTINE ZMZ2M(ZVAL,MA) C C MA = ZVAL C C ZVAL is complex and is converted to ZM form. C C IMPLICIT NONE C INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ C PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) C COMPLEX ZVAL DOUBLE PRECISION MA(0:LUNPKZ) C INTEGER NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC,KFLAG, * KWARN,KROUND,KSWIDE,KESWCH,KDEBUG DOUBLE PRECISION MBASE C COMMON /FMUSER/ MBASE,NDIG,JFORM1,JFORM2,KRAD,KW,NTRACE,LVLTRC, * KFLAG,KWARN,KROUND,KSWIDE,KESWCH,KDEBUG C DOUBLE PRECISION DPMAX INTEGER NCALL,KACCSW,IUNKNO,NDG2MX,INTMAX,KSUB REAL RUNKNO,SPMAX DOUBLE PRECISION MWA,MXEXP,MXEXP2,MEXPUN,MEXPOV,MUNKNO,MXBASE, * MAXINT C COMMON /FM/ MWA(LMWA),NCALL,KACCSW,MXEXP,MXEXP2,MEXPUN,MEXPOV, * MUNKNO,IUNKNO,RUNKNO,MXBASE,NDG2MX,SPMAX,DPMAX, * MAXINT,INTMAX,KSUB C CHARACTER CMBUFF,CMCHAR CHARACTER *6 NAMEST C COMMON /FMBUFF/ CMBUFF(LMBUFF),NAMEST(0:50),CMCHAR C DOUBLE PRECISION DZ C NCALL = NCALL + 1 NAMEST(NCALL) = 'ZMZ2M ' IF (NTRACE.NE.0) CALL ZMNTRZ(2,ZVAL,1) C DZ = DBLE(ZVAL) CALL FMDP2M(DZ,MA) DZ = DBLE(AIMAG(ZVAL)) CALL FMDP2M(DZ,MA(KPTIMU)) C IF (NTRACE.NE.0) CALL ZMNTR(1,MA,MA,1) NCALL = NCALL - 1 RETURN END C C Here are the routines which work with packed ZM numbers. All names C are the same as unpacked versions with 'ZM' replaced by 'ZP'. C C To convert a program using the ZM package from unpacked calls to C packed calls make these changes to the program: C '(0:LUNPKZ)' to '(0:LUNPKZ)' in dimensions. C 'CALL ZM' to 'CALL ZP' C SUBROUTINE ZPABS(MA,MBFM) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MBFM(0:LPACK) DOUBLE PRECISION MPA,MPB,MPC COMMON /FMPCK/ MPA(0:LUNPCK),MPB(0:LUNPCK),MPC(0:LUNPCK) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMABS(MX,MPA) CALL FMPACK(MPA,MBFM) RETURN END SUBROUTINE ZPACOS(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMACOS(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPADD(MA,MB,MC) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ),MC(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMUNPK(MB,MY) CALL ZMADD(MX,MY,MX) CALL ZMPACK(MX,MC) RETURN END SUBROUTINE ZPADDI(MA,INTEG) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ) INTEGER INTEG DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMADDI(MX,INTEG) CALL ZMPACK(MX,MA) RETURN END SUBROUTINE ZPARG(MA,MBFM) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MBFM(0:LPACK) DOUBLE PRECISION MPA,MPB,MPC COMMON /FMPCK/ MPA(0:LUNPCK),MPB(0:LUNPCK),MPC(0:LUNPCK) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMARG(MX,MPA) CALL FMPACK(MPA,MBFM) RETURN END SUBROUTINE ZPASIN(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMASIN(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPATAN(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMATAN(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPCHSH(MA,MB,MC) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ),MC(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMCHSH(MX,MX,MY) CALL ZMPACK(MX,MB) CALL ZMPACK(MY,MC) RETURN END SUBROUTINE ZPCMPX(MAFM,MBFM,MC) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MAFM(0:LPACK),MBFM(0:LPACK),MC(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) DOUBLE PRECISION MPA,MPB,MPC COMMON /FMPCK/ MPA(0:LUNPCK),MPB(0:LUNPCK),MPC(0:LUNPCK) CALL FMUNPK(MAFM,MPA) CALL FMUNPK(MBFM,MPB) CALL ZMCMPX(MPA,MPB,MX) CALL ZMPACK(MX,MC) RETURN END SUBROUTINE ZPCONJ(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMCONJ(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPCOS(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMCOS(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPCOSH(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMCOSH(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPCSSN(MA,MB,MC) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ),MC(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMCSSN(MX,MX,MY) CALL ZMPACK(MX,MB) CALL ZMPACK(MY,MC) RETURN END SUBROUTINE ZPDIV(MA,MB,MC) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ),MC(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMUNPK(MB,MY) CALL ZMDIV(MX,MY,MX) CALL ZMPACK(MX,MC) RETURN END SUBROUTINE ZPDIVI(MA,INTEG,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) INTEGER INTEG DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMDIVI(MX,INTEG,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPEQ(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) CALL FPEQ(MA,MB) CALL FPEQ(MA(KPTIMP),MB(KPTIMP)) RETURN END SUBROUTINE ZPEQU(MA,MB,NDA,NDB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) INTEGER NDA,NDB CALL FPEQU(MA,MB,NDA,NDB) CALL FPEQU(MA(KPTIMP),MB(KPTIMP),NDA,NDB) RETURN END SUBROUTINE ZPEXP(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMEXP(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPFORM(FORM1,FORM2,MA,STRING) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ) CHARACTER *(*) FORM1,FORM2,STRING DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMFORM(FORM1,FORM2,MX,STRING) RETURN END SUBROUTINE ZPFPRT(FORM1,FORM2,MA) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ) CHARACTER *(*) FORM1,FORM2 DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMFPRT(FORM1,FORM2,MX) RETURN END SUBROUTINE ZP2I2M(INTEG1,INTEG2,MA) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) INTEGER INTEG1,INTEG2 DOUBLE PRECISION MA(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZM2I2M(INTEG1,INTEG2,MX) CALL ZMPACK(MX,MA) RETURN END SUBROUTINE ZPI2M(INTEG,MA) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) INTEGER INTEG DOUBLE PRECISION MA(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMI2M(INTEG,MX) CALL ZMPACK(MX,MA) RETURN END SUBROUTINE ZPIMAG(MA,MBFM) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MBFM(0:LPACK) DOUBLE PRECISION MPA,MPB,MPC COMMON /FMPCK/ MPA(0:LUNPCK),MPB(0:LUNPCK),MPC(0:LUNPCK) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMIMAG(MX,MPA) CALL FMPACK(MPA,MBFM) RETURN END SUBROUTINE ZPINT(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMINT(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPINP(LINE,MA,LA,LB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) INTEGER LA,LB CHARACTER LINE(LB) DOUBLE PRECISION MA(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMINP(LINE,MX,LA,LB) CALL ZMPACK(MX,MA) RETURN END SUBROUTINE ZPIPWR(MA,INTEG,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) INTEGER INTEG DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMIPWR(MX,INTEG,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPLG10(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMLG10(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPLN(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMLN(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPM2I(MA,INTEG) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ) INTEGER INTEG DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMM2I(MX,INTEG) RETURN END SUBROUTINE ZPM2Z(MA,ZVAL) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) COMPLEX ZVAL DOUBLE PRECISION MA(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMM2Z(MX,ZVAL) RETURN END SUBROUTINE ZPMPY(MA,MB,MC) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ),MC(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMUNPK(MB,MY) CALL ZMMPY(MX,MY,MX) CALL ZMPACK(MX,MC) RETURN END SUBROUTINE ZPMPYI(MA,INTEG,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) INTEGER INTEG DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMMPYI(MX,INTEG,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPNINT(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMNINT(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPOUT(MA,LINE,LB,LAST1,LAST2) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ) INTEGER LB,LAST1,LAST2 CHARACTER LINE(LB) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMOUT(MX,LINE,LB,LAST1,LAST2) RETURN END SUBROUTINE ZPPRNT(MA) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMPRNT(MX) RETURN END SUBROUTINE ZPPWR(MA,MB,MC) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ),MC(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMUNPK(MB,MY) CALL ZMPWR(MX,MY,MX) CALL ZMPACK(MX,MC) RETURN END SUBROUTINE ZPREAD(KREAD,MA) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) INTEGER KREAD DOUBLE PRECISION MA(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMREAD(KREAD,MX) CALL ZMPACK(MX,MA) RETURN END SUBROUTINE ZPREAL(MA,MBFM) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MBFM(0:LPACK) DOUBLE PRECISION MPA,MPB,MPC COMMON /FMPCK/ MPA(0:LUNPCK),MPB(0:LUNPCK),MPC(0:LUNPCK) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMREAL(MX,MPA) CALL FMPACK(MPA,MBFM) RETURN END SUBROUTINE ZPRPWR(MA,IVAL,JVAL,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) INTEGER IVAL,JVAL DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMRPWR(MX,IVAL,JVAL,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPSET(NPREC) INTEGER NPREC CALL ZMSET(NPREC) RETURN END SUBROUTINE ZPSIN(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMSIN(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPSINH(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMSINH(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPSQR(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMSQR(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPSQRT(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMSQRT(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPST2M(STRING,MA) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) CHARACTER *(*) STRING DOUBLE PRECISION MA(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMST2M(STRING,MX) CALL ZMPACK(MX,MA) RETURN END SUBROUTINE ZPSUB(MA,MB,MC) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ),MC(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMUNPK(MB,MY) CALL ZMSUB(MX,MY,MX) CALL ZMPACK(MX,MC) RETURN END SUBROUTINE ZPTAN(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMTAN(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPTANH(MA,MB) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) DOUBLE PRECISION MA(0:LPACKZ),MB(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMTANH(MX,MX) CALL ZMPACK(MX,MB) RETURN END SUBROUTINE ZPWRIT(KWRITE,MA) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) INTEGER KWRITE DOUBLE PRECISION MA(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMUNPK(MA,MX) CALL ZMWRIT(KWRITE,MX) RETURN END SUBROUTINE ZPZ2M(ZVAL,MA) C IMPLICIT NONE INTEGER NDIGMX,NBITS,LPACK,LUNPCK,LMWA,LJSUMS,LMBUFF,LPACKZ, * LUNPKZ,KPTIMP,KPTIMU,LMBUFZ PARAMETER ( NDIGMX=256 , NBITS=64 , * LPACK = (NDIGMX+1)/2+1 , LUNPCK = (6*NDIGMX)/5+20, * LMWA = 2*LUNPCK , LJSUMS = 8*(LUNPCK+2), * LMBUFF = ((LUNPCK+3)*(NBITS-1)*301)/2000+6, * LPACKZ = 2*LPACK+1 , LUNPKZ = 2*LUNPCK+1, * KPTIMP = LPACK+1 , KPTIMU = LUNPCK+1, * LMBUFZ = 2*LMBUFF+10 ) COMPLEX ZVAL DOUBLE PRECISION MA(0:LPACKZ) DOUBLE PRECISION MX,MY COMMON /ZMPCK/ MX(0:LUNPKZ),MY(0:LUNPKZ) CALL ZMZ2M(ZVAL,MX) CALL ZMPACK(MX,MA) RETURN C End of the ZM package. This is line 9,248. END