      SUBROUTINE SHEARD
C
C     THIS SUBROUTINE COMPUTES THE 12 X 12 STIFFNESS MATRIX FOR THE
C     SHEAR PANEL ELEMENT, AS WELL AS ITS DIAGONALIZED MASS MATRIX.
C
C     DOUBLE PRECISION VERSION
C
C     ECPT FOR THE SHEAR PANEL ELEMENT
C
C     ECPT( 1)  -  IELID          ELEMENT ID. NO.
C     ECPT( 2)  -  ISILNO(4)      SCALAR INDEX NUMBERS
C     ECPT( 3)  -   ...                   ...
C     ECPT( 4)  -   ...                   ...
C     ECPT( 5)  -   ...                   ...
C     ECPT( 6)  -  MATID          MATERIAL ID.
C     ECPT( 7)  -  T              THICKNESS
C     ECPT( 8)  -  FMU            NON-STRUCTURAL MASS
C     ECPT( 9)  -  ICSID1         COOR. SYS. ID. FOR GRID POINT 1
C     ECPT(10)  -  GP1(3)         BASIC COORDINATES FOR GRID POINT 1
C     ECPT(11)  -   ...                      ...
C     ECPT(12)  -   ...                      ...
C     ECPT(13)  -  ICSID2         COOR. SYS. ID. FOR GRID POINT 2
C     ECPT(14)  -  GP2(3)         BASIC COORDINATES FOR GRID POINT 2
C     ECPT(15)  -   ...                      ...
C     ECPT(16)  -   ...                      ...
C     ECPT(17)  -  ICSID3         COOR. SYS. ID. FOR GRID POINT 3
C     ECPT(18)  -  GP3(3)         BASIC COORDINATES FOR GRID POINT 3
C     ECPT(19)  -   ...                      ...
C     ECPT(20)  -   ...                      ...
C     ECPT(21)  -  ICSID4         COOR. SYS. ID. FOR GRID POINT 4
C     ECPT(22)  -  GP4(3)         BASIC COORDINATES FOR GRID POINT 4
C     ECPT(23)  -   ...                      ...
C     ECPT(24)  -   ...                      ...
C     ECPT(25)  -  TEMPEL         ELEMENT TEMPERATURE
C
      LOGICAL          IHEAT,NOGO
      INTEGER          IPART(4),DICT(11),ESTID
      REAL             NU
      DOUBLE PRECISION CEPX,CEPY,EP,ME(144),KOUT(144),MOUT(144),KE(144),
     1                 T,NUC,G,E,C23,VLEFT(6),VRIGHT(6),TI(9),P(4),X1,
     2                 Y1,X2,Y2,X3,Y3,X4,Y4,CEP1,CEP2,TEMP,YP,XP,SA,A,B,
     3                 C,D,TERM,TERM1,TERM2,TERM3,TERM4,TERM5,F,XL13,
     4                 XL24,CON,Z,XL,VD1(3),VD2(3),VKN(3),VK(3),V12(3),
     5                 V41(3),VP12(3),VI(3),VJ(3),AVEC(4),SMALLU(4),
     6                 SMALLV(4),A2,A3,A4,A5,B2,B3,B4,B5,C2,C3,C4,C5,
     7                 D2,D3,D4,D5
      DIMENSION        IECPT(100),ECPT(100)
      COMMON /SYSTEM/  KSYSTM(55),IHEAT
      COMMON /EMGPRM/  IXR,JCORE,NCORE,DUM(12),ISMB(3),IPREC,NOGO,HEAT
      COMMON /EMGDIC/  IDM, LDICT,NGRIDS,ELID,ESTID
      COMMON /EMGEST/  IELID,ISILNO(4),MATID,TSP,FMU,ICSID1,GP1(3),
     1                 ICSID2,GP2(3),ICSID3,GP3(3),ICSID4,GP4(3),TEMPEL
C
C     INPUT AND OUTPUT BLOCKS FOR SUBROUTINE MAT
C
      COMMON /MATOUT/  ESP,GSP,NU,RHO,ALPHA,TSUB0,GSUBE,SIGT,SIGC,SIGS
      COMMON /MATIN /  MATIDC,MATFLG,ELTEMP,STRESS,SINTH,COSTH
      EQUIVALENCE      (ME(1),KE(1)),(KOUT(1),MOUT(1)),
     1                 (IECPT(1),ECPT(1),IELID),(DICT(5),DICT5)
      DATA    IPART /  1,2,3,4 /
C
      NGRIDS = 4
      LDICT  = 5 + NGRIDS
C
C     IF STIFFNESS MATRIX NOT NEEDED GO TO PERFORM MASS CALCULATIONS
C
      IF (ISMB(1) .EQ. 0) GO TO 400
C
      DICT(1) = ESTID
      DICT(2) = 1
      DICT(3) = 12
      DICT(4) = 7
      IP      = IPREC
      ISORT   = 0
C
C     CALL MAT TO GET MATERIAL PROPERTIES.
C
      MATIDC = MATID
      MATFLG = 1
      ELTEMP = TEMPEL
      CALL MAT (IECPT(1))
      DICT5  = GSUBE
C
      T   = TSP
      G   = GSP
      E   = ESP
      IF (T*G .EQ. 0.0) GO TO 7770
      C23 = 2.D0/3.D0
      NUC = 1.D0/(1.D0+NU)
C
C     COMPUTE DIAGONAL VECTORS.
C
      DO 10 I = 1,3
      VD1(I) = GP3(I) - GP1(I)
   10 VD2(I) = GP4(I) - GP2(I)
C
C     COMPUTE THE NORMAL VECTOR VKN, NORMALIZE, AND COMPUTE THE
C     PROJECTED AREA, PA
C
      VKN(1) = VD1(2)*VD2(3) - VD1(3)*VD2(2)
      VKN(2) = VD1(3)*VD2(1) - VD1(1)*VD2(3)
      VKN(3) = VD1(1)*VD2(2) - VD1(2)*VD2(1)
      VKL    = DSQRT(VKN(1)**2 + VKN(2)**2  + VKN(3)**2)
      IF (VKL .EQ. 0.) GO TO 7770
      VK(1)  = VKN(1)/VKL
      VK(2)  = VKN(2)/VKL
      VK(3)  = VKN(3)/VKL
      PA     = VKL/2.
C
C     COMPUTE  SIDES -12- AND -41-
C
      DO 20 I = 1,3
      V12(I) = GP2(I) - GP1(I)
   20 V41(I) = GP1(I) - GP4(I)
C
C     COMPUTE DOT PRODUCT, V12DK, OF V12 AND VK, THE VECTORS VP12, VI,
C     VJ
C
      V12DK   = V12(1)*VK(1) + V12(2)*VK(2) + V12(3)*VK(3)
      VP12(1) = V12(1) - V12DK*VK(1)
      VP12(2) = V12(2) - V12DK*VK(2)
      VP12(3) = V12(3) - V12DK*VK(3)
      VP12L   = DSQRT(VP12(1)**2 + VP12(2)**2 + VP12(3)**2)
      IF (VP12L .EQ. 0.) GO TO 7770
      VI(1) = VP12(1)/VP12L
      VI(2) = VP12(2)/VP12L
      VI(3) = VP12(3)/VP12L
      VJ(1) = VK(2)*VI(3) - VK(3)*VI(2)
      VJ(2) = VK(3)*VI(1) - VK(1)*VI(3)
      VJ(3) = VK(1)*VI(2) - VK(2)*VI(1)
C
C     NORMALIZE J FOR GOOD MEASURE
C
      VJL = DSQRT(VJ(1)**2 + VJ(2)**2 + VJ(3)**2)
      IF (VJL .EQ. 0.) GO TO 7770
      VJ(1) = VJ(1)/VJL
      VJ(2) = VJ(2)/VJL
      VJ(3) = VJ(3)/VJL
      X1 = 0.
      Y1 = 0.
      X2 = VP12L
      Y2 = 0.
      X3 = VI(1)*VD1(1) + VI(2)*VD1(2) + VI(3)*VD1(3)
      Y3 = VJ(1)*VD1(1) + VJ(2)*VD1(2) + VJ(3)*VD1(3)
      X4 =-VI(1)*V41(1) - VI(2)*V41(2) - VI(3)*V41(3)
      Y4 =-VJ(1)*V41(1) - VJ(2)*V41(2) - VJ(3)*V41(3)
C
C     CHECK TO SEE IF INTERIOR ANGLES ARE LESS THAN 180 DEGREES. IF NOT,
C     CALL FATAL ERROR MESSAGE.
C
      IF (Y3 .LE. 0.) GO TO 7780
      IF (Y4 .LE. 0.) GO TO 7800
      IF (X3 .LE. Y3*X4/Y4) GO TO 7790
      IF (X4 .GE. X2-(X2-X3)*Y4/Y3) GO TO 7810
C
C     TEST FOR PARALLEL EFFECTS.
C
      CEP1 = DABS(Y3-Y4)
      CEPX = DABS(X3-X4)
      TEMP = X3 - X2
      CEP2 = DABS(Y4*TEMP-Y3*X4)
      CEPY = DABS(X4*TEMP+Y4*Y3)
      EP   = 0.01D0
      IF (CEP1 .LT. EP*CEPX) GO TO 30
      IF (CEP2 .LT. EP*CEPY) GO TO 40
      GO TO 70
   30 IF (CEP2 .LT. EP*CEPY) GO TO 50
C
C     AT THIS POINT THE LINE CONNECTING POINTS 3 AND 4 IS -PARALLEL- TO
C     THE LINE CONNECTING POINTS 1 AND 2.
C
      TEMP = Y3*X4 - Y4*(X3-X2)
      YP   = X2*Y3*Y4/TEMP
      P(1) = YP - Y1
      P(2) = YP - Y2
      P(3) = YP - Y3
      P(4) = YP - Y4
      XP   = X2*Y3*X4/TEMP
      SA   = (X2 - XP)/YP
      C    = (X1 - XP)/YP
      Z    = ((P(1)*P(2)*PA)/(P(3)*P(4)*2.*G*T))*(1.+C23*NUC*
     X       (SA**2+SA*C+C**2))
      GO TO 80
C
C     AT THIS POINT THE LINE CONNECTING POINTS 1 AND 4 IS -PARALLEL- TO
C     THE LINE CONNECTING POINTS 2 AND 3.
C
   40 D    = -.5*(X4/Y4 + (X3-X2)/Y3)
      XQ   = X4 - Y4*(X3-X4)/(Y3-Y4)
      TEMP = 1.D0/DSQRT(1.D0+D**2)
      P(1) = (XQ-X1-D*Y1)*TEMP
      P(2) = (XQ-X2-D*Y2)*TEMP
      P(3) = (XQ-X3-D*Y3)*TEMP
      P(4) = (XQ-X4-D*Y4)*TEMP
      TEMP = XQ - X4
      B    = (TEMP*D+Y4)/(TEMP-Y4*D)
      Z    = ((P(1)*P(2)*PA)/(P(3)*P(4)*2.*G*T))*(1.+C23*NUC*(B**2+B*D
     1     + D**2))
      GO TO 80
C
C     IN THIS CASE THE PANEL APPROXIMATES A PARALLELOGRAM.
C
   50 DO 60 I = 1,4
   60 P(I) = 1.
      D = -.5D0*(X4/Y4+(X3-X2)/Y3+(Y3-Y4)/(X3-X4))
      Z = PA/(2.*G*T)*(1.+2.*D**2*NUC)
      GO TO 80
C
C     IN THIS CASE NO PARALLEL EFFECTS EXIST.
C
   70 XQ   = X4 - (X3-X4)/(Y3-Y4)*Y4
      TEMP = Y3*X4 - Y4*(X3-X2)
      XP   = X2*Y3*X4/TEMP
      YP   = X2*Y3*Y4/TEMP
      XL   = DSQRT((XQ-XP)**2 + YP**2)
      D    = (XQ-XP)/YP
      TEMP = YP/XL
      P(1) = TEMP*(XQ-X1-D*Y1)
      P(2) = TEMP*(XQ-X2-D*Y2)
      P(3) = TEMP*(XQ-X3-D*Y3)
      P(4) = TEMP*(XQ-X4-D*Y4)
      C    = XL/P(1) - D
      B    = XL/P(4) - C
      A    = XL/P(2) - D
      A2   = A**2
      B2   = B**2
      C2   = C**2
      D2   = D**2
      A3   = A2*A
      B3   = B2*B
      C3   = C2*C
      D3   = D2*D
      A4   = A3*A
      B4   = B3*B
      C4   = C3*C
      D4   = D3*D
      A5   = A4*A
      B5   = B4*B
      C5   = C4*C
      D5   = D4*D
      TEMP = .5D0*P(1)*P(2)*P(3)*P(4)/XL**2
      TERM = (A + B + C23*(A3+B3) + .2D0*(A5+B5))*DLOG(DABS(A+B))
      TERM1= (C + D + C23*(C3+D3) + .2D0*(C5+D5))*DLOG(DABS(C+D))
      TERM2= (B + C + C23*(B3+C3) + .2D0*(B5+C5))*DLOG(DABS(B+C))
      TERM3= (D + A + C23*(D3+A3) + .2D0*(D5+A5))*DLOG(DABS(D+A))
      TERM4= .1D0*((A2-C2)*(B3-D3)+ (B2-D2)*(A3-C3))
      TERM5= .2D0*((A-C)*(B4-D4) + (B-D)*(A4-C4))
      F    = TEMP*(TERM+TERM1-TERM2-TERM3+TERM4-TERM5)
      Z    = P(1)*P(2)/(P(3)*P(4)*2.*G*T)*(PA+4.*NUC*(F-C23*PA))
   80 XL13 = DSQRT(X3**2 + Y3**2)
      XL24 = DSQRT((X4-X2)**2 + Y4**2)
      SMALLU(1) = X3/XL13
      SMALLU(2) = (X4-X2)/XL24
      SMALLU(3) = SMALLU(1)
      SMALLU(4) = SMALLU(2)
      SMALLV(1) = Y3/XL13
      SMALLV(2) = Y4/XL24
      SMALLV(3) = SMALLV(1)
      SMALLV(4) = SMALLV(2)
      TEMP    = X4*Y3 - X3*Y4
      AVEC(1) = -.5*X2*Y4*XL13/TEMP
      AVEC(2) =  .5*X2*Y3 *XL24/(TEMP -X2*(Y3-Y4))
      AVEC(3) = -AVEC(1)
      AVEC(4) = -AVEC(2)
C
      DO 90 I = 1,144
   90 KE(I) = 0.
      DO 230 IPVT = 1,4
      CON = AVEC(IPVT)/(2.*Z)
C
C     COMPUTE THE -VLEFT- VECTOR
C
      IVLBEG = 1
      VLEFT(1) = VI(1)*SMALLU(IPVT) + VJ(1)*SMALLV(IPVT)
      VLEFT(2) = VI(2)*SMALLU(IPVT) + VJ(2)*SMALLV(IPVT)
      VLEFT(3) = VI(3)*SMALLU(IPVT) + VJ(3)*SMALLV(IPVT)
      IF (IECPT(4*IPVT+5) .EQ. 0) GO TO 150
      CALL TRANSD (IECPT(4*IPVT+5),TI)
      IVLBEG = 4
      CALL GMMATD (TI,3,3,1, VLEFT(1),3,1,0, VLEFT(4))
C
C     COMPUTE THE 6 X 6 -S
C
  150 DO 220 J = 1,4
      IVRBEG = 1
      VRIGHT(1) = SMALLU(J)*VI(1) + SMALLV(J)*VJ(1)
      VRIGHT(2) = SMALLU(J)*VI(2) + SMALLV(J)*VJ(2)
      VRIGHT(3) = SMALLU(J)*VI(3) + SMALLV(J)*VJ(3)
      IF (IECPT(4*J+5) .EQ. 0) GO TO 170
      CALL TRANSD (IECPT(4*J+5),TI)
      CALL GMMATD (VRIGHT(1),1,3,0, TI,3,3,0, VRIGHT(4))
      IVRBEG = 4
170   JT = (IPVT-1)*36 + (J-1)*9 + 1
      CALL GMMATD (VLEFT(IVLBEG),3,1,0, VRIGHT(IVRBEG),1,3,0, KE(JT))
      JT8 = JT + 8
      DO 180 K = JT,JT8
  180 KE(K) = CON*KE(K)*AVEC(J)
 220  CONTINUE
 230  CONTINUE
C
C     NOW REARRANGE KE BY INCREASING SIL THEN OUTPUT IT VIA EMGOUT
C     FIRST DETERMINE WHAT INCREASING SIL ORDER WILL BE
C
      ASSIGN 290 TO K OR M
  275 CONTINUE
      DO 280 I = 1,3
      IP1 = I + 1
      IT  = IPART(I)
      DO 270 J = IP1,4
      JT = IPART(J)
      IF (ISILNO(IT) .LE. ISILNO(JT)) GO TO 270
      IPART(I) = JT
      IPART(J) = IT
      IT = JT
      GO TO 275
 270  CONTINUE
 280  CONTINUE
      ISORT = 1
      GO TO KORM, (290,420)
C
C     NOW REARRANGE TERMS IN THE STIFFNESS MATRIX KE AND STORE IN KOUT
C
C     KE = (K  ,K  ,K  ,K  ,K  ,...,K  ,K  ,...,K  )
C            11  12  13  14  21      24  31      44
C
C     WHERE  K  IS A 3X3 SUBMATRIX AND  SILS ARE IN GRID POINT ORDER
C             IJ
C
C     AND    *****                  ****
C            * K     K     K     K     *
C            *  L1L1  L1L2  L1L3  L1L4 *
C            *                         *
C            * K     K     K     K     *
C     KOUT = *  L2L1  L2L2  L2L3  L2L4 *
C            *                         *
C            * K     K     K     K     *
C            *  L3L1  L3L2  L3L3  L3L4 *
C            *                         *
C            * K     K     K     K     *
C            *  L4L1  L4L2  L4L3  L4L4 *
C            ****                   ****
C
C     WHERE  KOUT     IS A   3X3    MATRIX AND SILS ARE IN INCREASING
C                LILJ
C     ORDER
C
 290  CONTINUE
      DO 300 I = 1,4
      IS = IPART(I)
      DO 300 J = 1,4
      JS = IPART(J)
      DO 300 K = 1,3
      DO 300 L = 1,3
      IOUT = (I -1)*36 + (J -1)*3 + (K-1)*12 + L
      IKE  = (IS-1)*36 + (JS-1)*9 + (K-1)* 3 + L
  300 KOUT(IOUT) = KE(IKE)
C
C     OUTPUT THE STIFFNESS MATRIX
C
      CALL EMGOUT (KOUT,KOUT,144,1,DICT,1,IP)
C
C     HERE WE CALCULATE THE MASS MATRIX VIA SUBROUTINE EMASTQ
C
C
  400 IF (ISMB(2) .EQ. 0) RETURN
C
      CALL EMADTQ (6,ME)
      IF (ISORT .EQ. 1) GO TO 420
      ASSIGN 420 TO KORM
      GO TO 275
C
C     RETURN WITH A GRID POINT SORT ARRAY IN IPART
C
  420 DO 440 I = 1,4
      IT = 1 + (IPART(I)-1)*3
      IJ = (I-1)*3 + 1
      MOUT(IJ  ) = ME(IT  )
      MOUT(IJ+1) = ME(IT+1)
  440 MOUT(IJ+2) = ME(IT+2)
C
      DICT(1) = ESTID
      DICT(2) = 2
      DICT(3) = 12
      DICT(4) =  7
      DICT5   = 0.
C
      CALL  EMGOUT (KOUT,KOUT,12,1,DICT,2,IP)
      RETURN
C
C     ERROR EXITS
C
 7770 CALL MESAGE (30,26,IECPT(1))
 7777 NOGO = .TRUE.
      RETURN
C
 7780 IECPT(2) = 2
      GO TO 7820
 7790 IECPT(2) = 4
      GO TO 7820
 7800 IECPT(2) = 1
      GO TO 7820
 7810 IECPT(2) = 3
 7820 CALL MESAGE (30,27,IECPT(1))
      GO TO 7777
      END


! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
MODULE CubatureRule_Tn
USE Precision_Model
IMPLICIT NONE

PRIVATE

PUBLIC :: Rule_Tn
PRIVATE :: RuleParms_Tn, SymSmp_Sum

CONTAINS
   SUBROUTINE Rule_Tn( TUNE, NDIM, VERTEX, VOLUME, NF, Integrand,             &
                       INKEY, BASVAL, RGNERR, FVALT )
!***BEGIN PROLOGUE Rule_Tn
!***KEYWORDS basic numerical integration rule
!***PURPOSE  To compute basic integration rule values.
!***LAST MODIFICATION BY ORIGINAL AUTHOR 02-07-09
!***AUTHOR
!
!            Alan Genz
!            Department of Mathematics
!            Washington State University
!            Pullman, WA 99164-3113, USA
!            AlanGenz@wsu.edu
!
!***REVISION DATE  150729   (YYMMDD) (Made threadsafe / re-entrant)
!***MODIFIER
!          Pat Scott, Dept. of Physics, Imperial College London
!          Email: p.scott@imperial
!***DESCRIPTION Rule_Tn computes basic integration rule values for a
!            vector of integrands over a hyper-rectangular region.
!            These are estimates for the integrals. Rule_Tn also computes
!            estimates for the errors.
!
!   ON ENTRY
!
!     TUNE   Real, tuning parameter.
!     NDIM   Integer, number of variables.
!     VERTEX Real array of dimension (NDIM,0:NDIM).
!            The simplex vertices; vertex J must have components
!            VERTEX(I,J), I = 1, 2, ..., NDIM.
!     VOLUME Real, volume of simplex.
!     NF     Integer, number of components for the vector integrand.
!  Integrand Real vector function of length NF for computing components of
!            the integrand at Z.
!            It must have parameters ( NF, Z ); see interface below
!            Input parameters:
!              Z      Real array of length NDIM, the evaluation point.
!              NF     Integer number of components of Integrand.
!     INKEY  Integer rule parameter.
!            If INKEY > 0 and INKEY < 5 then a rule of degree 2*INKEY + 1
!            is used; otherwise a default rule of degree 7 is used.
!
!   ON RETURN
!
!     BASVAL Real array of length NF, values for the basic rule for
!            each component of the integrand.
!     RGNERR Real array of length NF, error estimates for BASVAL.
!     FVALT  Integer, number of integrand values USEd by Rule_Tn.
!
!
!***ROUTINES CALLED: RuleParms_Tn, SymSmp_Sum
!
!***END PROLOGUE Rule_Tn
!
!   Global variables.
!
      INTEGER,                             INTENT(IN)  :: NF, NDIM, INKEY
      INTEGER,                             INTENT(OUT) :: FVALT
      INTERFACE
         FUNCTION Integrand(NF,X) RESULT(Value)
            USE Precision_Model
            INTEGER,                       INTENT(IN)  :: NF
            REAL(KIND=STND), DIMENSION(:), INTENT(IN)  :: X
            REAL(KIND=STND), DIMENSION(NF)             :: Value
         END FUNCTION Integrand
      END INTERFACE
      REAL(KIND=STND), DIMENSION(:,0:),    INTENT(IN)  :: VERTEX
      REAL(KIND=STND),                     INTENT(IN)  :: VOLUME, TUNE
      REAL(KIND=STND), DIMENSION(:),       INTENT(OUT) :: BASVAL, RGNERR
!
!   Local variables.
!
!   WTS    Integer number of weights in the integration rules.
!   W      Real array of dimension (WTS,RLS).
!          The weights for the basic and null rules.
!          W(1,1),...,W(WTS,1) are weights for the basic rule.
!          W(1,I),...,W(WTS,I), for I > 1 are null rule weights.
!   G      Real array of dimension (0:NDIM, WTS).
!          The fully symmetric sum generators for the rules.
!          G(0, J), ..., G(NDIM, J) are the are the generators for the
!          points associated with the Jth weights.
!   X      Real work array of length NDIM.
!   GT     Real work array of length 0:NDIM.
!   RULE   Real work array of dimension (NF,MXRLS).
!   ERROR  Real work array of length NF.
!   RATIO  Real work array of length NF.
!
      INTEGER, PARAMETER                      :: MXW = 21, MXRLS = 7, MXG = 4
      REAL(KIND=STND), PARAMETER                  :: ONE = 1
      REAL(KIND=STND), PARAMETER                  :: SMALL = 100*EPSILON(ONE)
      INTEGER, SAVE                               :: OLDKEY = -1, OLDN = 0
      INTEGER, SAVE                               :: RLS, WTS, KEY, FVALS
      INTEGER, DIMENSION(MXW), SAVE               :: PTS
      REAL(KIND=STND), DIMENSION(MXW,MXRLS), SAVE :: W
      REAL(KIND=STND), DIMENSION(0:MXG,MXW), SAVE :: G
!$omp threadprivate(OLDKEY, OLDN, RLS, WTS, KEY, FVALS, PTS, W, G)
      REAL(KIND=STND), DIMENSION(NF,MXRLS)        :: RULE
      REAL(KIND=STND), DIMENSION(MXRLS)           :: ALPHA
      REAL(KIND=STND), DIMENSION(0:NDIM)          :: GTEMP
      REAL(KIND=STND), DIMENSION(NF)              :: RATIO
      REAL(KIND=STND)                             :: NORMCF, NORMNL, ERRCOF
      INTEGER                                     :: K
!
!***FIRST PROCESSING STATEMENT Rule_Tn
!
      IF ( OLDKEY /= INKEY .OR. OLDN /= NDIM ) THEN
         OLDN = NDIM
         OLDKEY = INKEY
         IF ( INKEY > 0 .AND. INKEY < 5 ) THEN
            KEY = INKEY
         ELSE
            KEY = 3
         END IF
!
!        Compute WTS, RLS, weights, generators, ERRCOF and PTS.
!
         CALL RuleParms_Tn( NDIM, KEY, W, G, WTS, RLS, PTS )
!
!        Orthogonalize and normalize null rules.
!
         NORMCF = DOT_PRODUCT( PTS(1:WTS)*W(1:WTS,1), W(1:WTS,1) )
         DO K = 2, RLS
            ALPHA(2:K-1) = -MATMUL( TRANSPOSE(W(:,2:K-1)), PTS*W(:,K) )
            W(:,K) = W(:,K) + MATMUL( W(:,2:K-1), ALPHA(2:K-1) )/NORMCF
            NORMNL = DOT_PRODUCT( PTS*W(:,K), W(:,K) )
            W(:,K) = W(:,K)*SQRT( NORMCF/NORMNL )
         END DO
         FVALS = SUM( PTS(1:WTS) )
      END IF
!
!     Compute the rule values.
!
      RULE = 0
      DO K = 1, WTS
         IF ( PTS(K) > 0 ) THEN
            GTEMP( 0: MIN(NDIM,MXG-1) ) = G( 0: MIN(NDIM,MXG-1) , K )
            IF ( NDIM >= MXG ) THEN
               GTEMP(MXG:NDIM) = G(MXG,K)
            END IF
            BASVAL = SymSmp_Sum( NDIM, VERTEX, NF, Integrand, GTEMP )
            RULE = RULE + MATMUL( RESHAPE( BASVAL, (/ NF, 1 /) ), W(K:K,:) )
         END IF
      END DO
      BASVAL = RULE(:,1)
!
!     Scale integral values and compute the error estimates.
!
      ERRCOF = 7*TUNE + 1
      RATIO = 0
      RULE(:,RLS) = MAX ( ABS(RULE(:,RLS)) , ABS(RULE(:,RLS-1)) )
      RGNERR = RULE(:,RLS)
      IF ( KEY > 1 ) THEN
         DO K = RLS-2, 3, -2
            RULE(:,K) = MAX( ABS(RULE(:,K  )) , ABS(RULE(:,K-1)) )
            WHERE ( ABS(BASVAL) + RULE(:,K)/(100*KEY) > ABS(BASVAL) )
               RATIO = MAX( RULE(:,K)/RULE(:,K+2), RATIO )
            END WHERE
            RGNERR = MAX( RULE(:,K), RGNERR )
         END DO
         RATIO = MAX( ONE/10, RATIO )
         WHERE ( RATIO >= 1 )
            RGNERR = TUNE*RGNERR + ( 1 - TUNE )*RULE(:,3)
         ELSEWHERE
            RGNERR = RATIO*RULE(:,3)
         END WHERE
      END IF
      RGNERR = VOLUME*MAX( ERRCOF*RGNERR, SMALL*ABS( BASVAL ) )
      BASVAL = VOLUME*BASVAL
      FVALT = FVALS
      RETURN
!
!***END Rule_Tn
!
   END Subroutine Rule_Tn
!
   SUBROUTINE RuleParms_Tn( NDIM, KEY, W, G, WTS, RLS, PTS )
!
!***BEGIN PROLOGUE RuleParms_Tn
!***KEYWORDS basic integration rule, degree 2*KEY+1
!***PURPOSE  To initialize a degree 2*KEY+1 basic rule and null rules.
!***AUTHOR
!
!            Alan Genz
!            Department of Mathematics
!            Washington State University
!            Pullman, WA 99164-3113, USA
!            AlanGenz@wsu.edu
!
!            Ronald Cools, Dept. of Computer Science,
!            Katholieke Universiteit Leuven, Celestijnenlaan 200A,
!            B-3001 Heverlee, Belgium
!            Email:  Ronald.Cools@cs.kuleuven.ac.be
!
!***LAST MODIFICATION by Alan 99-05
!***LAST MODIFICATION by Ronald 01-07-19 (cleaning code)
!***DESCRIPTION  RuleParms_Tn initializes a degree 2*KEY+1 rule, and
!                and max(2*KEY,2) lower degree null rules.
!
!   ON ENTRY
!
!   NDIM    Integer, number of variables.
!   KEY    Integer,  < 5 and >= 0, rule parameter.
!          If KEY > 0 a degree 2*KEY+1 rule is initialized.
!          If KEY = 0 a degree 7 rule is initialized.
!
!   ON RETURN
!   RLS    Integer, total number of rules.
!   WTS    Integer, total number of weights in each of the rules.
!   W      Real array of dimension (MXW,*).
!          The weights for the basic and null rules.
!          W(1,1),...,W(WTS,1) are weights for the basic rule.
!          W(I,1),...,W(WTS,I) for I > 1 are null rule weights.
!   G      Real array of dimension (0:MXG,MXW).
!          The fully symmetric sum generators for the rules.
!          G(0,J), ..., G(MXG,J) are the generators for the
!          points associated with the Jth weights.
!   PTS    Integer array of length (MXW). PTS(J) is the number of integrand
!          values needed for generator J.
!
!***REFERENCES
!
!  Axel Grundmann and H. M. Moller
!  "Invariant Integration Formulas for the n-Simplex by Combinatorial Methods",
!   SIAM J Numer. Anal. 15(1978), 282--290,
! and
!  A. H. Stroud
!  "A Fifth Degree Integration Formula for the n-Simplex
!  SIAM J Numer. Anal. 6(1969), 90--98,
! and
!  I. P. Mysovskikh
!  "On a cubature formula for the simplex"
!  Vopros. Vycisl. i Prikl. Mat., Tashkent 51(1978), 74--90.
!
!
!***ROUTINES CALLED NONE
!***END PROLOGUE RuleParms_Tn
!
!   Global variables
!
      INTEGER, INTENT(IN)                           :: NDIM, KEY
      INTEGER, INTENT(OUT)                          :: WTS, RLS
      INTEGER, DIMENSION(:),            INTENT(OUT) :: PTS
      REAL(KIND=STND), DIMENSION(:,:),  INTENT(OUT) :: W
      REAL(KIND=STND), DIMENSION(0:,:), INTENT(OUT) :: G
!
!   Local Variables
!
      REAL(KIND=STND), PARAMETER :: ONE = 1, FFTEEN = 15
      REAL(KIND=STND) :: DR, DR2, DR4, DR6, DR8
      REAL(KIND=STND) :: R1, S1, R2, S2, U1, V1, U2, V2, L1, L2, D1, D2
      REAL(KIND=STND) :: A1, A2, A3, P0, P1, P2, P3, U5, U6, U7, SG
      REAL(KIND=STND) :: R, A, P, Q, TH, TP
      INTEGER         :: IW, GMS
!
!***FIRST PROCESSING STATEMENT RuleParms_Tn
!
!
!     Initialize RLS and GMS.
!
      IF ( KEY == 1 ) THEN
         RLS = 3
         GMS = 2
         WTS = 3
      ELSE IF ( KEY == 2 ) THEN
         RLS = 5
         GMS = 4
         WTS = 6
      ELSE IF ( KEY == 3 .OR. KEY == 0 ) THEN
         RLS = 7
         GMS = 7
         WTS = 11
      ELSE IF ( KEY == 4 ) THEN
         RLS = 7
         IF ( NDIM == 2 ) THEN
            GMS = 11
            WTS = 20
         ELSE
            GMS = 12
            WTS = 21
         END IF
      END IF
!
!     Initialize generators, weights and PTS.
!
      W(:,1:RLS) = 0
      PTS = 0

!
!     Compute generator, PTS and weight values for all rules.
!
      DR = NDIM
      DR2 =    ( DR + 1 )*( DR + 2 )
      DR4 = DR2*( DR + 3 )*( DR + 4 )
      DR6 = DR4*( DR + 5 )*( DR + 6 )
      DR8 = DR6*( DR + 7 )*( DR + 8 )
      G(0:,1) = 1/( DR + 1 )
          PTS(1) = 1
      R1 = ( DR + 4 - SQRT(FFTEEN) )/( DR*DR + 8*DR + 1 )
      S1 = 1 - DR*R1
      L1 = S1 - R1
      G(0    ,GMS+1) = S1
      G(1:,GMS+1) = R1
          PTS(GMS+1) = NDIM + 1
      IW = RLS
      IF ( KEY < 4 )  THEN
!
!        Compute weights for special degree 1 rule.
!
         W(1,IW) = 1
         IW = IW - 1
         W(GMS+1,IW) = 1/( DR + 1 )
         IW = IW - 1
      END IF
!
!     Compute weights, generators and PTS for degree 3 rule.
!
      G(0    ,2) = 3/( DR + 3 )
      G(1:,2) = 1/( DR + 3 )
          PTS(2) = NDIM + 1
            W(2,IW) = ( DR + 3 )**3/( 4*DR2*( DR + 3 ) )
      IF ( KEY > 1 ) THEN
         IW = IW - 1
!
!        Compute weights, generators and PTS for degree 3 and degree 5 rules.
!
         IF ( NDIM == 2 ) THEN
!
!           Special degree 3 rule.
!
            L2 = 0.6205464826720063258904603436171006977619_STND
            L1 = -SQRT( ONE/2 - L2**2 )
            R1 = ( 1 - L1 )/3
            S1 = 1 - 2*R1
            G(0    ,GMS+1) = S1
            G(1:,GMS+1) = R1
                PTS(GMS+1) = 3
                  W(GMS+1,IW) = ONE/6
            R2 = ( 1 - L2 )/3
            S2 = 1 - 2*R2
            G(0    ,GMS+2) = S2
            G(1:,GMS+2) = R2
                PTS(GMS+2) = 3
                  W(GMS+2,IW) = ONE/6
         ELSE
!
!           Degree 3 rule using Stroud points.
!
            R2 = ( DR + 4 + SQRT(FFTEEN) )/( DR*DR + 8*DR + 1 )
            S2 = 1 - DR*R2
            L2 = S2 - R2
            G(0    ,GMS+2) = S2
            G(1:,GMS+2) = R2
                PTS(GMS+2) = NDIM + 1
                  W(GMS+2,IW) = ( 2/(DR+3) - L1 )/(DR+1)/(DR+2)/(L2-L1)/L2**2
                  W(GMS+1,IW) = ( 2/(DR+3) - L2 )/(DR+1)/(DR+2)/(L1-L2)/L1**2
         END IF
         IW = IW - 1
!
!        Grundmann-Moller degree 5 rule.
!
         G(0    ,3) = 5/( DR + 5 )
         G(1:,3) = 1/( DR + 5 )
             PTS(3) = NDIM + 1
         G(0:1  ,4) = 3/( DR + 5 )
         G(2:,4) = 1/( DR + 5 )
             PTS(4) = ( ( NDIM + 1 )*NDIM )/2
             W(2,  IW) = -( DR + 3 )**5/( 16*DR4 )
             W(3:4,IW) =  ( DR + 5 )**5/( 16*DR4*( DR + 5 ) )
      END IF
      IF ( KEY > 2 )  THEN
         IW = IW - 1
!
!        Compute weights, generators and PTS for degree 5 and degree 7 rules.
!
!
!        Stroud degree 5 rule.
!
         U1 = ( DR + 7 + 2*SQRT(FFTEEN) )/( DR*DR + 14*DR - 11 )
         V1 = ( 1 - ( DR - 1 )*U1 )/2
         D1 = V1 - U1
         G(0:1  ,GMS+3) = V1
         G(2:,GMS+3) = U1
             PTS(GMS+3) = ( ( NDIM + 1 )*NDIM )/2
         U2 = ( DR + 7 - 2*SQRT(FFTEEN) )/( DR*DR + 14*DR - 11 )
         V2 = ( 1 - ( DR - 1 )*U2 )/2
         D2 = V2 - U2
         G(0:1  ,GMS+4) = V2
         G(2:,GMS+4) = U2
             PTS(GMS+4) = ( ( NDIM + 1 )*NDIM )/2
         IF ( NDIM == 2 ) THEN
               W(GMS+3,IW) = ( 155 - SQRT(FFTEEN) )/1200
               W(GMS+4,IW) = ( 155 + SQRT(FFTEEN) )/1200
               W(1,    IW) = 1 - 3*( W(GMS+3,IW) + W(GMS+4,IW) )
         ELSE IF ( NDIM == 3 ) THEN
               W(GMS+1,IW) = ( 2665 + 14*SQRT(FFTEEN) )/37800
               W(GMS+2,IW) = ( 2665 - 14*SQRT(FFTEEN) )/37800
               W(GMS+3,IW) = 2*FFTEEN/567
             PTS(GMS+4) = 0
         ELSE
               W(GMS+1,IW) = ( 2*(27-DR)/(DR+5)-L2*(13-DR) )/L1**4/(L1-L2)/DR4
               W(GMS+2,IW) = ( 2*(27-DR)/(DR+5)-L1*(13-DR) )/L2**4/(L2-L1)/DR4
               W(GMS+3,IW)=( 2/( DR + 5 ) - D2 )/( DR4*( D1 - D2 )*D1**4 )
               W(GMS+4,IW)=( 2/( DR + 5 ) - D1 )/( DR4*( D2 - D1 )*D2**4 )
         END IF
         IW = IW - 1
!
!        Grundmann-Moller degree 7 rule.
!
         G(0    ,5) = 7/( DR + 7 )
         G(1:,5) = 1/( DR + 7 )
             PTS(5) = NDIM + 1
         G(0    ,6) = 5/( DR + 7 )
         G(1    ,6) = 3/( DR + 7 )
         G(2:,6) = 1/( DR + 7 )
             PTS(6) = ( NDIM + 1 )*NDIM
         G(0:2  ,7) = 3/( DR + 7 )
         G(3:,7) = 1/( DR + 7 )
             PTS(7) = ( ( NDIM + 1 )*NDIM*( NDIM - 1 ) )/6
             W(2,  IW) =  ( DR + 3 )**7/( 2*64*DR4*( DR + 5 ) )
             W(3:4,IW) = -( DR + 5 )**7/(   64*DR6 )
             W(5:7,IW) =  ( DR + 7 )**7/(   64*DR6*( DR + 7 ) )
      END IF
      IF ( KEY == 4 )  THEN
         IW = IW - 1
!
!        Compute weights, generators and PTS for degree 7 and degree 9 rules.
!
!        Mysovskikh degree 7 rule.
!
         SG = 1/( 23328*DR6 )
         U5 = -6**3*SG*( 52212 - DR*( 6353 + DR*( 1934 - DR*27 ) ) )
         U6 =  6**4*SG*(  7884 - DR*( 1541 - DR*9 ) )
         U7 = -6**5*SG*(  8292 - DR*( 1139 - DR*3 ) )/( DR + 7 )
         P0 = -144*( 142528 + DR*( 23073 - DR*115 ) )
         P1 = -12*( 6690556 + DR*( 2641189 + DR*( 245378 - DR*1495 ) ) )
         P2 = -16*(6503401 + DR*( 4020794+DR*(787281+DR*(47323-DR*385)) ) )
         P3 = -(6386660+DR*(4411997+DR*(951821+DR*(61659-DR*665))))*(DR+7)
!---------------------------------------------------------------------------
!        Compute 3 zeros by 4 Newton iterations (good for about 30 digits)
!        A1 = -2/( DR + 3 )
!        A1 = A1 - ( P0+A1*(P1+A1*(P2+A1*P3)) )/( P1+A1*(2*P2+A1*3*P3) )
!        A1 = A1 - ( P0+A1*(P1+A1*(P2+A1*P3)) )/( P1+A1*(2*P2+A1*3*P3) )
!        A1 = A1 - ( P0+A1*(P1+A1*(P2+A1*P3)) )/( P1+A1*(2*P2+A1*3*P3) )
!        A1 = A1 - ( P0+A1*(P1+A1*(P2+A1*P3)) )/( P1+A1*(2*P2+A1*3*P3) )
!        G(0    ,GMS+5) = ( 1 - DR*A1 )/( DR + 1 )
!        G(1:,GMS+5) =   ( 1 + A1 )/( DR + 1 )
!            PTS(GMS+5) = NDIM + 1
!        P2 = P2 + A1*P3
!        P1 = P1 + A1*P2
!        A2 = ( -P2 - SQRT( P2**2 - 4*P1*P3 ) )/( 2*P3 )
!        G(0    ,GMS+6) = ( 1 - DR*A2 )/( DR + 1 )
!        G(1:,GMS+6) =   ( 1 + A2 )/( DR + 1 )
!            PTS(GMS+6) = NDIM + 1
!        A3 = ( -P2 + SQRT( P2**2 - 4*P1*P3 ) )/( 2*P3 )
!---------------------------------------------------------------------------
!        Compute 3 zeros by closed formula due to Cardan/Tartaglia
         A = P2/( 3*P3 )
         P = A*( P1/P2 - A )
         Q = A*( 2*A*A - P1/P3 ) + P0/P3
         R = SQRT( -P**3 )
         TH = ACOS( -Q/( 2*R ) )/3
         R = 2*R**( ONE/3 )
         TP = 2*ACOS(-ONE)/3
         A1 = -A + R*COS( TH )
         G(0    ,GMS+5) = ( 1 - DR*A1 )/( DR + 1 )
         G(1:,GMS+5) =   ( 1 + A1 )/( DR + 1 )
             PTS(GMS+5) = NDIM + 1
         A2 = -A + R*COS( TH + TP + TP )
         G(0    ,GMS+6) = ( 1 - DR*A2 )/( DR + 1 )
         G(1:,GMS+6) =   ( 1 + A2 )/( DR + 1 )
             PTS(GMS+6) = NDIM + 1
         A3 = -A + R*COS( TH + TP )
!---------------------------------------------------------------------------
         G(0    ,GMS+7) = ( 1 - DR*A3 )/( DR + 1 )
         G(1:,GMS+7) =   ( 1 + A3 )/( DR + 1 )
             PTS(GMS+7) = NDIM + 1
               W(GMS+5,IW) =                                                 &
                  ( U7-(A2+A3)*U6+A2*A3*U5 )/( A1**2-(A2+A3)*A1+A2*A3 )/A1**5
               W(GMS+6,IW) =                                                 &
                  ( U7-(A1+A3)*U6+A1*A3*U5 )/( A2**2-(A1+A3)*A2+A1*A3 )/A2**5
               W(GMS+7,IW) =                                                 &
                  ( U7-(A2+A1)*U6+A2*A1*U5 )/( A3**2-(A2+A1)*A3+A2*A1 )/A3**5
         G(0:1  ,GMS+8) = 4/( DR + 7 )
         G(2:,GMS+8) = 1/( DR + 7 )
             PTS(GMS+8) = ( ( NDIM + 1 )*NDIM )/2
               W(GMS+8,IW) = 10*(DR+7)**6/( 729*DR6 )
         G(0    ,GMS+9) = 11/( DR + 7 )/2
         G(1    ,GMS+9) =  5/( DR + 7 )/2
         G(2:,GMS+9) =  1/( DR + 7 )
             PTS(GMS+9) = ( ( NDIM + 1 )*NDIM )
               W(GMS+9,IW) = 64*(DR+7)**6/( 6561*DR6 )
               W(    4,IW) = W(4,IW+1)
               W(    7,IW) = W(7,IW+1)
         IW = IW - 1
!
!        Grundmann-Moller degree 9 rule.
!
         G(0    ,8) = 9/( DR + 9 )
         G(1:,8) = 1/( DR + 9 )
             PTS(8) = NDIM + 1
         G(0    ,9) = 7/( DR + 9 )
         G(1    ,9) = 3/( DR + 9 )
         G(2:,9) =   1/( DR + 9 )
             PTS(9) = ( NDIM + 1 )*NDIM
         G(0:1  ,10) = 5/( DR + 9 )
         G(2:,10) = 1/( DR + 9 )
             PTS(10) = ( ( NDIM + 1 )*NDIM )/2
         G(0    ,11) = 5/( DR + 9 )
         G(1:2  ,11) = 3/( DR + 9 )
         G(3:,11) = 1/( DR + 9 )
             PTS(11) = ( ( NDIM + 1 )*NDIM*( NDIM - 1 ) )/2
             W(2   ,IW) = -( DR + 3 )**9/( 6*256*DR6 )
             W(3:4 ,IW) =  ( DR + 5 )**9/( 2*256*DR6*(DR+7) )
             W(5:7 ,IW) = -( DR + 7 )**9/(   256*DR8 )
             W(8:11,IW) =  ( DR + 9 )**9/(   256*DR8*(DR+9) )
         IF ( NDIM > 2 ) THEN
            G(0:3  ,12) = 3/( DR + 9 )
            G(4:,12) = 1/( DR + 9 )
                PTS(12) = ( ( NDIM + 1 )*NDIM*( NDIM - 1 )*( NDIM - 2 ) )/24
                  W(12,IW) =    W(8,IW)
         END IF
      END IF
!
!     Compute constant weight values.
!
      W(1,1:RLS) = 1 - MATMUL( PTS(2:WTS), W(2:WTS,1:RLS) )
!
!     Compute final weight values; null rule weights are computed as
!     differences between weights from highest degree and lower degree rules.
!
      W(:,2:RLS) = W(:,2:RLS) - SPREAD( W(:,1), 2, RLS-1 )
!
      RETURN
   END Subroutine RuleParms_Tn
!
   FUNCTION SymSmp_Sum( N, VERTEX, NF, Integrand, GIN ) RESULT(SymSmpSum)
!
!***BEGIN PROLOGUE SymSmp_Sum
!***KEYWORDS fully symmetric sum
!***PURPOSE  To compute fully symmetric basic rule sums
!***AUTHOR
!
!            Alan Genz
!            Department of Mathematics
!            Washington State University
!            Pullman, WA 99164-3113, USA
!
!***LAST MODIFICATION 99-05
!***DESCRIPTION SymSmp_Sum computes a fully symmetric sum for a vector
!            of integrand values over a simplex. The sum is taken over
!            all permutations of the generators for the sum.
!
!   ON ENTRY
!
!   N       Integer, number of variables.
!   VERTEX  Real array of dimension (N,0:N)
!           The vertices of the simplex, one vertex per column.
!   NF      Integer, number of components for the vector integrand.
! Integrand Real vector function of length NF for computing components of
!            the integrand at Z.
!            It must have parameters ( NF, Z ); see interface below
!            Input parameters:
!              Z      Real array of length N, the evaluation point.
!              NF     Integer number of components of Integrand.
!   GIN    Real Array of dimension (0:N).
!          The generators for the fully symmetric sum.

!
!   ON RETURN
!
! SymSmp_Sum Real array of length NF, the values for the fully symmetric
!            sums for each component of the integrand.
!
!***ROUTINES CALLED: Integrand
!
!***END PROLOGUE SymSmp_Sum
!
!   Global variables.
!
      INTEGER,                          INTENT(IN) :: N, NF
      INTERFACE
         FUNCTION Integrand(NF,Z) RESULT(Value)
            USE Precision_Model
            INTEGER, INTENT(IN) :: NF
            REAL(KIND=STND), DIMENSION(:), INTENT(IN) :: Z
            REAL(KIND=STND), DIMENSION(NF) :: Value
         END FUNCTION Integrand
      END INTERFACE
      REAL(KIND=STND), DIMENSION(:,0:), INTENT(IN) :: VERTEX
      REAL(KIND=STND), DIMENSION(0:),   INTENT(IN) :: GIN
      REAL(KIND=STND), DIMENSION(NF)               :: SymSmpSum
!
!   Local variables.
!
      INTEGER                         :: IX, LX, I, J, K, L
      REAL(KIND=STND), DIMENSION(0:N) :: G
      REAL(KIND=STND)                 :: GL, GI
!
!***FIRST PROCESSING STATEMENT SymSmp_Sum
!
      SymSmpSum = 0
      G = GIN
!
!     Sort input generators if necessary
!
      K = 0
      DO I = 1, N
         IF ( G(I) > G(I-1) ) THEN
            K = 1
      END IF
      END DO
      IF ( K > 0 ) THEN
         DO I = 1, N
            K = I - 1
            DO J = I, N
               IF ( G(J) > G(K) ) THEN
                  K = J
               END IF
            END DO
            IF ( K >= I ) THEN
               GI = G(I-1)
               G(I-1) = G(K)
               G(K) = GI
            END IF
         END DO
      END IF
!
!     Compute integrand value for permutations of G
!
      DO
         SymSmpSum = SymSmpSum + Integrand( NF, MATMUL( VERTEX, G ) )
!
!        Find next distinct permuation of G and loop back for value.
!        Permutations are generated in reverse lexicographic order.
!
         DO I = 1, N
            IF ( G(I-1) > G(I) ) THEN
               GI = G(I)
               IX = I - 1
               DO L = 0, I/2-1
                  GL = G(L)
                  G(L) = G(I-L-1)
                  G(I-L-1) = GL
                  IF (  GL <= GI ) THEN
                     IX = IX - 1
                  END IF
                  IF ( G(L) > GI ) THEN
                     LX = L
                  END IF
               END DO
               IF ( G(IX) <= GI ) THEN
                  IX = LX
               END IF
               G(I) = G(IX)
               G(IX) = GI
               EXIT
            END IF
         END DO
         IF ( I == N+1 ) THEN
            EXIT
         END IF
      END DO
!
      RETURN
      END Function SymSmp_Sum
!
END MODULE CubatureRule_Tn


      SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC )
*
*  -- LAPACK auxiliary routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INCC, INCX, INCY, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   C( * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  DLARGV generates a vector of real plane rotations, determined by
*  elements of the real vectors x and y. For i = 1,2,...,n
*
*     (  c(i)  s(i) ) ( x(i) ) = ( a(i) )
*     ( -s(i)  c(i) ) ( y(i) ) = (   0  )
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of plane rotations to be generated.
*
*  X       (input/output) DOUBLE PRECISION array,
*                         dimension (1+(N-1)*INCX)
*          On entry, the vector x.
*          On exit, x(i) is overwritten by a(i), for i = 1,...,n.
*
*  INCX    (input) INTEGER
*          The increment between elements of X. INCX > 0.
*
*  Y       (input/output) DOUBLE PRECISION array,
*                         dimension (1+(N-1)*INCY)
*          On entry, the vector y.
*          On exit, the sines of the plane rotations.
*
*  INCY    (input) INTEGER
*          The increment between elements of Y. INCY > 0.
*
*  C       (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
*          The cosines of the plane rotations.
*
*  INCC    (input) INTEGER
*          The increment between elements of C. INCC > 0.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IC, IX, IY
      DOUBLE PRECISION   F, G, T, TT
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, SQRT
*     ..
*     .. Executable Statements ..
*
      IX = 1
      IY = 1
      IC = 1
      DO 10 I = 1, N
         F = X( IX )
         G = Y( IY )
         IF( G.EQ.ZERO ) THEN
            C( IC ) = ONE
         ELSE IF( F.EQ.ZERO ) THEN
            C( IC ) = ZERO
            Y( IY ) = ONE
            X( IX ) = G
         ELSE IF( ABS( F ).GT.ABS( G ) ) THEN
            T = G / F
            TT = SQRT( ONE+T*T )
            C( IC ) = ONE / TT
            Y( IY ) = T*C( IC )
            X( IX ) = F*TT
         ELSE
            T = F / G
            TT = SQRT( ONE+T*T )
            Y( IY ) = ONE / TT
            C( IC ) = T*Y( IY )
            X( IX ) = G*TT
         END IF
         IC = IC + INCC
         IY = IY + INCY
         IX = IX + INCX
   10 CONTINUE
      RETURN
*
*     End of DLARGV
*
      END


c
c
c ===================================================================
      subroutine step1(meqn,mwaves,mbc,maux,mx,q,aux,dx,dt,
     &              method,mthlim,cfl,f,wave,s,amdq,apdq,dtdx)
c ===================================================================
c
c     # Take one time step, updating q.
c
c     method(1) = 1   ==>  Godunov method
c     method(1) = 2   ==>  Slope limiter method
c     mthlim(p)  controls what limiter is used in the pth family
c
c
c     amdq, apdq, wave, s, and f are used locally:
c
c     amdq(1-mbc:mx+mbc, meqn) = left-going flux-differences
c     apdq(1-mbc:mx+mbc, meqn) = right-going flux-differences
c        e.g. amdq(m,i) = m'th component of A^- \Delta q from i'th Riemann
c                         problem (between cells i-1 and i).
c
c     wave(1-mbc:mx+mbc, meqn, mwaves) = waves from solution of
c                                           Riemann problems,
c            wave(m,mw,i) = mth component of jump in q across
c                           wave in family mw in Riemann problem between
c                           states i-1 and i.
c
c     s(1-mbc:mx+mbc, mwaves) = wave speeds,
c            s(m,iw) = speed of wave in family mw in Riemann problem between
c                      states i-1 and i.
c
c     f(1-mbc:mx+mbc, meqn) = correction fluxes for second order method
c            f(m,i) = mth component of flux at left edge of ith cell
c     --------------------------------------------------------------------
c
      implicit double precision (a-h,o-z)
      double precision q(meqn,1-mbc:mx+mbc)
      double precision aux(maux,1-mbc:mx+mbc)
      double precision f(meqn,1-mbc:mx+mbc)
      double precision s(mwaves,1-mbc:mx+mbc)
      double precision wave(meqn, mwaves,1-mbc:mx+mbc)
      double precision amdq(meqn,1-mbc:mx+mbc)
      double precision apdq(meqn,1-mbc:mx+mbc)
      double precision dtdx(1-mbc:mx+mbc)
      integer          method(7),mthlim(mwaves)
      logical limit

cf2py intent(in,out) q
cf2py intent(out) cfl
cf2py intent(in) meqn
cf2py intent(in) mbc
cf2py intent(in) mx
cf2py optional f, amdq, apdq, dtdx, s, wave

c
c     # check if any limiters are used:
      limit = .false.
      do 5 mw=1,mwaves
         if (mthlim(mw) .gt. 0) limit = .true.
   5     continue
c
      mcapa = method(6)
      do 10 i=1-mbc,mx+mbc
         if (mcapa.gt.0) then
             if (aux(mcapa,i) .le. 0.d0) then
                write(6,*) 'Error -- capa must be positive'
                stop
                endif
             dtdx(i) = dt / (dx*aux(mcapa,i))
            else
             dtdx(i) = dt/dx
            endif
   10    continue
c
c
c
c     # solve Riemann problem at each interface
c     -----------------------------------------
c
      call rp1(mx,meqn,mwaves,mbc,mx,q,q,aux,aux,wave,s,amdq,apdq)
c
c     # Modify q for Godunov update:
c     # Note this may not correspond to a conservative flux-differencing
c     # for equations not in conservation form.  It is conservative if
c     # amdq + apdq = f(q(i)) - f(q(i-1)).
c

c     print *,"q before, from fortran",q(24,1)

      forall(i=1:mx+1, m=1:meqn)
         q(m,i) = q(m,i) - dtdx(i)*apdq(m,i)
         q(m,i-1) = q(m,i-1) - dtdx(i-1)*amdq(m,i)
      end forall

c
c     # compute maximum wave speed:
      cfl = 0.d0
      do 50 mw=1,mwaves
         do 45 i=1,mx+1
c          # if s>0 use dtdx(i) to compute CFL,
c          # if s<0 use dtdx(i-1) to compute CFL:
           cfl = dmax1(cfl, dtdx(i)*s(mw,i), -dtdx(i-1)*s(mw,i))
   45      continue
   50    continue
c
      if (method(2) .eq. 1) go to 900
c
c     # compute correction fluxes for second order q_{xx} terms:
c     ----------------------------------------------------------
c
      forall(i=1-mbc:mx+mbc, m=1:meqn)
         f(m,i) = 0.d0
      end forall
c
c      # apply limiter to waves:
      if (limit) call limiter(mx,meqn,mwaves,mbc,mx,wave,s,mthlim)
c
      do 120 i=1,mx+1
         do 120 m=1,meqn
            do 110 mw=1,mwaves
         dtdxave = 0.5d0 * (dtdx(i-1) + dtdx(i))
         f(m,i) = f(m,i) + 0.5d0 * dabs(s(mw,i))
     &             * (1.d0 - dabs(s(mw,i))*dtdxave) * wave(m,mw,i)
  110          continue
  120       continue
c
c
c     # update q by differencing correction fluxes
c     ============================================
c
c     # (Note:  Godunov update has already been performed above)
c
      forall(i=1:mx+1, m=1:meqn)
            q(m,i) = q(m,i) - dtdx(i) * (f(m,i+1) - f(m,i))
      end forall
c
  900 continue
      return
      end


MODULE quadruple_precision_df
!
! This version is for Compaq Fortran, Lahey/Fujitsu LF95 and
! Absoft ProFortran 6.0.
! N.B. The -o0 option (no optimization) must be used with LF95.
!
! N.B. This is quadruple precision implemented in SOFTWARE, hence it is SLOW.
! This package has NOT been tested with other Fortran 90 compilers.
! The operations +-*/ & sqrt will probably work correctly with other compilers
! for PCs.   Functions and routines which initialize quadruple-precision
! constants, particularly the trigonometric and exponential functions will
! only work if the compiler initializes double-precision constants from
! decimal code in exactly the same way as the Lahey compilers.

! The basic algorithms come from:
! Linnainmma, S.  Software for doubled-precision floating-point computations,
!    ACM Trans, Math. Software, vol. 7, pp.272-283, 1981.

! Programmer : Alan Miller
! e-mail: amiller @ bigpond.net.au   URL:  http://users.bigpond.net.au/amiller

! Latest revision - 18 September 2002

! 4 Aug 97.  Added new algorithm for exponential.  Takes half the time of the
!            previous Taylor series, but errors 2.5 times larger.   The old
!            exponential is included here under the name exp_taylor for anyone
!            who needs the extra accuracy.  To use it instead of the new
!            algorithm, change the module procedure name in INTERFACE exp from
!            longexp to exp_taylor.
! 5 Aug 97.  Found way to reduce cancellation errors in yesterday's algorithm
!            for the exponential.   Removed exp_taylor.
! 18 Aug 97. Added table of quadruple-precision constants.
! 8 Sept 97. Added str_quad which reads a character string and converts it to
!            quadruple-precision form.
! 15 Oct 97. Added quad_str which takes a quadruple-precision value and outputs
!            a character string containing its decimal value to 30 significant
!            digits.
!            Added overlays to the ** operator for quadruple-precision values.
! 15 Jan 98. Added ATAN2.
! 19 Jan 98. Added <, <=, ==, >= and >.
! 27 Dec 98. Added quad/real, quad/integer, integer/quad, real/quad, dp/quad,
!            int+quad, real+quad, dp+quad, int-quad, real-quad, dp-quad,
!            SUM, DOT_PRODUCT & MATMUL.
! 29 Dec 98. Correction to routine string_quad for strings of < 5 characters.
! 10 May 99. Added EPSILON for quad type.
! 5 Oct 99.  log10e corrected.
! 15 Oct 99. Corrected function quad_pow_int.
! 18 Oct 99. Rewrote quad_pow_int to use the binary power method.
! 11 Nov 99. Added overlaying of assignments, e.g. quad = int, etc.
! 21 Jan 00. Added inreface for EPSILON.
! 17 Feb 02. Corrected ACOS & ASIN for arguments close to +1 or -1.
! 18 Feb 02. Further improvement to ACOS.
! 18 Sep 02. Added reference to Linnainmaa in comments at beginning.

IMPLICIT NONE

INTEGER, PARAMETER   :: dp = SELECTED_REAL_KIND(12, 100)
INTEGER, PARAMETER   :: nbits = DIGITS(1.0_dp)
REAL (dp), PARAMETER :: constant = 2._dp**(nbits - nbits/2) + 1._dp
                        !
                        ! Special for Digital Visual Fortran 5.0
REAL (dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp

PRIVATE :: zero, one, constant, nbits

TYPE    :: quad
  REAL (dp) :: hi, lo
END TYPE quad

INTERFACE OPERATOR (*)
  MODULE PROCEDURE longmul
  MODULE PROCEDURE mult_quad_int
  MODULE PROCEDURE mult_int_quad
  MODULE PROCEDURE mult_quad_dp
  MODULE PROCEDURE mult_dp_quad
  MODULE PROCEDURE mult_quad_real
  MODULE PROCEDURE mult_real_quad
END INTERFACE

INTERFACE OPERATOR (/)
  MODULE PROCEDURE longdiv
  MODULE PROCEDURE div_quad_dp
  MODULE PROCEDURE div_quad_real
  MODULE PROCEDURE div_quad_int
  MODULE PROCEDURE div_int_quad
  MODULE PROCEDURE div_real_quad
  MODULE PROCEDURE div_dp_quad
END INTERFACE

INTERFACE OPERATOR (+)
  MODULE PROCEDURE longadd
  MODULE PROCEDURE quad_add_int
  MODULE PROCEDURE quad_add_real
  MODULE PROCEDURE quad_add_dp
  MODULE PROCEDURE int_add_quad
  MODULE PROCEDURE real_add_quad
  MODULE PROCEDURE dp_add_quad
END INTERFACE

INTERFACE OPERATOR (-)
  MODULE PROCEDURE longsub
  MODULE PROCEDURE quad_sub_int
  MODULE PROCEDURE quad_sub_real
  MODULE PROCEDURE quad_sub_dp
  MODULE PROCEDURE int_sub_quad
  MODULE PROCEDURE real_sub_quad
  MODULE PROCEDURE dp_sub_quad
  MODULE PROCEDURE negate_quad
END INTERFACE

INTERFACE ASSIGNMENT (=)
  MODULE PROCEDURE quad_eq_int
  MODULE PROCEDURE quad_eq_real
  MODULE PROCEDURE quad_eq_dp
  MODULE PROCEDURE int_eq_quad
  MODULE PROCEDURE real_eq_quad
  MODULE PROCEDURE dp_eq_quad
END INTERFACE

INTERFACE OPERATOR (**)
  MODULE PROCEDURE quad_pow_int
  MODULE PROCEDURE quad_pow_real
  MODULE PROCEDURE quad_pow_dp
  MODULE PROCEDURE quad_pow_quad
END INTERFACE

INTERFACE OPERATOR (<)
  MODULE PROCEDURE quad_lt
END INTERFACE

INTERFACE OPERATOR (<=)
  MODULE PROCEDURE quad_le
END INTERFACE

INTERFACE OPERATOR (==)
  MODULE PROCEDURE quad_eq
END INTERFACE

INTERFACE OPERATOR (>=)
  MODULE PROCEDURE quad_ge
END INTERFACE

INTERFACE OPERATOR (>)
  MODULE PROCEDURE quad_gt
END INTERFACE

INTERFACE SCALE
  MODULE PROCEDURE qscale
END INTERFACE

INTERFACE ABS
  MODULE PROCEDURE qabs
END INTERFACE

INTERFACE SQRT
  MODULE PROCEDURE longsqrt
END INTERFACE

INTERFACE LOG
  MODULE PROCEDURE longlog
END INTERFACE

INTERFACE EXP
  MODULE PROCEDURE longexp
END INTERFACE

INTERFACE SIN
  MODULE PROCEDURE longsin
END INTERFACE

INTERFACE COS
  MODULE PROCEDURE longcos
END INTERFACE

INTERFACE TAN
  MODULE PROCEDURE longtan
END INTERFACE

INTERFACE ASIN
  MODULE PROCEDURE longasin
END INTERFACE

INTERFACE ACOS
  MODULE PROCEDURE longacos
END INTERFACE

INTERFACE ATAN
  MODULE PROCEDURE longatan
END INTERFACE

INTERFACE ATAN2
  MODULE PROCEDURE qatan2
END INTERFACE

INTERFACE SUM
  MODULE PROCEDURE quad_sum
END INTERFACE

INTERFACE DOT_PRODUCT
  MODULE PROCEDURE quad_dot_product
END INTERFACE

INTERFACE MATMUL
  MODULE PROCEDURE q_matmul12
  MODULE PROCEDURE q_matmul21
  MODULE PROCEDURE q_matmul22
END INTERFACE

INTERFACE EPSILON
  MODULE PROCEDURE q_epsilon
END INTERFACE

TYPE (quad), PARAMETER ::  &
             pi =  quad( 0.3141592653589793D+01, 0.1224646799147353D-15 ),  &
          piby2 =  quad( 0.1570796326794897D+01, -.3828568698926950D-15 ),  &
          piby3 =  quad( 0.1047197551196598D+01, -.3292527815701405D-15 ),  &
          piby4 =  quad( 0.7853981633974484D+00, -.8040613248383182D-16 ),  &
          piby6 =  quad( 0.5235987755982990D+00, -.1646263907850702D-15 ),  &
          twopi =  quad( 0.6283185307179586D+01, 0.2449293598294707D-15 ),  &
          ln_pi =  quad( 0.1144729885849400D+01, 0.2323105560877391D-15 ),  &
         sqrtpi =  quad( 0.1772453850905516D+01, -.7666586499825800D-16 ),  &
       fact_pt5 =  quad( 0.8862269254527582D+00, -.1493552349616447D-15 ),  &
        sqrt2pi =  quad( 0.2506628274631001D+01, -.6273750096546544D-15 ),  &
      lnsqrt2pi =  quad( 0.9189385332046728D+00, -.3878294158067242D-16 ),  &
      one_on2pi =  quad( 0.1591549430918953D+00, 0.4567181289366658D-16 ),  &
    two_on_rtpi =  quad( 0.1128379167095513D+01, -.4287537502368968D-15 ),  &
        deg2rad =  quad( 0.1745329251994330D-01, -.3174581724866598D-17 ),  &
        rad2deg =  quad( 0.5729577951308232D+02, -.1987849567057628D-14 ),  &
            ln2 =  quad( 0.6931471805599454D+00, -.8783183432405266D-16 ),  &
           ln10 =  quad( 0.2302585092994046D+01, -.2170756223382249D-15 ),  &
          log2e =  quad( 0.1442695040888964D+01, -.6457785410341630D-15 ),  &
         log10e =  quad( 0.4342944819032519D+00, -.5552037773430574D-16 ),  &
        log2_10 =  quad( 0.3321928094887362D+01, 0.1661617516973592D-15 ),  &
        log10_2 =  quad( 0.3010299956639812D+00, -.2803728127785171D-17 ),  &
          euler =  quad( 0.5772156649015330D+00, -.1159652176149463D-15 ),  &
              e =  quad( 0.2718281828459045D+01, 0.1445646891729250D-15 ),  &
          sqrt2 =  quad( 0.1414213562373095D+01, 0.1253716717905022D-15 ),  &
          sqrt3 =  quad( 0.1732050807568877D+01, 0.3223954471431004D-15 ),  &
         sqrt10 =  quad( 0.3162277660168380D+01, -.6348773795572286D-15 )

CONTAINS

FUNCTION exactmul2(a, c) RESULT(ac)
!  Procedure exactmul2, translated from Pascal, from:
!  Linnainmaa, Seppo (1981).   Software for doubled-precision floating-point
!  computations.   ACM Trans. on Math. Software (TOMS), 7, 272-283.

REAL (dp), INTENT(IN) :: a, c
TYPE (quad)           :: ac

!     Local variables
REAL (dp) :: a1, a2, c1, c2, t

t = constant * a
a1 = (a - t) + t             ! Lahey's optimization removes the brackets
                             ! and sets a1 = a which defeats the whole point.
a2 = a - a1
t = constant * c
c1 = (c - t) + t
c2 = c - c1
ac%hi = a * c
ac%lo = (((a1 * c1 - ac%hi) + a1 * c2) + c1 * a2) + c2 * a2

RETURN
END FUNCTION exactmul2

FUNCTION longmul(a, c) RESULT(ac)
!  Procedure longmul, translated from Pascal, from:
!  Linnainmaa, Seppo (1981).   Software for doubled-precision floating-point
!  computations.   ACM Trans. on Math. Software (TOMS), 7, 272-283.

TYPE (quad), INTENT(IN) :: a, c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: zz
TYPE (quad) :: z

z = exactmul2(a%hi, c%hi)
zz = ((a%hi + a%lo) * c%lo + a%lo * c%hi) + z%lo
ac%hi = z%hi + zz
ac%lo = (z%hi - ac%hi) + zz

RETURN
END FUNCTION longmul

FUNCTION mult_quad_int(a, i) RESULT(c)
!     Multiply quadruple-precision number (a) by an integer (i).

TYPE (quad), INTENT(IN) :: a
INTEGER, INTENT(IN)     :: i
TYPE (quad)             :: c

IF (i == 0) THEN
  c = quad(zero, zero)
ELSE IF (i == 1) THEN
  c = a
ELSE IF (i == -1) THEN
  c = -a
ELSE
  c = exactmul2(a%hi, DBLE(i)) + exactmul2(a%lo, DBLE(i))
END IF

RETURN
END FUNCTION mult_quad_int

FUNCTION mult_int_quad(i, a) RESULT(c)
!     Multiply quadruple-precision number (a) by an integer (i).

INTEGER, INTENT(IN)     :: i
TYPE (quad), INTENT(IN) :: a
TYPE (quad)             :: c

IF (i == 0) THEN
  c = quad(zero, zero)
ELSE IF (i == 1) THEN
  c = a
ELSE IF (i == -1) THEN
  c = -a
ELSE
  c = exactmul2(a%hi, DBLE(i)) + exactmul2(a%lo, DBLE(i))
END IF

RETURN
END FUNCTION mult_int_quad

FUNCTION mult_quad_dp(a, b) RESULT(c)
!  Multiply a quadruple-precision number (a) by a double-precision number (b).

TYPE (quad), INTENT(IN) :: a
REAL (dp), INTENT(IN)   :: b
TYPE (quad)             :: c

!     Local variables
TYPE (quad)             :: z
REAL (dp)               :: zz

z = exactmul2(a%hi, b)
zz = a%lo * b + z%lo
c%hi = z%hi + zz
c%lo = (z%hi - c%hi) + zz

RETURN
END FUNCTION mult_quad_dp

FUNCTION mult_quad_real(a, b) RESULT(c)
!  Multiply a quadruple-precision number (a) by a real number (b).

TYPE (quad), INTENT(IN) :: a
REAL, INTENT(IN)        :: b
TYPE (quad)             :: c

!     Local variables
TYPE (quad)             :: z
REAL (dp)               :: zz

z = exactmul2(a%hi, DBLE(b))
zz = a%lo * b + z%lo
c%hi = z%hi + zz
c%lo = (z%hi - c%hi) + zz

RETURN
END FUNCTION mult_quad_real

FUNCTION mult_dp_quad(b, a) RESULT(c)
!  Multiply a quadruple-precision number (a) by a double-precision number (b).

TYPE (quad), INTENT(IN) :: a
REAL (dp), INTENT(IN)   :: b
TYPE (quad)             :: c

!     Local variables
TYPE (quad)             :: z
REAL (dp)               :: zz

z = exactmul2(a%hi, b)
zz = a%lo * b + z%lo
c%hi = z%hi + zz
c%lo = (z%hi - c%hi) + zz

RETURN
END FUNCTION mult_dp_quad

FUNCTION mult_real_quad(a, b) RESULT(c)
!  Multiply a quadruple-precision number (a) by a double-precision number (b).

REAL, INTENT(IN)        :: a
TYPE (quad), INTENT(IN) :: b
TYPE (quad)             :: c

!     Local variables
TYPE (quad)             :: z
REAL (dp)               :: zz

z = exactmul2(b%hi, DBLE(a))
zz = b%lo * a + z%lo
c%hi = z%hi + zz
c%lo = (z%hi - c%hi) + zz

RETURN
END FUNCTION mult_real_quad

FUNCTION longdiv(a, c) RESULT(ac)
!  Procedure longdiv, translated from Pascal, from:
!  Linnainmaa, Seppo (1981).   Software for doubled-precision floating-point
!  computations.   ACM Trans. on Math. Software (TOMS), 7, 272-283.

TYPE (quad), INTENT(IN) :: a, c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, zz
TYPE (quad) :: q

z = a%hi / c%hi
q = exactmul2(c%hi, z)
zz = ((((a%hi - q%hi) - q%lo) + a%lo) - z*c%lo) / (c%hi + c%lo)
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION longdiv

FUNCTION div_quad_dp(a, b) RESULT(c)
!     Divide a quadruple-precision number (a) by a double-precision number (b)

TYPE (quad), INTENT(IN) :: a
REAL (dp), INTENT(IN)   :: b
TYPE (quad)             :: c

!     Local variables
REAL (dp  ) :: z, zz
TYPE (quad) :: q

z = a%hi / b
q = exactmul2(b, z)
zz = (((a%hi - q%hi) - q%lo) + a%lo) / b
c%hi = z + zz
c%lo = (z - c%hi) + zz

RETURN
END FUNCTION div_quad_dp

FUNCTION div_quad_real(a, b) RESULT(c)
!     Divide a quadruple-precision number (a) by a real number (b)

TYPE (quad), INTENT(IN) :: a
REAL, INTENT(IN)        :: b
TYPE (quad)             :: c

!     Local variables
REAL (dp  ) :: z, zz
TYPE (quad) :: q

z = a%hi / b
q = exactmul2(DBLE(b), z)
zz = (((a%hi - q%hi) - q%lo) + a%lo) / b
c%hi = z + zz
c%lo = (z - c%hi) + zz

RETURN
END FUNCTION div_quad_real

FUNCTION div_quad_int(a, b) RESULT(c)
!     Divide a quadruple-precision number (a) by an integer (b)

TYPE (quad), INTENT(IN) :: a
INTEGER, INTENT(IN)     :: b
TYPE (quad)             :: c

!     Local variables
REAL (dp  ) :: z, zz
TYPE (quad) :: q

z = a%hi / b
q = exactmul2(DBLE(b), z)
zz = (((a%hi - q%hi) - q%lo) + a%lo) / b
c%hi = z + zz
c%lo = (z - c%hi) + zz

RETURN
END FUNCTION div_quad_int

FUNCTION div_int_quad(a, c) RESULT(ac)
!  Procedure longdiv, translated from Pascal, from:
!  Linnainmaa, Seppo (1981).   Software for doubled-precision floating-point
!  computations.   ACM Trans. on Math. Software (TOMS), 7, 272-283.

INTEGER, INTENT(IN)     :: a
TYPE (quad), INTENT(IN) :: c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, zz
TYPE (quad) :: q

z = DBLE(a) / c%hi
q = exactmul2(c%hi, z)
zz = (((a - q%hi) - q%lo) - z*c%lo) / (c%hi + c%lo)
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION div_int_quad

FUNCTION div_real_quad(a, c) RESULT(ac)
!  Procedure longdiv, translated from Pascal, from:
!  Linnainmaa, Seppo (1981).   Software for doubled-precision floating-point
!  computations.   ACM Trans. on Math. Software (TOMS), 7, 272-283.

REAL, INTENT(IN)        :: a
TYPE (quad), INTENT(IN) :: c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, zz
TYPE (quad) :: q

z = DBLE(a) / c%hi
q = exactmul2(c%hi, z)
zz = (((a - q%hi) - q%lo) - z*c%lo) / (c%hi + c%lo)
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION div_real_quad

FUNCTION div_dp_quad(a, c) RESULT(ac)
!  Procedure longdiv, translated from Pascal, from:
!  Linnainmaa, Seppo (1981).   Software for doubled-precision floating-point
!  computations.   ACM Trans. on Math. Software (TOMS), 7, 272-283.

REAL (dp), INTENT(IN)   :: a
TYPE (quad), INTENT(IN) :: c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, zz
TYPE (quad) :: q

z = a / c%hi
q = exactmul2(c%hi, z)
zz = (((a - q%hi) - q%lo) - z*c%lo) / (c%hi + c%lo)
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION div_dp_quad

FUNCTION longadd(a, c) RESULT(ac)
!  Procedure longadd, translated from Pascal, from:
!  Linnainmaa, Seppo (1981).   Software for doubled-precision floating-point
!  computations.   ACM Trans. on Math. Software (TOMS), 7, 272-283.

TYPE (quad), INTENT(IN) :: a, c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, q, zz

z = a%hi + c%hi
q = a%hi - z
zz = (((q + c%hi) + (a%hi - (q + z))) + a%lo) + c%lo
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION longadd

FUNCTION quad_add_int(a, c) RESULT(ac)

TYPE (quad), INTENT(IN) :: a
INTEGER, INTENT(IN)     :: c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, q, zz

z = a%hi + c
q = a%hi - z
zz = (((q + c) + (a%hi - (q + z))) + a%lo)
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION quad_add_int

FUNCTION quad_add_real(a, c) RESULT(ac)

TYPE (quad), INTENT(IN) :: a
REAL, INTENT(IN)        :: c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, q, zz

z = a%hi + c
q = a%hi - z
zz = (((q + c) + (a%hi - (q + z))) + a%lo)
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION quad_add_real

FUNCTION quad_add_dp(a, c) RESULT(ac)

TYPE (quad), INTENT(IN) :: a
REAL (dp), INTENT(IN)   :: c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, q, zz

z = a%hi + c
q = a%hi - z
zz = (((q + c) + (a%hi - (q + z))) + a%lo)
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION quad_add_dp

FUNCTION int_add_quad(c, a) RESULT(ac)

INTEGER, INTENT(IN)     :: c
TYPE (quad), INTENT(IN) :: a
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, q, zz

z = a%hi + c
q = a%hi - z
zz = (((q + c) + (a%hi - (q + z))) + a%lo)
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION int_add_quad

FUNCTION real_add_quad(c, a) RESULT(ac)

REAL, INTENT(IN)        :: c
TYPE (quad), INTENT(IN) :: a
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, q, zz

z = a%hi + c
q = a%hi - z
zz = (((q + c) + (a%hi - (q + z))) + a%lo)
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION real_add_quad

FUNCTION dp_add_quad(c, a) RESULT(ac)

REAL (dp), INTENT(IN)   :: c
TYPE (quad), INTENT(IN) :: a
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, q, zz

z = a%hi + c
q = a%hi - z
zz = (((q + c) + (a%hi - (q + z))) + a%lo)
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION dp_add_quad

FUNCTION longsub(a, c) RESULT(ac)
!  Adapted from longadd by changing signs of c.
!  Linnainmaa, Seppo (1981).   Software for doubled-precision floating-point
!  computations.   ACM Trans. on Math. Software (TOMS), 7, 272-283.

TYPE (quad), INTENT(IN) :: a, c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, q, zz

z = a%hi - c%hi
q = a%hi - z
zz = (((q - c%hi) + (a%hi - (q + z))) + a%lo) - c%lo
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION longsub

FUNCTION quad_sub_int(a, c) RESULT(ac)

TYPE (quad), INTENT(IN) :: a
INTEGER, INTENT(IN)     :: c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, q, zz

z = a%hi - c
q = a%hi - z
zz = (((q - c) + (a%hi - (q + z))) + a%lo)
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION quad_sub_int

FUNCTION quad_sub_real(a, c) RESULT(ac)

TYPE (quad), INTENT(IN) :: a
REAL, INTENT(IN)        :: c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, q, zz

z = a%hi - c
q = a%hi - z
zz = (((q - c) + (a%hi - (q + z))) + a%lo)
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION quad_sub_real

FUNCTION quad_sub_dp(a, c) RESULT(ac)

TYPE (quad), INTENT(IN) :: a
REAL (dp), INTENT(IN)   :: c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, q, zz

z = a%hi - c
q = a%hi - z
zz = (((q - c) + (a%hi - (q + z))) + a%lo)
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION quad_sub_dp

FUNCTION int_sub_quad(a, c) RESULT(ac)

INTEGER, INTENT(IN)     :: a
TYPE (quad), INTENT(IN) :: c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, q, zz

z = DBLE(a) - c%hi
q = DBLE(a) - z
zz = ((q - c%hi) + (DBLE(a) - (q + z))) - c%lo
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION int_sub_quad

FUNCTION real_sub_quad(a, c) RESULT(ac)

REAL, INTENT(IN)        :: a
TYPE (quad), INTENT(IN) :: c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, q, zz

z = a - c%hi
q = a - z
zz = ((q - c%hi) + (a - (q + z))) - c%lo
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION real_sub_quad

FUNCTION dp_sub_quad(a, c) RESULT(ac)

REAL (dp), INTENT(IN)   :: a
TYPE (quad), INTENT(IN) :: c
TYPE (quad)             :: ac

!     Local variables
REAL (dp  ) :: z, q, zz

z = a - c%hi
q = a - z
zz = ((q - c%hi) + (a - (q + z))) - c%lo
ac%hi = z + zz
ac%lo = (z - ac%hi) + zz

RETURN
END FUNCTION dp_sub_quad

FUNCTION negate_quad(a) RESULT(b)
!     Change the sign of a quadruple-precision number.
!     In many cases, a & b will occupy the same locations.

TYPE (quad), INTENT(IN) :: a
TYPE (quad)             :: b

b%hi = -a%hi
b%lo = -a%lo

RETURN
END FUNCTION negate_quad

SUBROUTINE quad_eq_int(a, i)
!     Assignment

TYPE (quad), INTENT(OUT) :: a
INTEGER, INTENT(IN)      :: i

a%hi = i
a%lo = 0

RETURN
END SUBROUTINE quad_eq_int

SUBROUTINE quad_eq_real(a, r)
!     Assignment

TYPE (quad), INTENT(OUT) :: a
REAL, INTENT(IN)         :: r

a%hi = r
a%lo = zero

RETURN
END SUBROUTINE quad_eq_real

SUBROUTINE quad_eq_dp(a, d)
!     Assignment

TYPE (quad), INTENT(OUT) :: a
REAL (dp), INTENT(IN)    :: d

a%hi = d
a%lo = zero

RETURN
END SUBROUTINE quad_eq_dp

SUBROUTINE int_eq_quad(i, a)
!     Assignment

INTEGER, INTENT(OUT)     :: i
TYPE (quad), INTENT(IN)  :: a

i = a%hi

RETURN
END SUBROUTINE int_eq_quad

SUBROUTINE real_eq_quad(r, a)
!     Assignment

REAL, INTENT(OUT)        :: r
TYPE (quad), INTENT(IN)  :: a

r = a%hi

RETURN
END SUBROUTINE real_eq_quad

SUBROUTINE dp_eq_quad(d, a)
!     Assignment

REAL (dp), INTENT(OUT)   :: d
TYPE (quad), INTENT(IN)  :: a

d = a%hi

RETURN
END SUBROUTINE dp_eq_quad

FUNCTION quad_lt(x, y) RESULT(is_it)
!     Comparison of 2 logical numbers

TYPE (quad), INTENT(IN) :: x, y
LOGICAL                 :: is_it

! Local variable
TYPE (quad) :: diff

diff = x - y
is_it = (diff%hi < zero)

RETURN
END FUNCTION quad_lt

FUNCTION quad_le(x, y) RESULT(is_it)
!     Comparison of 2 logical numbers

TYPE (quad), INTENT(IN) :: x, y
LOGICAL                 :: is_it

! Local variable
TYPE (quad) :: diff

diff = x - y
is_it = .NOT. (diff%hi > zero)

RETURN
END FUNCTION quad_le

FUNCTION quad_eq(x, y) RESULT(is_it)
!     Comparison of 2 logical numbers

TYPE (quad), INTENT(IN) :: x, y
LOGICAL                 :: is_it

! Local variable
TYPE (quad) :: diff

diff = x - y
is_it = (diff%hi == zero)

RETURN
END FUNCTION quad_eq

FUNCTION quad_ge(x, y) RESULT(is_it)
!     Comparison of 2 logical numbers

TYPE (quad), INTENT(IN) :: x, y
LOGICAL                 :: is_it

! Local variable
TYPE (quad) :: diff

diff = x - y
is_it = .NOT. (diff%hi < zero)

RETURN
END FUNCTION quad_ge

FUNCTION quad_gt(x, y) RESULT(is_it)
!     Comparison of 2 logical numbers

TYPE (quad), INTENT(IN) :: x, y
LOGICAL                 :: is_it

! Local variable
TYPE (quad) :: diff

diff = x - y
is_it = (diff%hi > zero)

RETURN
END FUNCTION quad_gt

FUNCTION quad_pow_int(a, i) RESULT(b)
!     Raise a quadruple=precision number (a) to a power.

TYPE (quad), INTENT(IN) :: a
INTEGER, INTENT(IN)     :: i
TYPE (quad)             :: b

! Local variables

INTEGER     :: ia, j, emax
TYPE (quad) :: power
LOGICAL     :: first

SELECT CASE (i)
  CASE (0)
    b = quad(one, zero)
  CASE (-1023:-1, 1:1023)
    ia = ABS(i)
    first = .TRUE.
    power = a
    emax = MAXEXPONENT(one)
    DO j = 0, 9
      IF (BTEST(ia, j)) THEN
        IF (first) THEN
          b = power
          first = .FALSE.
        ELSE
          IF (EXPONENT(power%hi) + EXPONENT(b%hi) > emax) THEN
            WRITE(*, *) '** Exponential overflow in routine QUAD_POW_INT **'
            RETURN
          END IF
          b = b * power
        END IF
        ia = IBCLR(ia, j)
        IF (ia == 0) EXIT
      END IF
      IF (EXPONENT(power%hi) > emax/2) THEN
        WRITE(*, *) '** Exponential overflow in routine QUAD_POW_INT **'
        RETURN
      END IF
      power = power * power
    END DO
    IF (i < 0) b = quad(one, zero) / b
  CASE DEFAULT
    IF (a%hi < zero) THEN
      IF (i * LOG(-a%hi) > LOG( HUGE(one) )) THEN
        WRITE(*, *) '** Exponential overflow in routine QUAD_POW_INT **'
        RETURN
      ELSE IF (i * LOG(-a%hi) < LOG( TINY(one) )) THEN
        b = quad(zero, zero)
      ELSE
        ia = ABS(i)
        IF (BTEST(ia,0)) THEN
          b = - EXP( LOG(-a)*i )         ! i is odd (test least sign. bit)
        ELSE
          b = EXP( LOG(-a)*i )           ! i is even
        END IF
      END IF
    ELSE IF (a%hi > zero) THEN
      IF (i * LOG(a%hi) > LOG( HUGE(one) )) THEN
        WRITE(*, *) '** Exponential overflow in routine QUAD_POW_INT **'
        RETURN
      ELSE IF (i * LOG(a%hi) < LOG( TINY(one) )) THEN
        b = quad(zero, zero)
      ELSE
        b = EXP( LOG(a)*i )
      END IF
    ELSE
      b = quad(zero, zero)
    END IF
END SELECT

RETURN
END FUNCTION quad_pow_int

FUNCTION quad_pow_real(a, r) RESULT(b)
!     Raise a quadruple=precision number (a) to a power.

TYPE (quad), INTENT(IN) :: a
REAL, INTENT(IN)        :: r
TYPE (quad)             :: b

IF (a%hi < zero) THEN
  WRITE(*, *)   &
  ' *** Error: attempt to raise negative quad. prec. number to a real power ***'
  b = quad(zero, zero)
ELSE IF (a%hi > zero) THEN
  b = EXP( LOG(a)*r )
ELSE
  b = quad(zero, zero)
END IF

RETURN
END FUNCTION quad_pow_real

FUNCTION quad_pow_dp(a, d) RESULT(b)
!     Raise a quadruple=precision number (a) to a power.

TYPE (quad), INTENT(IN) :: a
REAL (dp), INTENT(IN)   :: d
TYPE (quad)             :: b

IF (a%hi < zero) THEN
  WRITE(*, *)   &
  ' *** Error: attempt to raise negative quad. prec. number to a real power ***'
  b = quad(zero, zero)
ELSE IF (a%hi > zero) THEN
  b = EXP( LOG(a)*d )
ELSE
  b = quad(zero, zero)
END IF

RETURN
END FUNCTION quad_pow_dp

FUNCTION quad_pow_quad(a, q) RESULT(b)
!     Raise a quadruple=precision number (a) to a power.

TYPE (quad), INTENT(IN) :: a, q
TYPE (quad)             :: b

IF (a%hi < zero) THEN
  WRITE(*, *)   &
  ' *** Error: attempt to raise negative quad. prec. number to a real power ***'
  b = quad(zero, zero)
ELSE IF (a%hi > zero) THEN
  b = EXP( LOG(a)*q )
ELSE
  b = quad(zero, zero)
END IF

RETURN
END FUNCTION quad_pow_quad

FUNCTION qscale(a, i) RESULT(b)
!     Multiply a by 2^i

TYPE (quad), INTENT(IN) :: a
INTEGER, INTENT(IN)     :: i
TYPE (quad)             :: b

b%hi = SCALE(a%hi, i)
b%lo = SCALE(a%lo, i)

RETURN
END FUNCTION qscale

FUNCTION qabs(a) RESULT(b)
!     Absolute value of a quadruple-precision number

TYPE (quad), INTENT(IN) :: a
TYPE (quad)             :: b

IF (a%hi < zero) THEN
  b%hi = - a%hi
  b%lo = - a%lo
ELSE
  b%hi = a%hi
  b%lo = a%lo
END IF

RETURN
END FUNCTION qabs

FUNCTION longsqrt(a) RESULT(b)
! This is modified from procedure sqrt2 of:
!    Dekker, T.J. (1971). 'A floating-point technique for extending the
!    available precision', Numer. Math., 18, 224-242.

TYPE (quad), INTENT(IN) :: a
TYPE (quad)             :: b

!     Local variables
REAL (dp)   :: t, res
TYPE (quad) :: tt

! Check that ahi >= 0.

IF (a%hi < 0._dp) THEN
  WRITE(*, *) ' *** Negative argument for longsqrt ***'
  RETURN
ELSE IF (a%hi == 0.d0) THEN
  b%hi = 0._dp
  b%lo = 0._dp
  RETURN
END IF

! First approximation is  t = sqrt(a).

t = SQRT(a%hi)
tt = exactmul2(t, t)
res = t + (((a%hi - tt%hi) - tt%lo) + a%lo) * 0.5_dp / t
b%lo = (t - res) + (((a%hi - tt%hi) - tt%lo) + a%lo) * 0.5_dp / t
b%hi = res

RETURN
END FUNCTION longsqrt

FUNCTION longlog(x) RESULT(y)
!  Quadruple-precision logarithm to base e
!  Halley's algorithm using double-precision logarithm as starting value.
!  Solves:         y
!          f(y) = e  - x = 0

TYPE (quad), INTENT(IN) :: x
TYPE (quad)             :: y

!     Local variables
TYPE (quad) :: expy, f

y%hi = LOG(x%hi)
y%lo = 0._dp
expy = EXP(y)
f = expy - x
f = SCALE(f, 1)
y = y - f / (expy + x)

RETURN
END FUNCTION longlog

FUNCTION longexp(x) RESULT(y)
!  Calculate a quadruple-precision exponential
!  Method:
!   x    x.log2(e)    nint[x.log2(e)] + frac[x.log2(e)]
!  e  = 2          = 2
!
!                     iy    fy
!                  = 2   . 2
!  Then
!   fy    y.ln(2)
!  2   = e
!
!  Now y.ln(2) will be less than 0.3466 in absolute value.
!  This is halved and a Pade approximation is used to approximate e^x over
!  the region (-0.1733, +0.1733).   This approximation is then squared.

!  WARNING: No overflow checks!

TYPE (quad), INTENT(IN) :: x
TYPE (quad)             :: y

! Local variables
TYPE (quad)          :: temp, ysq, sum1, sum2
INTEGER              :: iy

y = x / ln2
iy = NINT(REAL(y%hi))
y = (y - DBLE(iy)) * ln2
y = SCALE(y, -1)

! The Pade series is:
!     p0 + p1.y + p2.y^2 + p3.y^3 + ... + p9.y^9
!     ------------------------------------------
!     p0 - p1.y + p2.y^2 - p3.y^3 + ... - p9.y^9
!
! sum1 is the sum of the odd powers, sum2 is the sum of the even powers

ysq = y * y
sum1 = y * ((((ysq + 3960.)*ysq + 2162160._dp)*ysq + 302702400._dp)*ysq +   &
               8821612800._dp)
sum2 = (((90.*ysq + 110880.)*ysq + 30270240._dp)*ysq + 2075673600._dp)*ysq +  &
       17643225600._dp

!                     sum2 + sum1         2.sum1
! Now approximation = ----------- = 1 + ----------- = 1 + 2.temp
!                     sum2 - sum1       sum2 - sum1
!
! Then (1 + 2.temp)^2 = 4.temp.(1 + temp) + 1

temp = sum1 / (sum2 - sum1)
y = temp * (temp + 1._dp)
y = SCALE(y, 2)
y = y + 1._dp
y = SCALE(y, iy)

RETURN
END FUNCTION longexp

SUBROUTINE longmodr(a, b, n, rem)

! Extended arithmetic calculation of the 'rounded' modulus:
!  a = n.b + rem
! where all quantities are in quadruple-precision, except the integer
! number of multiples, n.   The absolute value of the remainder (rem)
! is not greater than b/2.
! The result is exact.   rem may occupy the same location as either input.

! Programmer: Alan Miller

! Latest revision - 11 September 1986
! Fortran version - 4 December 1996

TYPE (quad), INTENT(IN)  :: a, b
INTEGER, INTENT(OUT)     :: n
TYPE (quad), INTENT(OUT) :: rem

! Local variables

TYPE (quad) :: temp

! Check that b%hi .ne. 0

IF (b%hi == 0._dp) THEN
  WRITE(*, *) ' *** Error in longmodr - 3rd argument zero ***'
  RETURN
END IF

! Calculate n.

temp = a / b
n = NINT(REAL(temp%hi))

! Calculate remainder preserving full accuracy.

temp = exactmul2(DBLE(n), b%hi)
rem%hi = a%hi
rem%lo = zero
temp = rem - temp
rem%hi = a%lo
rem%lo = zero
temp = rem + temp
rem = exactmul2(DBLE(n), b%lo)
rem = temp - rem

RETURN
END SUBROUTINE longmodr

! Extended accuracy arithmetic sine, cosine & tangent (about 31 decimals).
! Calculates  b = sin, cos or tan (a), where all quantities are in
! quadruple-precision, using table look-up and a Taylor series expansion.
! The result may occupy the same locations as the input value.
! Much of the code is common to all three functions, and this is in a
! subroutine longcst.

FUNCTION longsin(a) RESULT(b)

TYPE (quad), INTENT(IN) :: a
TYPE (quad)             :: b

! Local variables

LOGICAL :: sine, cosine, tangent

! Set logical variables for sine function.

sine = .true.
cosine = .false.
tangent = .false.
CALL longcst(a, b, sine, cosine, tangent)

RETURN
END FUNCTION longsin

FUNCTION longcos(a) RESULT(b)

TYPE (quad), INTENT(IN) :: a
TYPE (quad)             :: b

! Local variables

LOGICAL :: sine, cosine, tangent

! Set logical variables for sine function.

sine = .false.
cosine = .true.
tangent = .false.
CALL longcst(a, b, sine, cosine, tangent)

RETURN
END FUNCTION longcos

FUNCTION longtan(a) RESULT(b)

TYPE (quad), INTENT(IN) :: a
TYPE (quad)             :: b

! Local variables

LOGICAL :: sine, cosine, tangent

! Set logical variables for sine function.

sine = .false.
cosine = .false.
tangent = .true.
CALL longcst(a, b, sine, cosine, tangent)

RETURN
END FUNCTION longtan

SUBROUTINE longcst(a, b, sine, cosine, tangent)

TYPE (quad), INTENT(IN)  :: a
TYPE (quad), INTENT(OUT) :: b
LOGICAL, INTENT(IN)      :: sine, cosine, tangent

! Local variables

LOGICAL     :: pos
TYPE (quad) :: d, term, temp, angle, piby40, sum1, sum2, sin
INTEGER     :: npi, ipt, i
REAL (dp)   :: tol15 = 1.E-15_dp, tol30 = 1.E-30_dp

! sin(i.pi/40), i = 0(1)20
REAL (dp)   :: table(2, 0:20) = RESHAPE( (/    &
               0.0000000000000000E+00_dp,  0.0000000000000000E+00_dp,  &
               0.7845909572784494E-01_dp,  0.1464397249532491E-17_dp,  &
               0.1564344650402309E+00_dp,  -.2770509565052586E-16_dp,  &
               0.2334453638559054E+00_dp,  0.2058612230858154E-16_dp,  &
               0.3090169943749475E+00_dp,  -.8267172724967036E-16_dp,  &
               0.3826834323650898E+00_dp,  -.1005077269646159E-16_dp,  &
               0.4539904997395468E+00_dp,  -.1292033036231312E-16_dp,  &
               0.5224985647159488E+00_dp,  0.6606794454708078E-16_dp,  &
               0.5877852522924732E+00_dp,  -.1189570533007057E-15_dp,  &
               0.6494480483301838E+00_dp,  -.1134903961116171E-15_dp,  &
               0.7071067811865476E+00_dp,  -.4833646656726458E-16_dp,  &
               0.7604059656000310E+00_dp,  -.1036987135483477E-15_dp,  &
               0.8090169943749476E+00_dp,  -.1381828784809282E-15_dp,  &
               0.8526401643540922E+00_dp,  0.4331886637554353E-16_dp,  &
               0.8910065241883680E+00_dp,  -.1474714419679880E-15_dp,  &
               0.9238795325112868E+00_dp,  -.9337725537817898E-16_dp,  &
               0.9510565162951536E+00_dp,  -.7008780156242836E-16_dp,  &
               0.9723699203976766E+00_dp,  0.4478912629332321E-16_dp,  &
               0.9876883405951378E+00_dp,  -.4416018005989794E-16_dp,  &
               0.9969173337331280E+00_dp,  0.1235153006196267E-16_dp,  &
               0.1000000000000000E+01_dp,  0.0000000000000000E+00_dp  /),  &
               (/ 2, 21 /) )

! pi/40

piby40%hi = 0.7853981633974484E-01_dp
piby40%lo = -.1081617080994607E-16_dp

! Reduce angle to range (-pi/2, +pi/2) by subtracting an integer multiple of pi.

CALL longmodr(a, pi, npi, angle)

! Find nearest multiple of pi/40 to angle.

CALL longmodr(angle, piby40, ipt, d)

! Sum 1 = 1 - d**2/2! + d**4/4! - d**6/6! + ...
! Sum 2 = d - d**3/3! + d**5/5! - d**7/7! + ...

sum1%hi = zero
sum1%lo = zero
sum2%hi = zero
sum2%lo = zero
pos = .false.
term = d
i = 2
20 IF (ABS(term%hi) > tol15) THEN
  term = term * d                                ! Use quad. precision
  IF (i == 2 .OR. i == 4 .OR. i == 8) THEN
    term%hi = term%hi / i
    term%lo = term%lo / i
  ELSE
    term = term / DBLE(i)
  END IF
  IF (pos) THEN
    sum1 = sum1 + term
  ELSE
    sum1 = sum1 - term
  END IF
ELSE
  term%hi = term%hi * d%hi / DBLE(i)             ! Double prec. adequate
  IF (pos) THEN
    sum1%lo = sum1%lo + term%hi
  ELSE
    sum1%lo = sum1%lo - term%hi
  END IF
END IF

! Repeat for sum2

i = i + 1
IF (ABS(term%hi) > tol15) THEN
  term = term * d / DBLE(i)                      ! Use quad. precision
  IF (pos) THEN
    sum2 = sum2 + term
  ELSE
    sum2 = sum2 - term
  END IF
ELSE
  term%hi = term%hi * d%hi / DBLE(i)             ! Double prec. adequate
  IF (pos) THEN
    sum2%lo = sum2%lo + term%hi
  ELSE
    sum2%lo = sum2%lo - term%hi
  END IF
END IF

i = i + 1
pos = .NOT. pos
IF (ABS(term%hi) > tol30) GO TO 20

sum1 = sum1 + 1._dp                              ! Now add the 1st terms
sum2 = sum2 + d                                  ! for max. accuracy

! Construct sine, cosine or tangent.
! Sine first.    sin(angle + d) = sin(angle).cos(d) + cos(angle).sin(d)

IF (sine .OR. tangent) THEN
  IF (ipt >= 0) THEN
    temp%hi = table(1, ipt)
    temp%lo = table(2, ipt)
  ELSE
    temp%hi = - table(1, -ipt)
    temp%lo = - table(2, -ipt)
  END IF
  b = sum1 * temp
  IF (ipt >= 0) THEN
    temp%hi = table(1, 20-ipt)
    temp%lo = table(2, 20-ipt)
  ELSE
    temp%hi = table(1, 20+ipt)
    temp%lo = table(2, 20+ipt)
  END IF
  b = b + sum2 * temp
  IF (npi /= 2*(npi/2)) THEN
    b = -b
  END IF
  IF (tangent) THEN
    sin = b
  END IF
END IF

! Cosine or tangent.

IF (cosine .OR. tangent) THEN
  IF (ipt >= 0) THEN
    temp%hi = table(1, ipt)
    temp%lo = table(2, ipt)
  ELSE
    temp%hi = - table(1, -ipt)
    temp%lo = - table(2, -ipt)
  END IF
  b = sum2 * temp
  IF (ipt >= 0) THEN
    temp%hi = table(1, 20-ipt)
    temp%lo = table(2, 20-ipt)
  ELSE
    temp%hi = table(1, 20+ipt)
    temp%lo = table(2, 20+ipt)
  END IF
  b = sum1 * temp - b
  IF (npi /= 2*(npi/2)) THEN
    b = -b
  END IF
END IF

! Tangent.

IF (tangent) THEN

! Check that bhi .ne. 0

  IF (b%hi == 0.d0) THEN
    WRITE(*, *) ' *** Infinite tangent - routine longcst ***'
    b%hi = HUGE(one)
    b%lo = 0.d0
    RETURN
  END IF
  b = sin / b
END IF

RETURN
END SUBROUTINE longcst

FUNCTION longasin(a) RESULT(b)

! Quadratic-precision arc sine (about 31 decimals).
! One Newton-Raphson iteration to solve:  f(b) = sin(b) - a = 0,
! except when a close to -1 or +1.
! The result (b) may occupy the same location as the input values (a).
! Use ACOS when |a| is close to 1.

TYPE (quad), INTENT(IN) :: a
TYPE (quad)             :: b

! Local variables
TYPE (quad)  :: y, c

! Check that -1 <= a%hi <= +1.

IF (a%hi < -1._dp .OR. a%hi > 1._dp) THEN
  WRITE(*, *) ' *** Argument outside range for longasin ***'
  RETURN
END IF

IF (ABS(a%hi) < 0.866) THEN
  ! First approximation is  y = asin(a).
  ! Quadruple-precision result is  y - [sin(y) - a]/cos(y).

  y%hi = ASIN(a%hi)
  y%lo = zero
  b = y + (a - SIN(y)) / COS(y%hi)
ELSE
  ! Calculate acos(c) where c = sqrt(1 - a^2)
  c = SQRT(one - a*a)
  y%hi = ACOS(c%hi)
  y%lo = zero
  b = y + (COS(y) - c) / SIN(y%hi)
  IF (a%hi < zero) b = -b
END IF

RETURN
END FUNCTION longasin

FUNCTION longacos(a) RESULT(b)

! Quadratic-precision arc cosine (about 31 decimals).
! Newton-Raphson iteration to solve: f(b) = cos(b) - a = 0.
! The result (b) may occupy the same location as the input values (a).
! When |a| is near 1, use formula from p.175 of
! `Software Manual for the Elementary Functions' by W.J. Cody, Jr. &
! W. Waite, Prentice-Hall, 1980.

TYPE (quad), INTENT(IN) :: a
TYPE (quad)             :: b

! Local variables
TYPE (quad)  :: y, c

! Check that -1 <= a%hi <= +1.

IF (a%hi < -1._dp .OR. a%hi > 1._dp) THEN
  WRITE(*, *) ' *** Argument outside range for longacos ***'
  RETURN
END IF

IF (ABS(a%hi) < 0.866) THEN
  ! First approximation is  y = acos(a).
  ! Quadruple-precision result is  y + [cos(y) - a]/sin(y).

  y%hi = ACOS(a%hi)
  y%lo = 0._dp
  b = y + (COS(y) - a) / SIN(y%hi)
ELSE
  ! Calculate 2.asin(c) where c = sqrt([1 - |a|]/2)
  c = SQRT((one - ABS(a))/2)
  y%hi = ASIN(c%hi)
  y%lo = zero
  b = (y - (SIN(y) - c) / COS(y%hi))*2
  IF (a%hi < zero) b = pi - b
END IF

RETURN
END FUNCTION longacos

FUNCTION longatan(a) RESULT(b)

! Quadratic-precision arc tangent (about 31 decimals).
! Newton-Raphson iteration to solve: f(b) = tan(b) - a = 0.
! The result (b) may occupy the same location as the input values (a).

TYPE (quad), INTENT(IN) :: a
TYPE (quad)             :: b

! Local variables
TYPE (quad)  :: y

! First approximation is  y = atan(a).
! Quadruple-precision result is  y - [tan(y) - a] * cos(y)**2.

y%hi = ATAN(a%hi)
y%lo = 0._dp
b = y - (TAN(y) - a) * (COS(y%hi))**2

RETURN
END FUNCTION longatan

FUNCTION qatan2(y, x) RESULT(b)

! Quadratic-precision arc tangent (about 31 decimals).
! As for arc tangent (y/x) except that the result is in the range
!       -pi < ATAN2 <= pi.
! The signs of x and y determine the quadrant.

TYPE (quad), INTENT(IN) :: y, x
TYPE (quad)             :: b

! Local variables
TYPE (quad)  :: z

! First approximation is  z = atan2(y, x).
! Quadruple-precision result is  z - [tan(z) - (y/x)] * cos(z)**2.

z%hi = ATAN2(y%hi, x%hi)
z%lo = 0._dp
IF (x%hi == zero) THEN
  b = z
ELSE
  b = z - (TAN(z) - y/x) * (COS(z%hi))**2
END IF

RETURN
END FUNCTION qatan2

FUNCTION quad_sum(a) RESULT(s)

! Quadruple-precision SUM

TYPE (quad), INTENT(IN), DIMENSION(:) :: a
TYPE (quad)                           :: s

! Local variables

INTEGER :: i

s = quad(zero, zero)

DO i = 1, SIZE(a)
  s = s + a(i)
END DO

RETURN
END FUNCTION quad_sum

FUNCTION quad_dot_product(a, b) RESULT(ab)

! Quadruple-precision DOT_PRODUCT

TYPE (quad), INTENT(IN), DIMENSION(:) :: a, b
TYPE (quad)                           :: ab

! Local variables

INTEGER :: i, n

ab = quad(zero, zero)
n = SIZE(a)
IF (n /= SIZE(b)) THEN
  WRITE(*, *) ' ** Error invoking DOT_PRODUCT - different argument sizes **'
  WRITE(*, '(a, i10, a, i10)') ' Size of 1st argument = ', n,   &
                               '   Size of 2nd argument = ', SIZE(b)
  RETURN
END IF

DO i = 1, n
  ab = ab + a(i)*b(i)
END DO

RETURN
END FUNCTION quad_dot_product

FUNCTION q_matmul12(a, b) RESULT(ab)

! Quadruple-precision MATMUL
! Rank of A = 1, rank of B = 2

TYPE (quad), INTENT(IN), DIMENSION(:)   :: a
TYPE (quad), INTENT(IN), DIMENSION(:,:) :: b
TYPE (quad), DIMENSION( SIZE(b,2) )     :: ab

! Local variables

INTEGER :: j, na, nb1, nb2

! Check dimensions

na = SIZE(a)
nb1 = SIZE(b, 1)
nb2 = SIZE(b, 2)
IF (na /= nb1) THEN
  WRITE(*, *) ' ** Incompatible dimensions for quad-prec. MATMUL'
  RETURN
END IF

DO j = 1, nb2
  ab(j) = quad_dot_product( a, b(:,j) )
END DO

RETURN
END FUNCTION q_matmul12

FUNCTION q_matmul21(a, b) RESULT(ab)

! Quadruple-precision MATMUL
! Rank of A = 2, rank of B = 1

TYPE (quad), INTENT(IN), DIMENSION(:,:) :: a
TYPE (quad), INTENT(IN), DIMENSION(:)   :: b
TYPE (quad), DIMENSION( SIZE(a,1) )     :: ab

! Local variables

INTEGER :: i, na1, na2, nb

! Check dimensions

na1 = SIZE(a, 1)
na2 = SIZE(a, 2)
nb = SIZE(b)

IF (na2 /= nb) THEN
  WRITE(*, *) ' ** Incompatible dimensions for quad-prec. MATMUL'
  RETURN
END IF

DO i = 1, na1
  ab(i) = quad_dot_product( a(i,:), b )
END DO

RETURN
END FUNCTION q_matmul21

FUNCTION q_matmul22(a, b) RESULT(ab)

! Quadruple-precision MATMUL
! Rank of A = 2, rank of B = 2

TYPE (quad), INTENT(IN), DIMENSION(:,:)     :: a
TYPE (quad), INTENT(IN), DIMENSION(:,:)     :: b
TYPE (quad), DIMENSION(SIZE(a,1),SIZE(b,2)) :: ab

! Local variables

INTEGER :: i, j, na1, na2, nb1, nb2

! Check dimensions

na1 = SIZE(a, 1)
na2 = SIZE(a, 2)
nb1 = SIZE(b, 1)
nb2 = SIZE(b, 2)

IF (na2 /= nb1) THEN
  WRITE(*, *) ' ** Incompatible dimensions for quad-prec. MATMUL'
  RETURN
END IF

DO i = 1, na1
  DO j = 1, nb2
    ab(i,j) = quad_dot_product( a(i,:), b(:,j) )
  END DO
END DO

RETURN
END FUNCTION q_matmul22

SUBROUTINE string_quad(string, value, ier)
! Convert a character string to a quadruple-precision quantity.
! Error indicator ier = 0 if value OK
!                     = 1 if string has > 50 characters and no decimal point
!                            in about the first 45
!                     = 2 if a non-numeric character is read in the mantissa
!                            part

CHARACTER (LEN=*), INTENT(IN) :: string
TYPE (quad), INTENT(OUT)      :: value
INTEGER, INTENT(OUT)          :: ier

! Local variables
CHARACTER (LEN=50)            :: str
INTEGER                       :: length, pos, decpt, status, power10, i, i1, i2
REAL (dp)                     :: sgn, temp
CHARACTER (LEN= 5)            :: expnt

str = ADJUSTL(string)
length = LEN_TRIM( ADJUSTL(string) )
IF (length > 50) THEN
                             ! Truncate string to 50 characters preserving
                             ! the exponent, if present.
  pos = SCAN(string(length-4:length), 'DdEe')
  IF (pos > 0) THEN
    str(45+pos:50) = string(length-5+pos:length)
  END IF
                             ! Check that the string contains a '.'
  IF (INDEX(str, '.') == 0) THEN
    ier = 1
    value = quad(zero, zero)
    RETURN
  END IF
END IF

ier = 0

! Determine sign of mantissa

sgn = +1._dp
IF (str(1:1) == '-') THEN
  sgn = -1._dp
  str = str(2:)
ELSE IF (str(1:1) == '+') THEN
  str = str(2:)
END IF

! Separate the exponent, if there is one

length = LEN_TRIM(str)
IF (length > 4) THEN
  pos = SCAN(str(length-4:length), 'DdEe')
  IF (pos > 0) THEN
    expnt = str(length-5+pos:)
    str(length-5+pos:) = '     '
  ELSE
    expnt = ' '
  END IF
ELSE
  expnt = ' '
END IF

! decpt = position of decimal point

decpt = INDEX(str, '.')
IF (decpt > 0) str = str(:decpt-1) // str(decpt+1:)

! Read str in blocks of up to 9 digits at a time, as a large integer.

i1 = 1
length = LEN_TRIM(str)
value = quad(zero, zero)
DO
  i2 = MIN(i1+8, length)
  READ(str(i1:i2), '(f9.0)', IOSTAT=status) temp
  IF (status /= 0) THEN
    ier = 2
    RETURN
  END IF
  IF (i1 > 1) THEN
    value = value * (10._dp ** (i2+1-i1)) + temp
  ELSE
    value = quad(temp, zero)
  END IF
  i1 = i2 + 1
  IF (i1 > length) EXIT
END DO

IF (sgn < zero) value = -value

! Multiply by appropriate power of 10 for position of the decimal point,
! and the exponent.

IF (expnt == ' ') THEN
  power10 = 0
ELSE
  i = LEN_TRIM(expnt)
  READ(expnt(2:i), '(i4)') power10
END IF
IF (decpt > 0) power10 = power10 - (length + 1 - decpt)

! As 1.D+15 is represented exactly in double-precision IEEE arithmetic,
! multiply by multiples of 1.D+15 or 1.D-15.

IF (power10 == 0) RETURN
IF (power10 < 0) THEN
  DO i = 1, -power10/15
    value = value / 1.D+15
  END DO
  i = MOD(-power10, 15)
  IF (i /= 0) value = value / (10._dp ** i)
ELSE
  DO i = 1, power10/15
    value = value * 1.D+15
  END DO
  i = MOD(power10, 15)
  IF (i /= 0) value = value * (10._dp ** i)
END IF

RETURN
END SUBROUTINE string_quad

SUBROUTINE quad_string(value, string, ier)
! Convert a quadruple-precision quantity to a decimal character string.
! Error indicator ier = 0 if conversion OK
!                     = 1 if the length of the string < 36 characters.

TYPE (quad), INTENT(IN)        :: value
CHARACTER (LEN=*), INTENT(OUT) :: string
INTEGER, INTENT(OUT)           :: ier

! Local variables
CHARACTER (LEN= 1)   :: sgn
CHARACTER (LEN=17)   :: str1, str2
TYPE (quad)          :: val
INTEGER              :: dec_expnt, i
REAL (dp)            :: tmp

IF (LEN(string) < 36) THEN
  ier = 1
  string = '***'
  RETURN
END IF
ier = 0

! Check if value = zero.
IF (value%hi == zero) THEN
  string = ' 0.00'
  RETURN
END IF

IF (value%hi < zero) THEN
  sgn = '-'
  val = - value
ELSE
  sgn = ' '
  val = value
END IF

! Use LOG10 to set the exponent.
dec_expnt = FLOOR( LOG10(val%hi) )

! Get the first 15 decimal digits
IF (dec_expnt /= 14) THEN
  val = val * EXP( LOG(quad(10._dp, zero)) * REAL(14 - dec_expnt) )
END IF
WRITE(str1, '(f16.0)') val%hi

! Calculate the remainder
READ(str1, '(f16.0)') tmp
val = val - tmp

! If val is -ve, subtract 1 from the last digit of str1, and add 1 to val.
IF (val%hi < -0.5D-16) THEN
  tmp = tmp - one
  WRITE(str1, '(f16.0)') tmp
  val = val + one
END IF
val = val * 1.D15

! write the second 15 digits
WRITE(str2, '(f16.0)') val%hi

! If str2 consists of asterisks, add 1 in the last digit to str1.
! Set str2 to zeroes.
IF (str2(2:2) == '*') THEN
  tmp = tmp + one
  WRITE(str1, '(f17.0)') tmp
  IF (str1(1:1) /= ' ') THEN
    dec_expnt = dec_expnt + 1
  ELSE
    str1 = str1(2:17)
  END IF
  str2 = '000000000000000.'
END IF

! Replace leading blanks with zeroes
DO i = 1, 15
  IF (str2(i:i) /= ' ') EXIT
  str2(i:i) = '0'
END DO

! Combine str1 & str2, removing decimal points & adding exponent.
i = INDEX(str1, '.')
str1(i:i) = ' '
str2(16:16) = ' '
string = '.' // TRIM(ADJUSTL(str1)) // TRIM(ADJUSTL(str2)) // 'E'
WRITE(str1, '(i4.2)') dec_expnt+1
string = TRIM(string) // ADJUSTL(str1)

! Restore the sign.
IF (sgn == '-') THEN
  string = '-' // ADJUSTL(string)
ELSE
  string = ADJUSTL(string)
END IF

RETURN
END SUBROUTINE quad_string

FUNCTION q_epsilon(x) RESULT(eps)
! Returns the machine accuracy.
! eps is the smallest value such that x.(1 + eps) > x for all x.
! This value is machine dependent.   It has been checked only for the
! the following PC compilers:
! Lahey's ELF90
! Lahey/Fujitsi LF95
! Compaq (Digital) DVF5

TYPE (quad), INTENT(IN)  :: x
TYPE (quad)              :: eps

eps = quad(0.6163e-32_dp, 0.0_dp)

RETURN
END FUNCTION q_epsilon

END MODULE quadruple_precision_df


subroutine gmres_Laplace_pa(x,d,w,bg,dg,ien,id,&
		ne_local,ien_local,nn_local,node_local,send_address,ad_length,&
		global_com,nn_global_com,local_com,nn_local_com)
	use fluid_variables, only: nsd,nn,ne,nen
	use mpi_variables
	implicit none
	include 'mpif.h'
	integer inner, outer
	parameter (inner = 100) ! Laplace equation inner 50 should be sufficient
	parameter (outer = 10)  ! Laplace equation outer 5 should be sufficient
	integer ien(nen,ne)
	real* 8 x(nsd,nn)
	real* 8 d(nn)
	real* 8 bg(nn), dg(nn), w(nn)
	real* 8 Hm(inner+1,inner) !Henssenberg matrix
	real* 8 Vm(nn_local, inner+1) ! Krylov space matrix
!--------------------------------
	integer id(nn)
!--------------------------------
	integer i,j,iouter,icount,INFO
	real* 8  e1(inner+1)
	real* 8 x0(nn)
	real* 8 beta(inner+1)
	real* 8 eps
	real* 8 r0(nn)
	real* 8 rnorm, rnorm0,err
        real* 8 dv(nn)
	real* 8 Vy(nn)
        real* 8 avloc(nn)
	real* 8 temp
	character(1) TRAN
	real* 8 workls(2*inner)
!-------------------------------
! MPI varibalbes
  integer ne_local ! # of element on each processor
  integer ien_local(ne_local) ! subregion-->wholeregion element index
  integer ie_local ! loop parameter
  integer node_local(nn_local)
  integer nn_local
  integer node
  integer nn_global_com
  integer global_com(nn_global_com)  ! global node index for communication
  integer nn_local_com
  integer local_com(nn_local_com)  ! local index in the communication region on each processor
  integer ad_length
  integer send_address(ad_length,2)
  real(8) dg_sent(nn)
  real(8) space1(inner)
  real(8) space2(inner)

	eps = 1.0e-6
	e1(:) = 0.0
	e1(1) = 1
	x0(:) = 0.0
	iouter = 1
	r0(:) = bg(:)
	TRAN = 'N'
	avloc(:) = 0.0
!	w(:) = 1
        call getnorm_pa(r0,1,nn,node_local,nn_local,rnorm0)
        rnorm = sqrt(rnorm0)
if (myid == 0) write(*,*) 'rnorm0', rnorm0
!do icount=1,nn
!	write(*,*) 'node id',icount, id(icount)
!end do

!!!!!!!!!!!!!!!start outer loop!!!!!!!!!
	do 111, while((iouter .le. outer) .and. (rnorm .ge. eps))

	Vm(:,:) = 0.0
	do icount = 1, nn_local
	node=node_local(icount)
	   Vm(icount,1) = r0(node)/rnorm
	end do ! get V1

	   beta(:) = rnorm*e1(:) ! get beta*e1
	   Hm(:,:) = 0.0
!!!!!!!!!!!!!!!!start inner loop!!!!!!!!!!!!!
	   do j=1,inner

		dv(:) = 0.0d0

		 do icount=1, nn_local
		 node=node_local(icount)
		    dv(node) = 1.0/w(node)*Vm(icount,j)
		 end do!!!!!!!!!!calcule eps*inv(P)*V1

                call communicate_res_ad_sub(dv,1,nn,send_address,ad_length)

		avloc(:) = 0.0d0
		call blockgmres_Laplace(x,dv,avloc,ien,ien_local,ne_local)
!		avloc(:) = (-avloc(:)+bg(:))/eps ! get Av,bg=-r(u)
                call communicate_res_ad_sub(avloc,1,nn,send_address,ad_length)
		call setid_pa(avloc,1,nn,id,node_local,nn_local)
		continue

	space1(:)=0.0d0
	space2(:)=0.0d0

		do i=1,j
		 do icount = 1, nn_local
		   node=node_local(icount)
		   space1(i) = space1(i)+avloc(node)*Vm(icount,i)
		 end do
		end do

		call mpi_barrier(mpi_comm_world,ierror)
		call mpi_allreduce(space1(1),space2(1),j,mpi_double_precision,mpi_sum,mpi_comm_world,ierror)
		Hm(1:j,j)=space2(1:j)

	      do icount = 1, nn_local
	      	node=node_local(icount)
		 do i=1,j
		   Vm(icount,j+1) = Vm(icount,j+1)-Hm(i,j)*Vm(icount,i)
		 end do
		 Vm(icount,j+1)=Vm(icount,j+1)+avloc(node)
	      end do  ! construct v(j+1)

temp=0.0d0
	      do icount = 1, nn_local
		 temp= temp + Vm(icount,j+1)*Vm(icount,j+1)
	      end do

                call mpi_barrier(mpi_comm_world,ierror)
		call mpi_allreduce(temp,rnorm0,1,mpi_double_precision,mpi_sum,mpi_comm_world,ierror)

	      Hm(j+1,j) = sqrt(rnorm0)

	      do icount = 1, nn_local
 		 Vm(icount,j+1)=Vm(icount,j+1)/Hm(j+1,j)
	      end do
	  end do  ! end inner loop

!==========================================================================
!	call DGELS(TRAN,inner+1,inner,1,Hm,inner+1,beta,inner+1,workls,2*inner,INFO)
	call mpi_barrier(mpi_comm_world,ierror)

	call givens(Hm,inner,beta)
!!!!!!!!!!!!beta(1:inner) is ym, the solution!!!!!!!!!!!!!!!!!!!!!!!!!
	Vy(:) = 0
	do icount=1,nn_local
	node=node_local(icount)
	   do i=1,inner
	      Vy(node)=Vy(node)+Vm(icount,i)*beta(i)
	   end do
	   x0(node)=x0(node)+Vy(node)
	end do ! calculate Xm
!write(*,*)'x0=',x0(:)

!        do icount=1,nn_local
!	node=global_com(local_com(icount))
!	dv(node)=0.0d0
!	end do

	dv(:)=0.0d0

	do icount = 1, nn_local
	   node = node_local(icount)
	   dv(node) = 1.0/w(node)*x0(node)
	end do

        call communicate_res_ad_sub(dv,1,nn,send_address,ad_length)

	avloc(:) = 0.0d0
	call blockgmres_Laplace(x,dv,avloc,ien,ien_local,ne_local)
!	avloc(:) = (-avloc(:)+bg(:))/eps
        call communicate_res_ad_sub(avloc,1,nn,send_address,ad_length)
        call setid_pa(avloc,1,nn,id,node_local,nn_local)

!!!!!!!!!!calculate AXm

	do icount=1,nn_local
	node=node_local(icount)
	   r0(node) = bg(node)-avloc(node)
	end do !update r0=f-AX0
	call getnorm_pa(r0,1,nn,node_local,nn_local,rnorm0)
	err = sqrt(rnorm0)

	rnorm = sqrt(rnorm0)
	iouter = iouter + 1

if (myid == 0)	write(*,*) '***** Indicator Laplace Eq err******=',err
111     continue  ! end outer loop
!write(*,*)'x0_2=',x0(:)

	dg_sent(:)=0.0d0
	do icount=1,nn_local
		node=node_local(icount)
		dg_sent(node)=1.0/w(node)*x0(node)
	end do
	dg(:)=0.0d0
	call mpi_barrier(mpi_comm_world,ierror)
	call mpi_allreduce(dg_sent(1),dg(1),nn,mpi_double_precision,mpi_sum,mpi_comm_world,ierror)
	call mpi_barrier(mpi_comm_world,ierror)
	return
	end