C--**--CH2936--539--C:L--4:11:1999
C--**--CH2934--539--P:RW--4:11:1999
C--**--CH2931--539--C:ID--4:11:1999
C--**--CH2927--539--A:1--4:11:1999
C--**--CH349--539--A:H--15:6:1999
C--**--CH348--539--C:D--15:6:1999
C--**--CH347--539--U:D--15:6:1999
      SUBROUTINE MPBLAS(I1)
C
C     THIS SUBROUTINE IS CALLED TO SET UP BRENT'S MP PACKAGE
C     FOR USE BY THE EXTENDED PRECISION INNER PRODUCTS FROM THE BLAS.
C
C     THE COMMON BLOCK FOR THE MP PACKAGE (MODIFIED TO GIVE IT A NAME)
C
C     SET  I1 = 1  TO FLAG THAT THIS ROUTINE WAS CALLED
C     .. Scalar Arguments ..
      INTEGER I1
C     ..
C     .. Scalars in Common ..
      INTEGER MPB,MPLUN,MPM,MPMXR,MPT
C     ..
C     .. Arrays in Common ..
      INTEGER MPR(12)
C     ..
C     .. External Functions ..
      INTEGER I1MACH
      EXTERNAL I1MACH
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/MPB,MPT,MPM,MPLUN,MPMXR,MPR
C     ..
      I1 = 1
C
C     FOR FULL EXTENDED PRECISION ACCURACY, MPB SHOULD BE AS LARGE AS
C     POSSIBLE, SUBJECT TO THE RESTRICTIONS IN BRENT'S PAPER (ACM TRANS.
C     ON MATH. SOFTWARE, MARCH 1978, VOL. 4, NO. 1.).
C     STATEMENTS BELOW ARE FOR AN INTEGER WORDLENGTH OF  48, 36, 32,
C     24, 18, AND 16. PICK ONE, OR GENERATE A NEW ONE.
C  48     MPB = 4194304
C  36     MPB =   65536
C  32
      MPB = 16384
C  24     MPB =    1024
C  18     MPB =     128
C  16     MPB =      64
C
C     SET UP REMAINING PARAMETERS
C                  UNIT FOR ERROR MESSAGES
      MPLUN = I1MACH(2)
C                  NUMBER OF MP DIGITS
      MPT = 8
C                  DIMENSION OF R
      MPMXR = 12
C                  EXPONENT RANGE
      MPM = 32767
      RETURN

      END
C $$                   ******  MPADD  ******
      SUBROUTINE MPADD(X,Y,Z)
C ADDS X AND Y, FORMING RESULT IN Z, WHERE X, Y AND Z ARE MP
C NUMBERS.  FOUR GUARD DIGITS ARE USED, AND THEN R*-ROUNDING.
C     .. Array Arguments ..
      INTEGER X(*),Y(*),Z(*)
C     ..
C     .. External Subroutines ..
      EXTERNAL MPADD2
C     ..
      CALL MPADD2(X,Y,Z,Y,0)
      RETURN

      END
C $$                   ******  MPMLP  ******
      SUBROUTINE MPMLP(U,V,W,J)
C PERFORMS INNER MULTIPLICATION LOOP FOR MPMUL
C NOTE THAT CARRIES ARE NOT PROPAGATED IN INNER LOOP,
C WHICH SAVES TIME AT THE EXPENSE OF SPACE.
C     .. Scalar Arguments ..
      INTEGER J,W
C     ..
C     .. Array Arguments ..
      INTEGER U(*),V(*)
C     ..
C     .. Local Scalars ..
      INTEGER I
C     ..
      DO 10 I = 1,J
          U(I) = U(I) + W*V(I)
   10 CONTINUE
      RETURN

      END
C $$                   ******  MPUNFL  ******
      SUBROUTINE MPUNFL(X)
C CALLED ON MULTIPLE-PRECISION UNDERFLOW, IE WHEN THE
C EXPONENT OF MP NUMBER X WOULD BE LESS THAN -M.
C SINCE M MAY HAVE BEEN OVERWRITTEN, CHECK B, T, M ETC.
C     .. Array Arguments ..
      INTEGER X(*)
C     ..
C     .. External Subroutines ..
      EXTERNAL MPCHK
C     ..
      CALL MPCHK(1,4)
C THE UNDERFLOWING NUMBER IS SET TO ZERO
C AN ALTERNATIVE WOULD BE TO CALL MPMINR (X) AND RETURN,
C POSSIBLY UPDATING A COUNTER AND TERMINATING EXECUTION
C AFTER A PRESET NUMBER OF UNDERFLOWS.  ACTION COULD EASILY
C BE DETERMINED BY A FLAG IN LABELLED COMMON.
      X(1) = 0
      RETURN

      END
C $$                   ******  MPMULI  ******
      SUBROUTINE MPMULI(X,IY,Z)
C MULTIPLIES MP X BY SINGLE-PRECISION INTEGER IY GIVING MP Z.
C THIS IS FASTER THAN USING MPMUL.  RESULT IS ROUNDED.
C MULTIPLICATION BY 1 MAY BE USED TO NORMALIZE A NUMBER
C EVEN IF THE LAST DIGIT IS B.
C     .. Scalar Arguments ..
      INTEGER IY
C     ..
C     .. Array Arguments ..
      INTEGER X(*),Z(*)
C     ..
C     .. External Subroutines ..
      EXTERNAL MPMUL2
C     ..
      CALL MPMUL2(X,IY,Z,0)
      RETURN

      END
C $$                   ******  MPADD2  ******
      SUBROUTINE MPADD2(X,Y,Z,Y1,TRUNC)
C     MODIFIED FOR USE WITH BLAS.
C     COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12.
C CALLED BY MPADD, MPSUB ETC.
C X, Y AND Z ARE MP NUMBERS, Y1 AND TRUNC ARE INTEGERS.
C TO FORCE CALL BY REFERENCE RATHER THAN VALUE/RESULT, Y1 IS
C DECLARED AS AN ARRAY, BUT ONLY Y1(1) IS EVER USED.
C SETS Z = X + Y1(1)*ABS(Y), WHERE Y1(1) = +- Y(1).
C IF TRUNC.EQ.0 R*-ROUNDING IS USED, OTHERWISE TRUNCATION.
C R*-ROUNDING IS DEFINED IN KUKI AND CODI, COMM. ACM
C 16(1973), 223.  (SEE ALSO BRENT, IEEE TC-22(1973), 601.)
C CHECK FOR X OR Y ZERO
C     .. Scalar Arguments ..
      INTEGER TRUNC
C     ..
C     .. Array Arguments ..
      INTEGER X(*),Y(*),Y1(*),Z(*)
C     ..
C     .. Scalars in Common ..
      INTEGER B,LUN,M,MXR,T
C     ..
C     .. Arrays in Common ..
      INTEGER R(12)
C     ..
C     .. Local Scalars ..
      INTEGER ED,J,MED,RE,RS,S
C     ..
C     .. External Subroutines ..
      EXTERNAL MPADD3,MPCHK,MPERR,MPNZR,MPSTR
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC IABS
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/B,T,M,LUN,MXR,R
C     ..
      IF (X(1).NE.0) GO TO 20
   10 CALL MPSTR(Y,Z)
      Z(1) = Y1(1)
      RETURN

   20 IF (Y1(1).NE.0) GO TO 40
   30 CALL MPSTR(X,Z)
      RETURN
C COMPARE SIGNS
   40 S = X(1)*Y1(1)
      IF (IABS(S).LE.1) GO TO 50
      CALL MPCHK(1,4)
      WRITE (LUN,FMT=9000)
      CALL MPERR
      Z(1) = 0
      RETURN
C COMPARE EXPONENTS
   50 ED = X(2) - Y(2)
      MED = IABS(ED)
      IF (ED) 80,60,110
C EXPONENTS EQUAL SO COMPARE SIGNS, THEN FRACTIONS IF NEC.
   60 IF (S.GT.0) GO TO 90
      DO 70 J = 1,T
          IF (X(J+2)-Y(J+2)) 90,70,120
   70 CONTINUE
C RESULT IS ZERO
      Z(1) = 0
      RETURN
C HERE EXPONENT(Y) .GE. EXPONENT(X)
   80 IF (MED.GT.T) GO TO 10
   90 RS = Y1(1)
      RE = Y(2)
      CALL MPADD3(X,Y,S,MED,RE)
C NORMALIZE, ROUND OR TRUNCATE, AND RETURN
  100 CALL MPNZR(RS,RE,Z,TRUNC)
      RETURN
C ABS(X) .GT. ABS(Y)
  110 IF (MED.GT.T) GO TO 30
  120 RS = X(1)
      RE = X(2)
      CALL MPADD3(Y,X,S,MED,RE)
      GO TO 100

 9000 FORMAT (' *** SIGN NOT 0, +1 OR -1 IN CALL TO MPADD2,',' POSSIBL',
     +       'E OVERWRITING PROBLEM ***')
      END
C $$                   ******  MPADD3  ******
      SUBROUTINE MPADD3(X,Y,S,MED,RE)
C     MODIFIED FOR USE WITH BLAS.
C     COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12.
C CALLED BY MPADD2, DOES INNER LOOPS OF ADDITION
C     .. Scalar Arguments ..
      INTEGER MED,RE,S
C     ..
C     .. Array Arguments ..
      INTEGER X(*),Y(*)
C     ..
C     .. Scalars in Common ..
      INTEGER B,LUN,M,MXR,T
C     ..
C     .. Arrays in Common ..
      INTEGER R(12)
C     ..
C     .. Local Scalars ..
      INTEGER C,I,I2,I2P,J,TED
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/B,T,M,LUN,MXR,R
C     ..
      TED = T + MED
      I2 = T + 4
      I = I2
      C = 0
C CLEAR GUARD DIGITS TO RIGHT OF X DIGITS
   10 IF (I.LE.TED) GO TO 20
      R(I) = 0
      I = I - 1
      GO TO 10

   20 IF (S.LT.0) GO TO 130
C HERE DO ADDITION, EXPONENT(Y) .GE. EXPONENT(X)
      IF (I.LT.T) GO TO 40
   30 J = I - MED
      R(I) = X(J+2)
      I = I - 1
      IF (I.GT.T) GO TO 30
   40 IF (I.LE.MED) GO TO 60
      J = I - MED
      C = Y(I+2) + X(J+2) + C
      IF (C.LT.B) GO TO 50
C CARRY GENERATED HERE
      R(I) = C - B
      C = 1
      I = I - 1
      GO TO 40
C NO CARRY GENERATED HERE
   50 R(I) = C
      C = 0
      I = I - 1
      GO TO 40

   60 IF (I.LE.0) GO TO 90
      C = Y(I+2) + C
      IF (C.LT.B) GO TO 70
      R(I) = 0
      C = 1
      I = I - 1
      GO TO 60

   70 R(I) = C
      I = I - 1
C NO CARRY POSSIBLE HERE
   80 IF (I.LE.0) RETURN
      R(I) = Y(I+2)
      I = I - 1
      GO TO 80

   90 IF (C.EQ.0) RETURN
C MUST SHIFT RIGHT HERE AS CARRY OFF END
      I2P = I2 + 1
      DO 100 J = 2,I2
          I = I2P - J
          R(I+1) = R(I)
  100 CONTINUE
      R(1) = 1
      RE = RE + 1
      RETURN
C HERE DO SUBTRACTION, ABS(Y) .GT. ABS(X)
  110 J = I - MED
      R(I) = C - X(J+2)
      C = 0
      IF (R(I).GE.0) GO TO 120
C BORROW GENERATED HERE
      C = -1
      R(I) = R(I) + B
  120 I = I - 1
  130 IF (I.GT.T) GO TO 110
  140 IF (I.LE.MED) GO TO 160
      J = I - MED
      C = Y(I+2) + C - X(J+2)
      IF (C.GE.0) GO TO 150
C BORROW GENERATED HERE
      R(I) = C + B
      C = -1
      I = I - 1
      GO TO 140
C NO BORROW GENERATED HERE
  150 R(I) = C
      C = 0
      I = I - 1
      GO TO 140

  160 IF (I.LE.0) RETURN
      C = Y(I+2) + C
      IF (C.GE.0) GO TO 70
      R(I) = C + B
      C = -1
      I = I - 1
      GO TO 160

      END
C $$                   ******  MPCDM  ******
      SUBROUTINE MPCDM(DX,Z)
C     MODIFIED FOR USE WITH BLAS.
C     COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12.
C CONVERTS DOUBLE-PRECISION NUMBER DX TO MULTIPLE-PRECISION Z.
C SOME NUMBERS WILL NOT CONVERT EXACTLY ON MACHINES
C WITH BASE OTHER THAN TWO, FOUR OR SIXTEEN.
C THIS ROUTINE IS NOT CALLED BY ANY OTHER ROUTINE IN MP,
C SO MAY BE OMITTED IF DOUBLE-PRECISION IS NOT AVAILABLE.
C CHECK LEGALITY OF B, T, M, MXR AND LUN
C     .. Scalar Arguments ..
      DOUBLE PRECISION DX
C     ..
C     .. Array Arguments ..
      INTEGER Z(*)
C     ..
C     .. Scalars in Common ..
      INTEGER B,LUN,M,MXR,T
C     ..
C     .. Arrays in Common ..
      INTEGER R(12)
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION DB,DJ
      INTEGER I,I2,IB,IE,K,RE,RS,TP
C     ..
C     .. External Subroutines ..
      EXTERNAL MPCHK,MPDIVI,MPMULI,MPNZR
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC DBLE,FLOAT,IDINT,MAX0
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/B,T,M,LUN,MXR,R
C     ..
      CALL MPCHK(1,4)
      I2 = T + 4
C CHECK SIGN
      IF (DX) 20,10,30
C IF DX = 0D0 RETURN 0
   10 Z(1) = 0
      RETURN
C DX .LT. 0D0
   20 RS = -1
      DJ = -DX
      GO TO 40
C DX .GT. 0D0
   30 RS = 1
      DJ = DX
   40 IE = 0
   50 IF (DJ.LT.1D0) GO TO 60
C INCREASE IE AND DIVIDE DJ BY 16.
      IE = IE + 1
      DJ = 0.0625D0*DJ
      GO TO 50

   60 IF (DJ.GE.0.0625D0) GO TO 70
      IE = IE - 1
      DJ = 16D0*DJ
      GO TO 60
C NOW DJ IS DY DIVIDED BY SUITABLE POWER OF 16
C SET EXPONENT TO 0
   70 RE = 0
C DB = DFLOAT(B) IS NOT ANSI STANDARD SO USE FLOAT AND DBLE
      DB = DBLE(FLOAT(B))
C CONVERSION LOOP (ASSUME DOUBLE-PRECISION OPS. EXACT)
      DO 80 I = 1,I2
          DJ = DB*DJ
          R(I) = IDINT(DJ)
          DJ = DJ - DBLE(FLOAT(R(I)))
   80 CONTINUE
C NORMALIZE RESULT
      CALL MPNZR(RS,RE,Z,0)
      IB = MAX0(7*B*B,32767)/16
      TP = 1
C NOW MULTIPLY BY 16**IE
      IF (IE) 90,130,110
   90 K = -IE
      DO 100 I = 1,K
          TP = 16*TP
          IF ((TP.LE.IB) .AND. (TP.NE.B) .AND. (I.LT.K)) GO TO 100
          CALL MPDIVI(Z,TP,Z)
          TP = 1
  100 CONTINUE
      RETURN

  110 DO 120 I = 1,IE
          TP = 16*TP
          IF ((TP.LE.IB) .AND. (TP.NE.B) .AND. (I.LT.IE)) GO TO 120
          CALL MPMULI(Z,TP,Z)
          TP = 1
  120 CONTINUE
  130 RETURN

      END
C $$                   ******  MPCHK  ******
      SUBROUTINE MPCHK(I,J)
C     MODIFIED FOR USE WITH BLAS.
C     COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12.
C CHECKS LEGALITY OF B, T, M, MXR AND LUN WHICH SHOULD BE SET
C IN COMMON.
C THE CONDITION ON MXR (THE DIMENSION OF R IN COMMON) IS THAT
C MXR .GE. (I*T + J)
C FIRST CHECK THAT LUN IN RANGE 1 TO 99, IF NOT PRINT ERROR
C MESSAGE ON LOGICAL UNIT 6.
C     .. Scalar Arguments ..
      INTEGER I,J
C     ..
C     .. Scalars in Common ..
      INTEGER B,LUN,M,MXR,T
C     ..
C     .. Arrays in Common ..
      INTEGER R(12)
C     ..
C     .. Local Scalars ..
      INTEGER IB,MX
C     ..
C     .. External Subroutines ..
      EXTERNAL MPERR
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/B,T,M,LUN,MXR,R
C     ..
      IF ((0.LT.LUN) .AND. (LUN.LT.100)) GO TO 10
      WRITE (6,FMT=9000) LUN
      LUN = 6
      CALL MPERR
C NOW CHECK LEGALITY OF B, T AND M
   10 IF (B.GT.1) GO TO 20
      WRITE (LUN,FMT=9010) B
      CALL MPERR
   20 IF (T.GT.1) GO TO 30
      WRITE (LUN,FMT=9020) T
      CALL MPERR
   30 IF (M.GT.T) GO TO 40
      WRITE (LUN,FMT=9030)
      CALL MPERR
C 8*B*B-1 SHOULD BE REPRESENTABLE, IF NOT WILL OVERFLOW
C AND MAY BECOME NEGATIVE, SO CHECK FOR THIS
   40 IB = 4*B*B - 1
      IF ((IB.GT.0) .AND. ((2*IB+1).GT.0)) GO TO 50
      WRITE (LUN,FMT=9040)
      CALL MPERR
C CHECK THAT SPACE IN COMMON IS SUFFICIENT
   50 MX = I*T + J
      IF (MXR.GE.MX) RETURN
C HERE COMMON IS TOO SMALL, SO GIVE ERROR MESSAGE.
      WRITE (LUN,FMT=9050) I,J,MX,MXR,T
      CALL MPERR
      RETURN

 9000 FORMAT (' *** LUN =',I10,' ILLEGAL IN CALL TO MPCHK,',' PERHAPS ',
     +       'NOT SET BEFORE CALL TO AN MP ROUTINE ***')
 9010 FORMAT (' *** B =',I10,' ILLEGAL IN CALL TO MPCHK,',/' PERHAPS N',
     +       'OT SET BEFORE CALL TO AN MP ROUTINE ***')
 9020 FORMAT (' *** T =',I10,' ILLEGAL IN CALL TO MPCHK,',/' PERHAPS N',
     +       'OT SET BEFORE CALL TO AN MP ROUTINE ***')
 9030 FORMAT (' *** M .LE. T IN CALL TO MPCHK,',/' PERHAPS NOT SET BEF',
     +       'ORE CALL TO AN MP ROUTINE ***')
 9040 FORMAT (' *** B TOO LARGE IN CALL TO MPCHK ***')
 9050 FORMAT (' *** MXR TOO SMALL OR NOT SET TO DIM(R) BEFORE CALL',
     +       ' TO AN MP ROUTINE ***',/' *** MXR SHOULD BE AT LEAST',I3,
     +       '*T +',I4,' =',I6,'  ***',/' *** ACTUALLY MXR =',I10,', A',
     +       'ND T =',I10,'  ***')
      END
C $$                   ******  MPCMD  ******
      SUBROUTINE MPCMD(X,DZ)
C     MODIFIED FOR USE WITH BLAS.
C     COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12.
C CONVERTS MULTIPLE-PRECISION X TO DOUBLE-PRECISION DZ.
C ASSUMES X IS IN ALLOWABLE RANGE FOR DOUBLE-PRECISION
C NUMBERS.   THERE IS SOME LOSS OF ACCURACY IF THE
C EXPONENT IS LARGE.
C CHECK LEGALITY OF B, T, M, MXR AND LUN
C     .. Scalar Arguments ..
      DOUBLE PRECISION DZ
C     ..
C     .. Array Arguments ..
      INTEGER X(*)
C     ..
C     .. Scalars in Common ..
      INTEGER B,LUN,M,MXR,T
C     ..
C     .. Arrays in Common ..
      INTEGER R(12)
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION DB,DZ2
      INTEGER I,TM
C     ..
C     .. External Subroutines ..
      EXTERNAL MPCHK,MPERR
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC DABS,DBLE,DLOG,FLOAT
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/B,T,M,LUN,MXR,R
C     ..
      CALL MPCHK(1,4)
      DZ = 0D0
      IF (X(1).EQ.0) RETURN
C DB = DFLOAT(B) IS NOT ANSI STANDARD, SO USE FLOAT AND DBLE
      DB = DBLE(FLOAT(B))
      DO 10 I = 1,T
          DZ = DB*DZ + DBLE(FLOAT(X(I+2)))
          TM = I
C CHECK IF FULL DOUBLE-PRECISION ACCURACY ATTAINED
          DZ2 = DZ + 1D0
C TEST BELOW NOT ALWAYS EQUIVALENT TO - IF (DZ2.LE.DZ) GO TO 20,
C FOR EXAMPLE ON CYBER 76.
          IF ((DZ2-DZ).LE.0D0) GO TO 20
   10 CONTINUE
C NOW ALLOW FOR EXPONENT
   20 DZ = DZ* (DB** (X(2)-TM))
C CHECK REASONABLENESS OF RESULT.
      IF (DZ.LE.0D0) GO TO 30
C LHS SHOULD BE .LE. 0.5 BUT ALLOW FOR SOME ERROR IN DLOG
      IF (DABS(DBLE(FLOAT(X(2)))- (DLOG(DZ)/DLOG(DBLE(FLOAT(B)))+
     +    0.5D0)).GT.0.6D0) GO TO 30
      IF (X(1).LT.0) DZ = -DZ
      RETURN
C FOLLOWING MESSAGE INDICATES THAT X IS TOO LARGE OR SMALL -
C TRY USING MPCMDE INSTEAD.
   30 WRITE (LUN,FMT=9000)
      CALL MPERR
      RETURN

 9000 FORMAT (' *** FLOATING-POINT OVER/UNDER-FLOW IN MPCMD ***')
      END
C $$                   ******  MPDIVI  ******
      SUBROUTINE MPDIVI(X,IY,Z)

C     MODIFIED FOR USE WITH BLAS.
C     COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12.
C DIVIDES MP X BY THE SINGLE-PRECISION INTEGER IY GIVING MP Z.
C THIS IS MUCH FASTER THAN DIVISION BY AN MP NUMBER.
C     .. Scalar Arguments ..
      INTEGER IY
C     ..
C     .. Array Arguments ..
      INTEGER X(*),Z(*)
C     ..
C     .. Scalars in Common ..
      INTEGER B,LUN,M,MXR,T
C     ..
C     .. Arrays in Common ..
      INTEGER R(12)
C     ..
C     .. Local Scalars ..
      INTEGER B2,C,C2,I,I2,IQ,IQJ,IR,J,J1,J11,J2,K,KH,R1,RE,RS
C     ..
C     .. External Subroutines ..
      EXTERNAL MPCHK,MPERR,MPNZR,MPSTR,MPUNFL
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC MAX0
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/B,T,M,LUN,MXR,R
C     ..
      RS = X(1)
      J = IY
      IF (J) 20,10,30
   10 WRITE (LUN,FMT=9000)
      GO TO 210

   20 J = -J
      RS = -RS
   30 RE = X(2)
C CHECK FOR ZERO DIVIDEND
      IF (RS.EQ.0) GO TO 110
C CHECK FOR DIVISION BY B
      IF (J.NE.B) GO TO 40
      CALL MPSTR(X,Z)
      IF (RE.LE. (-M)) GO TO 220
      Z(1) = RS
      Z(2) = RE - 1
      RETURN
C CHECK FOR DIVISION BY 1 OR -1
   40 IF (J.NE.1) GO TO 50
      CALL MPSTR(X,Z)
      Z(1) = RS
      RETURN

   50 C = 0
      I2 = T + 4
      I = 0
C IF J*B NOT REPRESENTABLE AS AN INTEGER HAVE TO SIMULATE
C LONG DIVISION.   ASSUME AT LEAST 16-BIT WORD.
      B2 = MAX0(8*B,32767/B)
      IF (J.GE.B2) GO TO 120
C LOOK FOR FIRST NONZERO DIGIT IN QUOTIENT
   60 I = I + 1
      C = B*C
      IF (I.LE.T) C = C + X(I+2)
      R1 = C/J
      IF (R1) 200,60,70
C ADJUST EXPONENT AND GET T+4 DIGITS IN QUOTIENT
   70 RE = RE + 1 - I
      R(1) = R1
      C = B* (C-J*R1)
      KH = 2
      IF (I.GE.T) GO TO 90
      KH = 1 + T - I
      DO 80 K = 2,KH
          I = I + 1
          C = C + X(I+2)
          R(K) = C/J
          C = B* (C-J*R(K))
   80 CONTINUE
      IF (C.LT.0) GO TO 200
      KH = KH + 1
   90 DO 100 K = KH,I2
          R(K) = C/J
          C = B* (C-J*R(K))
  100 CONTINUE
      IF (C.LT.0) GO TO 200
C NORMALIZE AND ROUND RESULT
  110 CALL MPNZR(RS,RE,Z,0)
      RETURN
C HERE NEED SIMULATED DOUBLE-PRECISION DIVISION
  120 C2 = 0
      J1 = J/B
      J2 = J - J1*B
      J11 = J1 + 1
C LOOK FOR FIRST NONZERO DIGIT
  130 I = I + 1
      C = B*C + C2
      C2 = 0
      IF (I.LE.T) C2 = X(I+2)
      IF (C-J1) 130,140,150
  140 IF (C2.LT.J2) GO TO 130
C COMPUTE T+4 QUOTIENT DIGITS
  150 RE = RE + 1 - I
      K = 1
      GO TO 170
C MAIN LOOP FOR LARGE ABS(IY) CASE
  160 K = K + 1
      IF (K.GT.I2) GO TO 110
      I = I + 1
C GET APPROXIMATE QUOTIENT FIRST
  170 IR = C/J11
C NOW REDUCE SO OVERFLOW DOES NOT OCCUR
      IQ = C - IR*J1
      IF (IQ.LT.B2) GO TO 180
C HERE IQ*B WOULD POSSIBLY OVERFLOW SO INCREASE IR
      IR = IR + 1
      IQ = IQ - J1
  180 IQ = IQ*B - IR*J2
      IF (IQ.GE.0) GO TO 190
C HERE IQ NEGATIVE SO IR WAS TOO LARGE
      IR = IR - 1
      IQ = IQ + J
  190 IF (I.LE.T) IQ = IQ + X(I+2)
      IQJ = IQ/J
C R(K) = QUOTIENT, C = REMAINDER
      R(K) = IQJ + IR
      C = IQ - J*IQJ
      IF (C.GE.0) GO TO 160
C CARRY NEGATIVE SO OVERFLOW MUST HAVE OCCURRED
  200 CALL MPCHK(1,4)
      WRITE (LUN,FMT=9010)
  210 CALL MPERR
      Z(1) = 0
      RETURN
C UNDERFLOW HERE
  220 CALL MPUNFL(Z)
      RETURN

 9000 FORMAT (' *** ATTEMPTED DIVISION BY ZERO IN CALL TO MPDIVI ***')
 9010 FORMAT (' *** INTEGER OVERFLOW IN MPDIVI, B TOO LARGE ***')
      END
C $$                   ******  MPERR  ******
      SUBROUTINE MPERR
C     MODIFIED FOR USE WITH BLAS.
C     COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12.
C THIS ROUTINE IS CALLED WHEN A FATAL ERROR CONDITION IS
C ENCOUNTERED, AND AFTER A MESSAGE HAS BEEN WRITTEN ON
C LOGICAL UNIT LUN.
C     .. Scalars in Common ..
      INTEGER B,LUN,M,MXR,T
C     ..
C     .. Arrays in Common ..
      INTEGER R(12)
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/B,T,M,LUN,MXR,R
C     ..
      WRITE (LUN,FMT=9000)
C AT PRESENT JUST STOP, BUT COULD DUMP B, T, ETC. HERE.
C ACTION COULD EASILY BE CONTROLLED BY A FLAG IN LABELLED COMMON.
C ANSI VERSION USES STOP, UNIVAC 1108 VERSION USES
C RETURN 0 IN ORDER TO GIVE A TRACE-BACK.
C FOR DEBUGGING PURPOSES IT MAY BE USEFUL SIMPLY TO
C RETURN HERE.  MOST MP ROUTINES RETURN WITH RESULT
C ZERO AFTER CALLING MPERR.
      STOP

 9000 FORMAT (' *** EXECUTION TERMINATED BY CALL TO MPERR',' IN MP VER',
     +       'SION 770217 ***')
      END
C $$                   ******  MPMAXR  ******
      SUBROUTINE MPMAXR(X)
C     MODIFIED FOR USE WITH BLAS.
C     COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12.
C SETS X TO THE LARGEST POSSIBLE POSITIVE MP NUMBER
C CHECK LEGALITY OF B, T, M, MXR AND LUN
C     .. Array Arguments ..
      INTEGER X(*)
C     ..
C     .. Scalars in Common ..
      INTEGER B,LUN,M,MXR,T
C     ..
C     .. Arrays in Common ..
      INTEGER R(12)
C     ..
C     .. Local Scalars ..
      INTEGER I,IT
C     ..
C     .. External Subroutines ..
      EXTERNAL MPCHK
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/B,T,M,LUN,MXR,R
C     ..
      CALL MPCHK(1,4)
      IT = B - 1
C SET FRACTION DIGITS TO B-1
      DO 10 I = 1,T
          X(I+2) = IT
   10 CONTINUE
C SET SIGN AND EXPONENT
      X(1) = 1
      X(2) = M
      RETURN

      END
C $$                   ******  MPMUL  ******
      SUBROUTINE MPMUL(X,Y,Z)
C     MODIFIED FOR USE WITH BLAS.
C     COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12.
C MULTIPLIES X AND Y, RETURNING RESULT IN Z, FOR MP X, Y AND Z.
C THE SIMPLE O(T**2) ALGORITHM IS USED, WITH
C FOUR GUARD DIGITS AND R*-ROUNDING.
C ADVANTAGE IS TAKEN OF ZERO DIGITS IN X, BUT NOT IN Y.
C ASYMPTOTICALLY FASTER ALGORITHMS ARE KNOWN (SEE KNUTH,
C VOL. 2), BUT ARE DIFFICULT TO IMPLEMENT IN FORTRAN IN AN
C EFFICIENT AND MACHINE-INDEPENDENT MANNER.
C IN COMMENTS TO OTHER MP ROUTINES, M(T) IS THE TIME
C TO PERFORM T-DIGIT MP MULTIPLICATION.   THUS
C M(T) = O(T**2) WITH THE PRESENT VERSION OF MPMUL,
C BUT M(T) = O(T.LOG(T).LOG(LOG(T))) IS THEORETICALLY POSSIBLE.
C CHECK LEGALITY OF B, T, M, MXR AND LUN
C     .. Array Arguments ..
      INTEGER X(*),Y(*),Z(*)
C     ..
C     .. Scalars in Common ..
      INTEGER B,LUN,M,MXR,T
C     ..
C     .. Arrays in Common ..
      INTEGER R(12)
C     ..
C     .. Local Scalars ..
      INTEGER C,I,I2,I2P,J,J1,RE,RI,RS,XI
C     ..
C     .. External Subroutines ..
      EXTERNAL MPCHK,MPERR,MPMLP,MPNZR
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC MIN0
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/B,T,M,LUN,MXR,R
C     ..
      CALL MPCHK(1,4)
      I2 = T + 4
      I2P = I2 + 1
C FORM SIGN OF PRODUCT
      RS = X(1)*Y(1)
      IF (RS.NE.0) GO TO 10
C SET RESULT TO ZERO
      Z(1) = 0
      RETURN
C FORM EXPONENT OF PRODUCT
   10 RE = X(2) + Y(2)
C CLEAR ACCUMULATOR
      DO 20 I = 1,I2
          R(I) = 0
   20 CONTINUE
C PERFORM MULTIPLICATION
      C = 8
      DO 40 I = 1,T
          XI = X(I+2)
C FOR SPEED, PUT THE NUMBER WITH MANY ZEROS FIRST
          IF (XI.EQ.0) GO TO 40
          CALL MPMLP(R(I+1),Y(3),XI,MIN0(T,I2-I))
          C = C - 1
          IF (C.GT.0) GO TO 40
C CHECK FOR LEGAL BASE B DIGIT
          IF ((XI.LT.0) .OR. (XI.GE.B)) GO TO 80
C PROPAGATE CARRIES AT END AND EVERY EIGHTH TIME,
C FASTER THAN DOING IT EVERY TIME.
          DO 30 J = 1,I2
              J1 = I2P - J
              RI = R(J1) + C
              IF (RI.LT.0) GO TO 70
              C = RI/B
              R(J1) = RI - B*C
   30     CONTINUE
          IF (C.NE.0) GO TO 80
          C = 8
   40 CONTINUE
      IF (C.EQ.8) GO TO 60
      IF ((XI.LT.0) .OR. (XI.GE.B)) GO TO 80
      C = 0
      DO 50 J = 1,I2
          J1 = I2P - J
          RI = R(J1) + C
          IF (RI.LT.0) GO TO 70
          C = RI/B
          R(J1) = RI - B*C
   50 CONTINUE
      IF (C.NE.0) GO TO 80
C NORMALIZE AND ROUND RESULT
   60 CALL MPNZR(RS,RE,Z,0)
      RETURN

   70 WRITE (LUN,FMT=9000)
      GO TO 90

   80 WRITE (LUN,FMT=9010)
   90 CALL MPERR
      Z(1) = 0
      RETURN

 9000 FORMAT (' *** INTEGER OVERFLOW IN MPMUL, B TOO LARGE ***')
 9010 FORMAT (' *** ILLEGAL BASE B DIGIT IN CALL TO MPMUL,',' POSSIBLE',
     +       ' OVERWRITING PROBLEM ***')
      END
C $$                   ******  MPMUL2  ******
      SUBROUTINE MPMUL2(X,IY,Z,TRUNC)
C     MODIFIED FOR USE WITH BLAS.
C     COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12.
C MULTIPLIES MP X BY SINGLE-PRECISION INTEGER IY GIVING MP Z.
C MULTIPLICATION BY 1 MAY BE USED TO NORMALIZE A NUMBER
C EVEN IF SOME DIGITS ARE GREATER THAN B-1.
C RESULT IS ROUNDED IF TRUNC.EQ.0, OTHERWISE TRUNCATED.
C     .. Scalar Arguments ..
      INTEGER IY,TRUNC
C     ..
C     .. Array Arguments ..
      INTEGER X(*),Z(*)
C     ..
C     .. Scalars in Common ..
      INTEGER B,LUN,M,MXR,T
C     ..
C     .. Arrays in Common ..
      INTEGER R(12)
C     ..
C     .. Local Scalars ..
      INTEGER C,C1,C2,I,IJ,IS,IX,J,J1,J2,RE,RI,RS,T1,T3,T4
C     ..
C     .. External Subroutines ..
      EXTERNAL MPCHK,MPERR,MPNZR,MPOVFL,MPSTR
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC MAX0
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/B,T,M,LUN,MXR,R
C     ..
      RS = X(1)
      IF (RS.EQ.0) GO TO 10
      J = IY
      IF (J) 20,10,40
C RESULT ZERO
   10 Z(1) = 0
      RETURN

   20 J = -J
      RS = -RS
C CHECK FOR MULTIPLICATION BY B
      IF (J.NE.B) GO TO 40
      IF (X(2).LT.M) GO TO 30
      CALL MPCHK(1,4)
      WRITE (LUN,FMT=9000)
      CALL MPOVFL(Z)
      RETURN

   30 CALL MPSTR(X,Z)
      Z(1) = RS
      Z(2) = X(2) + 1
      RETURN
C SET EXPONENT TO EXPONENT(X) + 4
   40 RE = X(2) + 4
C FORM PRODUCT IN ACCUMULATOR
      C = 0
      T1 = T + 1
      T3 = T + 3
      T4 = T + 4
C IF J*B NOT REPRESENTABLE AS AN INTEGER WE HAVE TO SIMULATE
C DOUBLE-PRECISION MULTIPLICATION.
      IF (J.GE.MAX0(8*B,32767/B)) GO TO 100
      DO 50 IJ = 1,T
          I = T1 - IJ
          RI = J*X(I+2) + C
          C = RI/B
          R(I+4) = RI - B*C
   50 CONTINUE
C CHECK FOR INTEGER OVERFLOW
      IF (RI.LT.0) GO TO 120
C HAVE TO TREAT FIRST FOUR WORDS OF R SEPARATELY
      DO 60 IJ = 1,4
          I = 5 - IJ
          RI = C
          C = RI/B
          R(I) = RI - B*C
   60 CONTINUE
      IF (C.EQ.0) GO TO 90
C HAVE TO SHIFT RIGHT HERE AS CARRY OFF END
   70 DO 80 IJ = 1,T3
          I = T4 - IJ
          R(I+1) = R(I)
   80 CONTINUE
      RI = C
      C = RI/B
      R(1) = RI - B*C
      RE = RE + 1
      IF (C) 120,90,70
C NORMALIZE AND ROUND OR TRUNCATE RESULT
   90 CALL MPNZR(RS,RE,Z,TRUNC)
      RETURN
C HERE J IS TOO LARGE FOR SINGLE-PRECISION MULTIPLICATION
  100 J1 = J/B
      J2 = J - J1*B
C FORM PRODUCT
      DO 110 IJ = 1,T4
          C1 = C/B
          C2 = C - B*C1
          I = T1 - IJ
          IX = 0
          IF (I.GT.0) IX = X(I+2)
          RI = J2*IX + C2
          IS = RI/B
          C = J1*IX + C1 + IS
          R(I+4) = RI - B*IS
  110 CONTINUE
      IF (C) 120,90,70
C CAN ONLY GET HERE IF INTEGER OVERFLOW OCCURRED
  120 CALL MPCHK(1,4)
      WRITE (LUN,FMT=9010)
      CALL MPERR
      GO TO 10

 9000 FORMAT (' *** OVERFLOW OCCURRED IN MPMUL2 ***')
 9010 FORMAT (' *** INTEGER OVERFLOW IN MPMUL2, B TOO LARGE ***')
      END
C $$                   ******  MPNZR  ******
      SUBROUTINE MPNZR(RS,RE,Z,TRUNC)
C     MODIFIED FOR USE WITH BLAS.
C     COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12.
C ASSUMES LONG (I.E. (T+4)-DIGIT) FRACTION IN
C R, SIGN = RS, EXPONENT = RE.  NORMALIZES,
C AND RETURNS MP RESULT IN Z.  INTEGER ARGUMENTS RS AND RE
C ARE NOT PRESERVED. R*-ROUNDING IS USED IF TRUNC.EQ.0
C     .. Scalar Arguments ..
      INTEGER RE,RS,TRUNC
C     ..
C     .. Array Arguments ..
      INTEGER Z(*)
C     ..
C     .. Scalars in Common ..
      INTEGER B,LUN,M,MXR,T
C     ..
C     .. Arrays in Common ..
      INTEGER R(12)
C     ..
C     .. Local Scalars ..
      INTEGER B2,I,I2,I2M,I2P,IS,IT,J,K
C     ..
C     .. External Subroutines ..
      EXTERNAL MPERR,MPOVFL,MPUNFL
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC IABS,MOD
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/B,T,M,LUN,MXR,R
C     ..
      I2 = T + 4
      IF (RS.NE.0) GO TO 20
C STORE ZERO IN Z
   10 Z(1) = 0
      RETURN
C CHECK THAT SIGN = +-1
   20 IF (IABS(RS).LE.1) GO TO 30
      WRITE (LUN,FMT=9000)
      CALL MPERR
      GO TO 10
C LOOK FOR FIRST NONZERO DIGIT
   30 DO 40 I = 1,I2
          IS = I - 1
          IF (R(I).GT.0) GO TO 50
   40 CONTINUE
C FRACTION ZERO
      GO TO 10

   50 IF (IS.EQ.0) GO TO 80
C NORMALIZE
      RE = RE - IS
      I2M = I2 - IS
      DO 60 J = 1,I2M
          K = J + IS
          R(J) = R(K)
   60 CONTINUE
      I2P = I2M + 1
      DO 70 J = I2P,I2
          R(J) = 0
   70 CONTINUE
C CHECK TO SEE IF TRUNCATION IS DESIRED
   80 IF (TRUNC.NE.0) GO TO 140
C SEE IF ROUNDING NECESSARY
C TREAT EVEN AND ODD BASES DIFFERENTLY
      B2 = B/2
      IF ((2*B2).NE.B) GO TO 120
C B EVEN.  ROUND IF R(T+1).GE.B2 UNLESS R(T) ODD AND ALL ZEROS
C AFTER R(T+2).
      IF (R(T+1)-B2) 140,90,100
   90 IF (MOD(R(T),2).EQ.0) GO TO 100
      IF ((R(T+2)+R(T+3)+R(T+4)).EQ.0) GO TO 140
C ROUND
  100 DO 110 J = 1,T
          I = T + 1 - J
          R(I) = R(I) + 1
          IF (R(I).LT.B) GO TO 140
          R(I) = 0
  110 CONTINUE
C EXCEPTIONAL CASE, ROUNDED UP TO .10000...
      RE = RE + 1
      R(1) = 1
      GO TO 140
C ODD BASE, ROUND IF R(T+1)... .GT. 1/2
  120 DO 130 I = 1,4
          IT = T + I
          IF (R(IT)-B2) 140,130,100
  130 CONTINUE
C CHECK FOR OVERFLOW
  140 IF (RE.LE.M) GO TO 150
      WRITE (LUN,FMT=9010)
      CALL MPOVFL(Z)
      RETURN
C CHECK FOR UNDERFLOW
  150 IF (RE.LT. (-M)) GO TO 170
C STORE RESULT IN Z
      Z(1) = RS
      Z(2) = RE
      DO 160 I = 1,T
          Z(I+2) = R(I)
  160 CONTINUE
      RETURN
C UNDERFLOW HERE
  170 CALL MPUNFL(Z)
      RETURN

 9000 FORMAT (' *** SIGN NOT 0, +1 OR -1 IN CALL TO MPNZR,',' POSSIBLE',
     +       ' OVERWRITING PROBLEM ***')
 9010 FORMAT (' *** OVERFLOW OCCURRED IN MPNZR ***')
      END
C $$                   ******  MPOVFL  ******
      SUBROUTINE MPOVFL(X)
C     MODIFIED FOR USE WITH BLAS.
C     COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12.
C CALLED ON MULTIPLE-PRECISION OVERFLOW, IE WHEN THE
C EXPONENT OF MP NUMBER X WOULD EXCEED M.
C AT PRESENT EXECUTION IS TERMINATED WITH AN ERROR MESSAGE
C AFTER CALLING MPMAXR(X), BUT IT WOULD BE POSSIBLE TO RETURN,
C POSSIBLY UPDATING A COUNTER AND TERMINATING EXECUTION AFTER
C A PRESET NUMBER OF OVERFLOWS.  ACTION COULD EASILY BE DETERMINED
C BY A FLAG IN LABELLED COMMON.
C M MAY HAVE BEEN OVERWRITTEN, SO CHECK B, T, M ETC.
C     .. Array Arguments ..
      INTEGER X(*)
C     ..
C     .. Scalars in Common ..
      INTEGER B,LUN,M,MXR,T
C     ..
C     .. Arrays in Common ..
      INTEGER R(12)
C     ..
C     .. External Subroutines ..
      EXTERNAL MPCHK,MPERR,MPMAXR
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/B,T,M,LUN,MXR,R
C     ..
      CALL MPCHK(1,4)
C SET X TO LARGEST POSSIBLE POSITIVE NUMBER
      CALL MPMAXR(X)
      WRITE (LUN,FMT=9000)
C TERMINATE EXECUTION BY CALLING MPERR
      CALL MPERR
      RETURN

 9000 FORMAT (' *** CALL TO MPOVFL, MP OVERFLOW OCCURRED ***')
      END
C $$                   ******  MPSTR  ******
      SUBROUTINE MPSTR(X,Y)
C     MODIFIED FOR USE WITH BLAS.
C     COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12.
C SETS Y = X FOR MP X AND Y.
C SEE IF X AND Y HAVE THE SAME ADDRESS (THEY OFTEN DO)
C     .. Array Arguments ..
      INTEGER X(*),Y(*)
C     ..
C     .. Scalars in Common ..
      INTEGER B,LUN,M,MXR,T
C     ..
C     .. Arrays in Common ..
      INTEGER R(12)
C     ..
C     .. Local Scalars ..
      INTEGER I,J,T2
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/B,T,M,LUN,MXR,R
C     ..
      J = X(1)
      Y(1) = J + 1
      IF (J.EQ.X(1)) GO TO 10
C HERE X(1) AND Y(1) MUST HAVE THE SAME ADDRESS
      X(1) = J
      RETURN
C HERE X(1) AND Y(1) HAVE DIFFERENT ADDRESSES
   10 Y(1) = J
C NO NEED TO MOVE X(2), ... IF X(1) = 0
      IF (J.EQ.0) RETURN
      T2 = T + 2
      DO 20 I = 2,T2
          Y(I) = X(I)
   20 CONTINUE
      RETURN

      END
      DOUBLE PRECISION FUNCTION DQDOTA(N,DB,QC,DX,INCX,DY,INCY)

C     D.P. DOT PRODUCT WITH EXTENDED PRECISION ACCUMULATION (AND RESULT)
C     QC AND DQDOTA ARE SET = DB + QC + SUM FOR I = 0 TO N-1 OF
C       DX(LX+I*INCX) * DY(LY+I*INCY),  WHERE QC IS AN EXTENDED
C       PRECISION RESULT PREVIOUSLY COMPUTED BY DQDOTI OR DQDOTA
C       AND LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS
C       DEFINED IN A SIMILAR WAY USING INCY. THE MP PACKAGE BY
C       RICHARD P. BRENT IS USED FOR THE EXTENDED PRECISION ARITHMETIC.
C
C     FRED T. KROGH,  JPL,  1977,  JUNE 1
C2
C     THE COMMON BLOCK FOR THE MP PACKAGE (MODIFIED TO GIVE IT A NAME)
C     .. Scalar Arguments ..
      DOUBLE PRECISION DB
      INTEGER INCX,INCY,N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION DX(*),DY(*)
      INTEGER QC(10)
C     ..
C     .. Scalars in Common ..
      INTEGER MPB,MPLUN,MPM,MPMXR,MPT
C     ..
C     .. Arrays in Common ..
      INTEGER MPR(12)
C     ..
C     .. Local Scalars ..
      INTEGER I,I1,IX,IY
C     ..
C     .. Local Arrays ..
      INTEGER QX(10),QY(10)
C     ..
C     .. External Subroutines ..
      EXTERNAL MPADD,MPBLAS,MPCDM,MPCMD,MPMUL
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/MPB,MPT,MPM,MPLUN,MPMXR,MPR
C     ..
C     .. Data statements ..
      DATA I1/0/
C     ..
C     IF I1 IS 0 THE MP PACKAGE MUST BE INITIALIZED (MPBLAS SETS I1 = 1)
      IF (I1.EQ.0) CALL MPBLAS(I1)
      IF (DB.EQ.0.D0) GO TO 10
      CALL MPCDM(DB,QX)
      CALL MPADD(QC,QX,QC)
   10 IF (N.EQ.0) GO TO 30
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 20 I = 1,N
          CALL MPCDM(DX(IX),QX)
          CALL MPCDM(DY(IY),QY)
          CALL MPMUL(QX,QY,QX)
          CALL MPADD(QC,QX,QC)
          IX = IX + INCX
          IY = IY + INCY
   20 CONTINUE
   30 CALL MPCMD(QC,DQDOTA)
      RETURN

      END
      DOUBLE PRECISION FUNCTION DQDOTI(N,DB,QC,DX,INCX,DY,INCY)

C     D.P. DOT PRODUCT WITH EXTENDED PRECISION ACCUMULATION (AND RESULT)
C     QC AND DQDOTI ARE SET = DB + SUM FOR I = 0 TO N-1 OF
C       DX(LX+I*INCX) * DY(LY+I*INCY),  WHERE QC IS AN EXTENDED
C       PRECISION RESULT WHICH CAN BE USED AS INPUT TO DQDOTA,
C       AND LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS
C       DEFINED IN A SIMILAR WAY USING INCY. THE MP PACKAGE BY
C       RICHARD P. BRENT IS USED FOR THE EXTENDED PRECISION ARITHMETIC.
C
C     FRED T. KROGH,  JPL,  1977,  JUNE 1
C2
C     THE COMMON BLOCK FOR THE MP PACKAGE (MODIFIED TO GIVE IT A NAME)
C     .. Scalar Arguments ..
      DOUBLE PRECISION DB
      INTEGER INCX,INCY,N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION DX(*),DY(*)
      INTEGER QC(10)
C     ..
C     .. Scalars in Common ..
      INTEGER MPB,MPLUN,MPM,MPMXR,MPT
C     ..
C     .. Arrays in Common ..
      INTEGER MPR(12)
C     ..
C     .. Local Scalars ..
      INTEGER I,I1,IX,IY
C     ..
C     .. Local Arrays ..
      INTEGER QX(10),QY(10)
C     ..
C     .. External Subroutines ..
      EXTERNAL MPADD,MPBLAS,MPCDM,MPCMD,MPMUL
C     ..
C     .. Common blocks ..
      COMMON /MPCOM/MPB,MPT,MPM,MPLUN,MPMXR,MPR
C     ..
C     .. Data statements ..
      DATA I1/0/
C     ..
C     IF I1 IS 0 THE MP PACKAGE MUST BE INITIALIZED (MPBLAS SETS I1 = 1)
      IF (I1.EQ.0) CALL MPBLAS(I1)
      QC(1) = 0
      IF (DB.EQ.0.D0) GO TO 10
      CALL MPCDM(DB,QX)
      CALL MPADD(QC,QX,QC)
   10 IF (N.EQ.0) GO TO 30
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 20 I = 1,N
          CALL MPCDM(DX(IX),QX)
          CALL MPCDM(DY(IY),QY)
          CALL MPMUL(QX,QY,QX)
          CALL MPADD(QC,QX,QC)
          IX = IX + INCX
          IY = IY + INCY
   20 CONTINUE
   30 CALL MPCMD(QC,DQDOTI)
      RETURN

      END
