      SUBROUTINE DTWODQ(F,AA,BB,G,H,TOL,ERE,IR_0,RESULT,ERROR)

C***BEGIN PROLOGUE  TWODQ
C***DATE WRITTEN   840518   (YYMMDD)
C***REVISION DATE  840518   (YYMMDD)
C***CATEGORY NO.  D1I
C***KEYWORDS  QUADRATURE,TWO DIMENSIONAL,ADAPTIVE,CUBATURE
C***AUTHOR KAHANER,D.K.,N.B.S.
C          RECHARD,O.W.,N.B.S.
C          BARNHILL,ROBERT,UNIV. OF UTAH
C***PURPOSE  To compute the two-dimensional integral of a function
C            F over a region consisting of N triangles.
C***DESCRIPTION
C
C   This subroutine computes the two-dimensional integral of a
C   function F over a region consisting of N triangles.
C   A total error estimate is obtained and compared with a
C   tolerance - TOL - that is provided as input to the subroutine.
C   The error tolerance is treated as either relative or absolute
C   depending on the input value of IFLAG.  A 'Local Quadrature
C   Module' is applied to each input triangle and estimates of the
C   total integral and the total error are computed.  The local
C   quadrature module is either subroutine LQM0 or subroutine
C   LQM1 and the choice between them is determined by the
C   value of the input variable ICLOSE.
C
C   If the total error estimate exceeds the tolerance, the triangle
C   with the largest absolute error is divided into two triangles
C   by a median to its longest side.  The local quadrature module
C   is then applied to each of the subtriangles to obtain new
C   estimates of the integral and the error.  This process is
C   repeated until either (1) the error tolerance is satisfied,
C   (2) the number of triangles generated exceeds the input
C   parameter MAXTRI, (3) the number of integrand evaluations
C   exceeds the input parameter MEVALS, or (4) the subroutine
C   senses that roundoff error is beginning to contaminate
C   the result.
C
C   The user must specify MAXTRI, the maximum number of triangles
C   in the final triangulation of the region, and provide two
C   storage arrays - DATA and IWORK - whose sizes are at least
C   9*MAXTRI and 2*MAXTRI respectively.  The user must also
C   specify MEVALS, the maximum number of function evaluations
C   to be allowed.  This number will be effective in limiting
C   the computation only if it is less than 94*MAXTRI when LQM1
C   is specified or 56*MAXTRI when LQM0 is specified.
C
C   After the subroutine has returned to the calling program
C   with output values, it can be called again with a smaller
C   value of TOL and/or a different value of MEVALS.  The tolerance
C   can also be changed from relative to absolute
C   or vice-versa by changing IFLAG.  Unless
C   the parameters NU and ND are reset to zero the subroutine
C   will restart with the final set of triangles and output
C   values from the previous call.
C
C   ARGUMENTS:
C
C   F function subprogram defining the integrand F(u,v);
C     the actual name for F needs to be declared EXTERNAL
C     by the calling program.
C
C   N the number of input triangles.
C
C   X a 3 by N array containing the abscissae of the vertices
C     of the N triangles.
C
C   Y a 3 by N array containing the ordinates of the vertices
C     of the N triangles
C
C   TOL the desired bound on the error.  If IFLAG=0 on input,
C       TOL is interpreted as a bound on the relative error;
C       if IFLAG=1, the bound is on the absolute error.
C
C   ICLOSE an integer parameter that determines the selection
C          of LQM0 or LQM1.  If ICLOSE=1 then LQM1 is used.
C          Any other value of ICLOSE causes LQM0 to be used.
C          LQM0 uses function values only at interior points of
C          the triangle.  LQM1 is usually more accurate than LQM0
C          but involves evaluating the integrand at more points
C          including some on the boundary of the triangle.  It
C          will usually be better to use LQM1 unless the integrand
C          has singularities on the boundary of the triangle.
C
C   MAXTRI The maximum number of triangles that are allowed
C          to be generated by the computation.
C
C   MEVALS  The maximum number of function evaluations allowed.
C
C   RESULT output of the estimate of the integral.
C
C   ERROR output of the estimate of the absolute value of the
C         total error.
C
C   NU an integer variable used for both input and output.   Must
C      be set to 0 on first call of the subroutine.  Subsequent
C      calls to restart the subroutine should use the previous
C      output value.
C
C   ND an integer variable used for both input and output.  Must
C      be set to 0 on first call of the subroutine.  Subsequent
C      calls to restart the subroutine should use the previous
C      output value.
C
C   NEVALS  The actual number of function evaluations performed.
C
C   IFLAG on input:
C        IFLAG=0 means TOL is a bound on the relative error;
C        IFLAG=1 means TOL is a bound on the absolute error;
C        any other input value for IFLAG causes the subroutine
C        to return immediately with IFLAG set equal to 9.
C
C        on output:
C        IFLAG=0 means normal termination;
C        IFLAG=1 means termination for lack of space to divide
C                another triangle;
C        IFLAG=2 means termination because of roundoff noise
C        IFLAG=3 means termination with relative error <=
C                5.0* machine epsilon;
C        IFLAG=4 means termination because the number of function
C                evaluations has exceeded MEVALS.
C        IFLAG=9 means termination because of error in input flag
C
C   DATA a one dimensional array of length >= 9*MAXTRI
C        passed to the subroutine by the calling program.  It is
C        used by the subroutine to store information
C        about triangles used in the quadrature.
C
C   IWORK  a one dimensional integer array of length >= 2*MAXTRI
C          passed to the subroutine by the calling program.
C          It is used by the subroutine to store pointers
C          to the information in the DATA array.
C
C
C   The information for each triangle is contained in a nine word
C   record consisting of the error estimate, the estimate of the
C   integral, the coordinates of the three vertices, and the area.
C   These records are stored in the DATA array
C   that is passed to the subroutine.  The storage is organized
C   into two heaps of length NU and ND respectively.  The first heap
C   contains those triangles for which the error exceeds
C   epsabs*a/ATOT where epsabs is a bound on the absolute error
C   derived from the input tolerance (which may refer to relative
C   or absolute error), a is the area of the triangle, and ATOT
C   is the total area of all triangles.  The second heap contains
C   those triangles for which the error is less than or equal to
C   epsabs*a/ATOT.  At the top of each heap is the triangle with
C   the largest absolute error.
C
C   Pointers into the heaps are contained in the array IWORK.
C   Pointers to the first heap are contained
C   between IWORK(1) and IWORK(NU).  Pointers to the second
C   heap are contained between IWORK(MAXTRI+1) and
C   IWORK(MAXTRI+ND).  The user thus has access to the records
C   stored in the DATA array through the pointers in IWORK.
C   For example, the following two DO loops will print out
C   the records for each triangle in the two heaps:
C
C     DO 10 I=1,NU
C       PRINT*,(DATA(IWORK(I)+J),J=0,8)
C    10  CONTINUE
C     DO 20 I=1,ND
C       PRINT*,(DATA(IWORK(MAXTRI+I)+J),J=0,8
C    20  CONTINUE
C
C   When the total number of triangles is equal to
C   MAXTRI, the program attempts to remove a triangle from the
C   bottom of the second heap and continue.  If the second heap
C   is empty, the program returns with the current estimates of
C   the integral and the error and with IFLAG set equal to 1.
C   Note that in this case the actual number of triangles
C   processed may exceed MAXTRI and the triangles stored in
C   the DATA array may not constitute a complete triangulation
C   of the region.
C
C   The following sample program will calculate the integral of
C   cos(x+y) over the square (0.,0.),(1.,0.),(1.,1.),(0.,1.) and
C   print out the values of the estimated integral, the estimated
C   error, the number of function evaluations, and IFLAG.
C
C     real*8 X(3,2),Y(3,2),DATA(450),RES,ERR
C     INTEGER IWORK(100),NU,ND,NEVALS,IFLAG
C     EXTERNAL F
C     X(1,1)=0.
C     Y(1,1)=0.
C     X(2,1)=1.
C     Y(2,1)=0.
C     X(3,1)=1.
C     Y(3,1)=1.
C     X(1,2)=0.
C     Y(1,2)=0.
C     X(2,2)=1.
C     Y(2,2)=1.
C     X(3,2)=0.
C     Y(3,2)=1.
C     NU=0
C     ND=0
C     IFLAG=1
C     CALL TWODQ(F,2,X,Y,1.E-04,1,50,4000,RES,ERR,NU,ND,
C    *  NEVALS,IFLAG,DATA,IWORK)
C     PRINT*,RES,ERR,NEVALS,IFLAG
C     END
C     FUNCTION F(X,Y)
C     F=COS(X+Y)
C     RETURN
C     END
C
C***REFERENCES  (NONE)
C
C***ROUTINES CALLED  HINITD,HINITU,HPACC,HPDEL,HPINS,LQM0,LQM1,
C                    TRIDV,R1MACH
C***END PROLOGUE  TWODQ
      integer n,iflag,nevals,iclose,nu,nd,mevals,iwork(200),maxtri
      real*8 f,x(3,2),y(3,2),data(900),tol,result,error
      REAL*8 AA,BB,G,H,ERE
      INTEGER IR_0
      integer rndcnt
      logical full
      logical GREATR
      real*8 dat05
      real*8 a,r,e,u(3),v(3),node(9),node1(9),node2(9),
     *  epsabs,EMACH,R1MACH,ATOT,fadd,newres,newerr
      save ATOT
      external f,GREATR
      EXTERNAL G,H,R1MACH

      EMACH = R1MACH(4)

      N = 2
      X(1,1) = AA
      Y(1,1) = G(AA)
      X(2,1) = BB
      Y(2,1) = G(BB)
      X(3,1) = BB
      Y(3,1) = H(BB)
      X(1,2) = AA
      Y(1,2) = G(AA)
      X(2,2) = BB
      Y(2,2) = H(BB)
      X(3,2) = AA
      Y(3,2) = H(AA)
      NU = 0
      ND = 0
      IFLAG = 1
      ICLOSE = 1
      MAXTRI = 100
      MEVALS = 8000

c
c      If heaps are empty, apply LQM to each input triangle and
c      place all of the data on the second heap.
c
      if((nu+nd).eq.0) then
      call HINITU(maxtri,9,nu,iwork)
      call HINITD(maxtri,9,nd,iwork(maxtri+1))
      ATOT=0.0
      result=0.0
      error=0.0
      rndcnt=0
      nevals=0
      do 20 i=1,n
        do 10 j=1,3
          u(j)=x(j,i)
          v(j)=y(j,i)
   10     continue
        a=0.5*abs(u(1)*v(2)+u(2)*v(3)+u(3)*v(1)
     1        -u(1)*v(3)-u(2)*v(1)-u(3)*v(2))
        ATOT=ATOT+a
        if(iclose.eq.1) then
          call LQM1(f,u,v,r,e)
          nevals=nevals+47
        else
          call LQM0(f,u,v,r,e)
          nevals=nevals+28
        end if
        result=result+r
        error=error+e
        node(1)=e
        node(2)=r
        node(3)=x(1,i)
        node(4)=y(1,i)
        node(5)=x(2,i)
        node(6)=y(2,i)
        node(7)=x(3,i)
        node(8)=y(3,i)
        node(9)=a
        call HPINS(maxtri,9,data,nd,iwork(maxtri+1),node,GREATR)
  20  continue
      end if
c
c      Check that input tolerance is consistent with
c      machine epsilon.
c
      if(iflag.eq.0) then
        if(tol.le.5.0*EMACH) then
          tol=5.0*EMACH
          fadd=3
        else
          fadd=0
        end if
        epsabs=tol*abs(result)
      else if(iflag.eq.1) then
        if(tol.le.5.0*EMACH*abs(result)) then
          epsabs=5.0*EMACH*abs(result)
        else
          fadd=0
          epsabs=tol
        end if
      else
        iflag=9
        return
      end if
c
c      Adjust the second heap on the basis of the current
c      value of epsabs.
c
   2  if(nd.eq.0) go to 40
        j=nd
   3    if(j.eq.0) go to 40
          call HPACC(maxtri,9,data,nd,iwork(maxtri+1),node,j)
          if(node(1).gt.epsabs*node(9)/ATOT) then
            call HPINS(maxtri,9,data,nu,iwork,node,GREATR)
            call HPDEL(maxtri,9,data,nd,iwork(maxtri+1),GREATR,j)
            if(j.gt.nd) j=j-1
          else
            j=j-1
          endif
        go to 3
c
c      Beginning of main loop from here to end
c
  40  if(nevals.ge.mevals) then
        iflag=4
        return
      end if
      if(error.le.epsabs) then
        if(iflag.eq.0) then
          if(error.le.abs(result)*tol) then
            iflag=fadd
            return
          else
            epsabs=abs(result)*tol
            go to 2
          end if
        else
          if(error.le.tol) then
            iflag=0
            return
          else if(error.le.5.0*EMACH*abs(result)) then
            iflag=3
            return
          else
            epsabs=5.0*EMACH*abs(result)
            go to 2
          end if
        end if
      end if
c
c      If there are too many triangles and second heap
c      is not empty remove bottom triangle from second
c      heap.  If second heap is empty return with iflag
c      set to 1 or 4.
c
      if((nu+nd).ge.maxtri) then
        full=.true.
        if(nd.gt.0) then
          iwork(nu+1)=iwork(maxtri+nd)
          nd=nd-1
        else
          iflag=1
          return
        end if
      else
        full=.false.
      end if
c
c      Find triangle with largest error, divide it in
c      two, and apply LQM to each half.
c
      if(nd.eq.0) then
        call HPACC(maxtri,9,data,nu,iwork,node,1)
        call HPDEL(maxtri,9,data,nu,iwork,GREATR,1)
      else if(nu.eq.0) then
        call HPACC(maxtri,9,data,nd,iwork(maxtri+1),node,1)
        call HPDEL(maxtri,9,data,nd,iwork(maxtri+1),GREATR,1)
      else if(data(iwork(1)).ge.data(iwork(maxtri+1))) then
        if(full) iwork(maxtri+nd+2)=iwork(nu)
        call HPACC(maxtri,9,data,nu,iwork,node,1)
        call HPDEL(maxtri,9,data,nu,iwork,GREATR,1)
      else
        if(full) iwork(nu+2)=iwork(maxtri+nd)
        call HPACC(maxtri,9,data,nd,iwork(maxtri+1),node,1)
        call HPDEL(maxtri,9,data,nd,iwork(maxtri+1),GREATR,1)
      end if
      dat05 = 0.5
      call tridv(node,node1,node2,dat05,1)
      do 60 j=1,3
        u(j)=node1(2*j+1)
        v(j)=node1(2*j+2)
  60  continue
      if(iclose.eq.1) then
        call LQM1(f,u,v,node1(2),node1(1))
        nevals=nevals+47
      else
        call LQM0(f,u,v,node1(2),node1(1))
        nevals=nevals+28
      end if
      do 70 j=1,3
        u(j)=node2(2*j+1)
        v(j)=node2(2*j+2)
  70  continue
      if(iclose.eq.1) then
        call LQM1(f,u,v,node2(2),node2(1))
        nevals=nevals+47
      else
        call LQM0(f,u,v,node2(2),node2(1))
        nevals=nevals+28
      end if
      newerr=node1(1)+node2(1)
      newres=node1(2)+node2(2)
      if(newerr.gt.0.99*node(1)) then
        if(abs(node(2)-newres).le.1.E-04*abs(newres)) rndcnt=rndcnt+1
      end if
      result=result-node(2)+newres
      error=error-node(1)+newerr
      if(node1(1).gt.node1(9)*epsabs/ATOT) then
        call HPINS(maxtri,9,data,nu,iwork,node1,GREATR)
      else
        call HPINS(maxtri,9,data,nd,iwork(maxtri+1),node1,GREATR)
      end if
      if(node2(1).gt.node2(9)*epsabs/ATOT) then
        call HPINS(maxtri,9,data,nu,iwork,node2,GREATR)
      else
        call HPINS(maxtri,9,data,nd,iwork(maxtri+1),node2,GREATR)
      end if
      if(rndcnt.ge.20) then
        iflag=2
        return
      end if
      if(iflag.eq.0) then
        if(epsabs.lt.0.5*tol*abs(result)) then
          epsabs=tol*abs(result)
          j=nu
   5      if(j.eq.0) go to 40
          call HPACC(maxtri,9,data,nu,iwork,node,j)
          if(node(1).le.epsabs*node(9)/ATOT) then
            call HPINS(maxtri,9,data,nd,iwork(maxtri+1),node,GREATR)
            call HPDEL(maxtri,9,data,nu,iwork,GREATR,j)
            if(j.gt.nu) j=j-1
          else
            j=j-1
          end if
          go to 5
        end if
      end if
      go to 40
      end

      LOGICAL FUNCTION GREATR(A,B,NWDS)
      INTEGER NWDS
      real*8 A(NWDS), B(NWDS)
      GREATR= A(1) .GT. B(1)
      RETURN
      END

      SUBROUTINE HINITD(NMAX,NWDS,N,T)
C   PURPOSE
C         THIS ROUTINE INITIALIZES THE HEAP PROGRAMS WITH T(NMAX)
C         POINTING TO THE TOP OF THE HEAP.
C         IT IS CALLED ONCE AT THE START OF EACH NEW CALCULATION.
C   INPUT
C         NMAX=MAXIMUM NUMBER OF NODES ALLOWED BY USER
C         NWDS=NUMBER OF WORDS PER NODE
C   OUTPUT
C         N=CURRENT NUMBER OF NODES IN HEAP = 0.
C         T=INTEGER ARRAY OF POINTERS TO POTENTIAL HEAP NODES.
C
      INTEGER T(1)
      DO 1 I=1,NMAX
    1  T(I)=(NMAX-I)*NWDS+1
      N=0
      RETURN
      END

      SUBROUTINE HINITU(NMAX,NWDS,N,T)
C        H E A P  PACKAGE
C          A COLLECTION OF PROGRAMS WHICH MAINTAIN A HEAP DATA
C          STRUCTURE.  BY CALLING THESE SUBROUTINES IT IS POSSIBLE TO
C          INSERT, DELETE, AND ACCESS AN EXISTING HEAP OR TO BUILD A
C          NEW HEAP FROM AN UNORDERED COLLECTION OF NODES. THE HEAP
C          FUNCTION IS AN ARGUMENT TO THE SUBROUTINES ALLOWING VERY
C          GENERAL ORGANIZATIONS.
C            THE USER MUST DECIDE ON THE MAXIMUM NUMBER OF NODES
C          ALLOWED AND DIMENSION THE real*8 ARRAY DATA AND THE INTEGER
C          ARRAY T USED INTERNALLY BY THE PACKAGE.  THESE VARIABLES ARE
C          THEN PASSED THROUGH THE CALL SEQUENCE BETWEEN THE HEAP
C          PROGRAMS BUT ARE NOT IN GENERAL ACCESSED BY THE USER.  HE
C          MUST ALSO PROVIDE A HEAP FUNCTION WHOSE NAME MUST BE INCLUD-
C          ED IN AN EXTERNAL STATEMENT IN THE USER PROGRAM WHICH CALLS
C          THE HEAP SUBROUTINES.  TWO SIMPLE HEAP FUNCTIONS ARE
C          PROVIDED WITH THE PACKAGE.
C
C
C   PURPOSE
C         THIS ROUTINE INITIALIZES THE HEAP PROGRAMS WITH T(1)
C         POINTING TO THE TOP OF THE HEAP.
C         IT IS CALLED ONCE AT THE START OF EACH NEW CALCULATION
C   INPUT
C         NMAX = MAXIMUM NUMBER OF NODES ALLOWED BY USER.
C         NWDS = NUMBER OF WORDS PER NODE
C   OUTPUT
C         N = CURRENT NUMBER OF NODES IN HEAP = 0.
C         T = INTEGER ARRAY OF POINTERS TO POTENTIAL HEAP NODES.
C
      INTEGER T(1)
      DO 1 I = 1, NMAX
    1    T(I)=(I-1)*NWDS+1
      N = 0
      RETURN
      END

      SUBROUTINE HPACC(NMAX,NWDS,DATA,N,T,XNODE,K)
C
C   PURPOSE
C          TO ACCESS THE K-TH NODE OF THE HEAP,
C          1 .LE. K .LE. N .LE. NMAX
C   INPUT
C        NMAX = MAXIMUM NUMBER OF NODES ALLOWED BY USER.
C        DATA = WORK AREA FOR STORING NODES.
C        N = CURRENT NUMBER OF NODES IN THE HEAP.
C        T = INTEGER ARRAY OF POINTERS TO HEAP NODES.
C        XNODE = A real*8 ARRAY, NWDS WORDS LONG, IN WHICH NODAL IN-
C          FORMATION WILL BE INSERTED.
C        K = THE INDEX OF THE NODE TO BE FOUND AND INSERTED INTO
C                XNODE.
C
C   OUTPUT
C        XNODE =  A real*8 ARRAY.    CONTAINS IN XNODE(1),...,XNODE(NWDS)
C          THE ELEMENTS OF THE K-TH NODE.
C
      real*8 DATA(1), XNODE(1)
      INTEGER T(1)
      IF (K .LT. 1 .OR. K .GT. N .OR. N .GT. NMAX) RETURN
      J=T(K)-1
      DO 1 I=1,NWDS
         IPJ=I+J
    1    XNODE(I)=DATA(IPJ)
      RETURN
      END

      SUBROUTINE HPBLD(NMAX,NWDS,DATA,N,T,HPFUN)
C
C   PURPOSE
C          BUILDS A HEAP, IN  T , FROM AN ARRAY OF  N  ELEMENTS
C            IN DATA, WHICH ARE SPACED NWDS APART.
C            AT CONCLUSION OF CALCULATION  THE TOP SATISFIES
C            HPFUN(TOP,SON) = .TRUE. FOR ANY SON.
C          USES SUBROUTINE HPGRO BY FEEDING IT ONE ELEMENT OF
C          THE ARRAY AT A TIME.
C
C   INPUT
C         NMAX = MAXIMUN NUMBER OF NODES ALLOWED BY USER.
C         NWDS = NUMBER OF WORDS PER NODE.
C         DATA = WORK AREA IN WHICH THE NODES ARE STORED.
C         N = CURRENT NUMBER OF NODES.
C         T = INTEGER ARRAY OF POINTERS TO HEAP NODES.
C         HPFUN = NAME OF USER WRITTEN FUNCTION TO DETERMINE TOP NODE.
C   OUTPUT
C         DATA = WORK AREA IN WHICH THE NODES ARE STORED.
C         T = INTEGER ARRAY OF POINTERS TO HEAP NODES.
C              IN PARTICULAR T(1) POINTS TO THE TOP.
C
      EXTERNAL HPFUN
      LOGICAL HPFUN
      real*8 DATA(1)
      INTEGER T(1)
      IF(NMAX .LT. N) RETURN
      INDEX = N/2
    1 CONTINUE
      IF( INDEX .EQ. 0) RETURN
         CALL HPGRO(NMAX,NWDS,DATA,N,T,HPFUN,INDEX)
         INDEX = INDEX-1
         GO TO 1
      END

      SUBROUTINE HPDEL(NMAX,NWDS,DATA,N,T,HPFUN,K)
C
C   PURPOSE
C          DELETE K-TH ELEMENT OF HEAP.  RESULTING TREE IS REHEAPED.
C   INPUT
C         NMAX = MAXIMUN NUMBER OF NODES ALLOWED BY USER.
C         NWDS = NUMBER OF WORDS PER NODE.
C         DATA = WORK AREA IN WHICH THE NODES ARE STORED.
C        N = CURRENT NUMBER OF NODES.
C        T = INTEGER ARRAY OF POINTERS TO NODES.
C         HPFUN = NAME OF USER WRITTEN FUNCTION TO DETERMINE TOP NODE.
C         K = INDEX OF NODE TO BE DELETED
C   OUTPUT
C         N = UPDATED NUMBER OF NODES.
C         T = UPDATED INTEGER POINTER ARRAY TO NODES.
C
      EXTERNAL HPFUN
      LOGICAL HPFUN
      real*8 DATA(1)
      INTEGER T(1)
      IF(N .EQ. 0) RETURN
      IF(K.EQ.N) THEN
        N=N-1
        RETURN
      END IF
      KDEL=K
      JUNK=T(KDEL)
      T(KDEL)=T(N)
      T(N)=JUNK
      N=N-1
  10  IF(KDEL.EQ.1) THEN
        CALL HPGRO(NMAX,NWDS,DATA,N,T,HPFUN,KDEL)
        RETURN
      ELSE
        KHALVE=KDEL/2
        IL=T(KHALVE)
        IR=T(KDEL)
        IF(HPFUN(DATA(IL),DATA(IR),NWDS)) THEN
          CALL HPGRO(NMAX,NWDS,DATA,N,T,HPFUN,KDEL)
          RETURN
        ELSE
          T(KHALVE)=IR
          T(KDEL)=IL
          KDEL=KHALVE
        END IF
      END IF
      GO TO 10
      END

      SUBROUTINE HPGRO(NMAX,NWDS,DATA,N,T,HPFUN,I)
C
C   PURPOSE
C          FORMS A HEAP OUT OF A TREE. USED PRIVATELY BY HPBLD.
C          THE TOP OF THE TREE IS STORED IN LOCATION T(I).
C          FIRST SON IS IN LOCATION T(2I), NEXT SON
C          IS IN LOCATION T(2I+1).
C          THIS PROGRAM ASSUMES EACH BRANCH OF THE TREE IS A HEAP.
C
      INTEGER T(1)
      real*8 DATA(1)
      LOGICAL HPFUN
      IF(N .GT. NMAX) RETURN
C
      K=I
    1 J=2*K
C
C          TEST IF ELEMENT IN J TH POSITION IS A LEAF.
C
      IF( J .GT. N ) RETURN
C
C          IF THERE IS MORE THAN ONE SON, FIND WHICH SON IS SMALLEST.
C
      IF( J .EQ. N ) GO TO 2
      IR=T(J)
      IL=T(J+1)
      IF(HPFUN(DATA(IL),DATA(IR),NWDS)) J=J+1
C
C          IF A SON IS LARGER THAN FATHER, INTERCHANGE
C          THIS DESTROYS HEAP PROPERTY, SO MUST RE-HEAP REMAINING
C          ELEMENTS
C
    2 CONTINUE
      IL=T(K)
      IR=T(J)
      IF(HPFUN(DATA(IL),DATA(IR),NWDS)) RETURN
         ITEMP=T(J)
         T(J)=T(K)
         T(K)=ITEMP
         K=J
      GO TO 1
      END

      SUBROUTINE HPINS(NMAX,NWDS,DATA,N,T,XNODE,HPFUN)
C
C   PURPOSE
C         THIS ROUTINE INSERTS A NODE INTO AN ALREADY EXISTING HEAP.
C             THE RESULTING TREE IS RE-HEAPED.
C
C   INPUT
C         NMAX = MAXIMUM NUMBER OF NODES ALLOWED BY USER.
C         NWDS = NUMBER OF WORDS PER NODE.
C         DATA = WORK AREA FOR STORING NODES.
C         N = CURRENT NUMBER OF NODES IN THE TREE.
C         T = INTEGER ARRAY OF POINTERS TO HEAP NODES.
C         XNODE = A real*8 ARRAY, NWDS WORDS LONG, WHICH
C                CONTAINS THE NODAL INFORMATION TO BE INSERTED.
C         HPFUN = NAME OF USER WRITTEN FUNCTION TO DETERMINE
C                THE TOP NODE.
C   OUTPUT
C         DATA = WORK AREA WITH NEW NODE INSERTED.
C         N = UPDATED NUMBER OF NODES.
C         T = UPDATED INTEGER POINTER ARRAY.
C
      real*8 XNODE(1),DATA(1)
      INTEGER T(1)
      LOGICAL HPFUN
      IF(N .EQ. NMAX) RETURN
      N=N+1
      J= T(N)-1
      DO 1 I= 1,NWDS
         IPJ=I+J
    1    DATA(IPJ) = XNODE(I)
      J=N
    2 CONTINUE
      IF(J .EQ. 1) RETURN
      JR=T(J)
      J2=J/2
      JL=T(J2)
      IF(HPFUN(DATA(JL),DATA(JR),NWDS)) RETURN
      T(J2)=T(J)
      T(J)=JL
      J=J2
      GO TO 2
      END

      LOGICAL FUNCTION LESS(A,B,NWDS)
      INTEGER NWDS
      real*8 A(NWDS), B(NWDS)
      LESS= A(1) .LT. B(1)
      RETURN
      END

      SUBROUTINE LQM0(F,U,V,RES8,EST)
C
C
C
C      PURPOSE
C           TO COMPUTE - IF = INTEGRAL OF F OVER THE TRIANGLE
C           WITH VERTICES (U(1),V(1)),(U(2),V(2)),(U(3),V(3)), AND
C           ESTIMATE THE ERROR,
C                      - INTEGRAL OF ABS(F) OVER THIS TRIANGLE
C
C      CALLING SEQUENCE
C           CALL LQM0(F,U,V,RES11,EST)
C        PARAMETERS
C           F       - FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     F(X,Y); THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE CALLING
C                     PROGRAM
C           U(1),U(2),U(3)- ABSCISSAE OF VERTICES
C           V(1),V(2),V(3)- ORDINATES OF VERTICES
C           RES6    - APPROXIMATION TO THE INTEGRAL IF, OBTAINED BY THE
C                     LYNESS AND JESPERSEN RULE OF DEGREE 6, USING
C                     12 POINTS
C           RES8   - APPROXIMATION TO THE INTEGRAL IF, OBTAINED BY THE
C                     LYNESS AND JESPERSEN RULE OF DEGREE 8,
C                     USING 16 POINTS
C           EST     - ESTIMATE OF THE ABSOLUTE ERROR
C           DRESC   - APPROXIMATION TO THE INTEGRAL OF ABS(F- IF/DJ),
C                     OBTAINED BY THE RULE OF DEGREE 6, AND USED FOR
C                     THE COMPUTATION OF EST
C
C      REMARKS
C           DATE OF LAST UPDATE : 10 APRIL 1984 O.W. RECHARD NBS
C
C           SUBROUTINES OR FUNCTIONS CALLED :
C                   - F (USER-SUPPLIED INTEGRAND FUNCTION)
C                   - R1MACH FOR MACHINE DEPENDENT INFORMATION
C
C .....................................................................
C
      real*8 DJ,DF0,DRESC,EMACH,EST,F,FV,F0,
     *  RES6,RES8,U1,U2,U3,UFLOW,V1,V2,V3,W,W60,W80,X,Y
     *  ,ZETA1,ZETA2,Z1,Z2,Z3,RESAB6
      real*8 AMAX1,AMIN1,R1MACH,SQRT
      real*8 U(3),V(3)
      INTEGER J,KOUNT,L
C
      DIMENSION FV(19),W(9),X(3),Y(3),ZETA1(9),ZETA2(9)
C
C
C            FIRST HOMOGENEOUS COORDINATES OF POINTS IN DEGREE-6
C            AND DEGREE-8 FORMULA, TAKEN WITH MULTIPLICITY 3
      DATA ZETA1(1),ZETA1(2),ZETA1(3),ZETA1(4),ZETA1(5),ZETA1(6),ZETA1(7
     *  ),ZETA1(8),ZETA1(9)/0.5014265096581342E+00,
     *  0.8738219710169965E+00,0.6365024991213939E+00,
     *  0.5314504984483216E-01,0.8141482341455413E-01,
     *  0.8989055433659379E+00,0.6588613844964797E+00,
     *  0.8394777409957211E-02,0.7284923929554041E+00/
C            SECOND HOMOGENEOUS COORDINATES OF POINTS IN DEGREE-6
C            AND DEGREE-8 FORMULA, TAKEN WITH MUNLTIPLICITY 3
      DATA ZETA2(1),ZETA2(2),ZETA2(3),ZETA2(4),ZETA2(5),ZETA2(6),ZETA2(7
     *  ),ZETA2(8),ZETA2(9)/0.2492867451709329E+00,
     *  0.6308901449150177E-01,0.5314504984483216E-01,
     *  0.6365024991213939E+00,0.4592925882927229E+00,
     *  0.5054722831703103E-01,0.1705693077517601E+00,
     *  0.7284923929554041E+00,0.8394777409957211E-02/
C           WEIGHTS OF MID-POINT OF TRIANGLE IN DEGREE-6
C           RESP. DEGREE-8 FORMULAE
      DATA W60/0.0E+00/
      DATA W80/0.1443156076777862E+00/
C           WEIGHTS IN DEGREE-6 AND DEGREE-8 RULE
      DATA W(1),W(2),W(3),W(4),W(5),W(6),W(7),W(8),W(9)/
     *  0.1167862757263407E+00,0.5084490637020547E-01,
     *  0.8285107561839291E-01,0.8285107561839291E-01,
     *  0.9509163426728497E-01,0.3245849762319813E-01,
     *  0.1032173705347184E+00,0.2723031417443487E-01,
     *  0.2723031417443487E-01/
C
C           LIST OF MAJOR VARIABLES
C           ----------------------
C           DJ      - AREA OF THE TRIANGLE
C           DRESC   - APPROXIMATION TO INTEGRAL OF
C                     ABS(F- IF/DJ)  OVER THE TRIANGLE
C           RESAB6  - APPROXIMATION TO INTEGRAL OF
C                     ABS(F) OVER THE TRIANGLE
C           X       - CARTESIAN ABSCISSAE OF THE INTEGRATION
C                     POINTS
C           Y       - CARTESIAN ORDINATES OF THE INTEGRATION
C                     POINTS
C           FV      - FUNCTION VALUES
C
C           COMPUTE DEGREE-6 AND DEGREE-8 RESULTS FOR IF/DJ AND
C           DEGREE-6 APPROXIMATION FOR ABS(F)
C
      EMACH = R1MACH(4)
      UFLOW = R1MACH(1)
      U1=U(1)
      U2=U(2)
      U3=U(3)
      V1=V(1)
      V2=V(2)
      V3=V(3)
      DJ = ABS(U1*V2-U2*V1-U1*V3+V1*U3+U2*V3-V2*U3)*0.5E+00
      F0 = F((U1+U2+U3)/3.0E+00,(V1+V2+V3)/3.0E+00)
      RES6 = F0*W60
      RESAB6 = ABS(F0)*W60
      FV(1) = F0
      KOUNT = 1
      RES8 = F0*W80
      DO 50 J=1,9
        Z1 = ZETA1(J)
        Z2 = ZETA2(J)
        Z3 = 1.0E+00-Z1-Z2
        X(1) = Z1*U1+Z2*U2+Z3*U3
        Y(1) = Z1*V1+Z2*V2+Z3*V3
        X(2) = Z2*U1+Z3*U2+Z1*U3
        Y(2) = Z2*V1+Z3*V2+Z1*V3
        X(3) = Z3*U1+Z1*U2+Z2*U3
        Y(3) = Z3*V1+Z1*V2+Z2*V3
        IF(J.LE.4) THEN
           F0 = 0.0E+00
           DF0 = 0.0E+00
           DO 10 L=1,3
             KOUNT = KOUNT+1
             FV(KOUNT) = F(X(L),Y(L))
             F0 = F0+FV(KOUNT)
             DF0 = DF0+ABS(FV(KOUNT))
   10      CONTINUE
           RES6 = RES6+F0*W(J)
           RESAB6 = RESAB6+DF0*W(J)
        ELSE
           F0 = F(X(1),Y(1))+F(X(2),Y(2))+F(X(3),Y(3))
           RES8 = RES8+F0*W(J)
        ENDIF
   50 CONTINUE
C
C           COMPUTE DEGREE-6 APPROXIMATION FOR THE INTEGRAL OF
C           ABS(F-IF/DJ)
C
      DRESC = ABS(FV(1)-RES6)*W60
      KOUNT = 2
      DO 60 J=1,4
        DRESC = DRESC+(ABS(FV(KOUNT)-RES6)+ABS(FV(KOUNT+1)-RES6)+ABS(
     *  FV(KOUNT+2)-RES6))*W(J)
        KOUNT = KOUNT+3
   60 CONTINUE
C
C           COMPUTE DEGREE-6 AND DEGREE-8 APPROXIMATIONS FOR IF,
C           AND ERROR ESTIMATE
C
      RES6 = RES6*DJ
      RES8 = RES8*DJ
      RESAB6 = RESAB6*DJ
      DRESC = DRESC*DJ
      EST = ABS(RES6-RES8)
      IF(DRESC.NE.0.0E+00) EST = AMAX1(EST,DRESC*AMIN1(1.0E+00,(20.0E+00
     *  *EST/DRESC)**1.5E+00))
      IF(RESAB6.GT.UFLOW) EST = AMAX1(EMACH*RESAB6,EST)
      RETURN
      END

      SUBROUTINE LQM1(F,U,V,RES11,EST)
C
C
C
C      PURPOSE
C           TO COMPUTE - IF = INTEGRAL OF F OVER THE TRIANGLE
C           WITH VERTICES (U(1),V(1)),(U(2),V(2)),(U(3),V(3)), AND
C           ESTIMATE THE ERROR,
C                      - INTEGRAL OF ABS(F) OVER THIS TRIANGLE
C
C      CALLING SEQUENCE
C           CALL LQM1(F,U,V,RES11,EST)
C        PARAMETERS
C           F       - FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     F(X,Y); THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE CALLING
C                     PROGRAM
C           U(1),U(2),U(3)- ABSCISSAE OF VERTICES
C           V(1),V(2),V(3)- ORDINATES OF VERTICES
C           RES9    - APPROXIMATION TO THE INTEGRAL IF, OBTAINED BY THE
C                     LYNESS AND JESPERSEN RULE OF DEGREE 9, USING
C                     19 POINTS
C           RES11   - APPROXIMATION TO THE INTEGRAL IF, OBTAINED BY THE
C                     LYNESS AND JESPERSEN RULE OF DEGREE 11,
C                     USING 28 POINTS
C           EST     - ESTIMATE OF THE ABSOLUTE ERROR
C           DRESC   - APPROXIMATION TO THE INTEGRAL OF ABS(F- IF/DJ),
C                     OBTAINED BY THE RULE OF DEGREE 9, AND USED FOR
C                     THE COMPUTATION OF EST
C
C      REMARKS
C           DATE OF LAST UPDATE : 18 JAN 1984 D. KAHANER NBS
C
C           SUBROUTINES OR FUNCTIONS CALLED :
C                   - F (USER-SUPPLIED INTEGRAND FUNCTION)
C                   - R1MACH FOR MACHINE DEPENDENT INFORMATION
C
C .....................................................................
C
      real*8 DJ,DF0,DRESC,EMACH,EST,F,FV,F0,
     *  RES9,RES11,U1,U2,U3,UFLOW,V1,V2,V3,W,W90,W110,X,Y
     *  ,ZETA1,ZETA2,Z1,Z2,Z3
      real*8 AMAX1,AMIN1,R1MACH,SQRT
      real*8 U(3),V(3)
      INTEGER J,KOUNT,L
C
      DIMENSION FV(19),W(15),X(3),Y(3),ZETA1(15),ZETA2(15)
C
C
C            FIRST HOMOGENEOUS COORDINATES OF POINTS IN DEGREE-9
C            AND DEGREE-11 FORMULA, TAKEN WITH MULTIPLICITY 3
      DATA ZETA1(1),ZETA1(2),ZETA1(3),ZETA1(4),ZETA1(5),ZETA1(6),ZETA1(7
     *  ),ZETA1(8),ZETA1(9),ZETA1(10),ZETA1(11),ZETA1(12),ZETA1(13),
     *  ZETA1(14),ZETA1(15)/0.2063496160252593E-01,0.1258208170141290E+
     *  00,0.6235929287619356E+00,0.9105409732110941E+00,
     *  0.3683841205473626E-01,0.7411985987844980E+00,
     *  0.9480217181434233E+00,0.8114249947041546E+00,
     *  0.1072644996557060E-01,0.5853132347709715E+00,
     *  0.1221843885990187E+00,0.4484167758913055E-01,
     *  0.6779376548825902E+00,0.0E+00,0.8588702812826364E+00/
C            SECOND HOMOGENEOUS COORDINATES OF POINTS IN DEGREE-9
C            AND DEGREE-11 FORMULA, TAKEN WITH MUNLTIPLICITY 3
      DATA ZETA2(1),ZETA2(2),ZETA2(3),ZETA2(4),ZETA2(5),ZETA2(6),ZETA2(7
     *  ),ZETA2(8),ZETA2(9),ZETA2(10),ZETA2(11),ZETA2(12),ZETA2(13),
     *  ZETA2(14),ZETA2(15)/0.4896825191987370E+00,0.4370895914929355E+
     *  00,0.1882035356190322E+00,0.4472951339445297E-01,
     *  0.7411985987844980E+00,0.3683841205473626E-01,
     *  0.2598914092828833E-01,0.9428750264792270E-01,
     *  0.4946367750172147E+00,0.2073433826145142E+00,
     *  0.4389078057004907E+00,0.6779376548825902E+00,
     *  0.4484167758913055E-01,0.8588702812826364E+00,0.0E+00/
C           WEIGHTS OF MID-POINT OF TRIANGLE IN DEGREE-9
C           RESP. DEGREE-11 FORMULAE
      DATA W90/0.9713579628279610E-01/
      DATA W110/0.8797730116222190E-01/
C           WEIGHTS IN DEGREE-9 AND DEGREE-11 RULE
      DATA W(1),W(2),W(3),W(4),W(5),W(6),W(7),W(8),W(9),W(10),W(11),W(12
     *  ),W(13),W(14),W(15)/0.3133470022713983E-01,0.7782754100477543E-
     *  01,0.7964773892720910E-01,0.2557767565869810E-01,
     *  0.4328353937728940E-01,0.4328353937728940E-01,
     *  0.8744311553736190E-02,0.3808157199393533E-01,
     *  0.1885544805613125E-01,0.7215969754474100E-01,
     *  0.6932913870553720E-01,0.4105631542928860E-01,
     *  0.4105631542928860E-01,0.7362383783300573E-02,
     *  0.7362383783300573E-02/
C
C           LIST OF MAJOR VARIABLES
C           ----------------------
C           DJ      - AREA OF THE TRIANGLE
C           DRESC   - APPROXIMATION TO INTEGRAL OF
C                     ABS(F- IF/DJ)  OVER THE TRIANGLE
C           RESAB9  - APPROXIMATION TO INTEGRAL OF
C                     ABS(F) OVER THE TRIANGLE
C           X       - CARTESIAN ABSCISSAE OF THE INTEGRATION
C                     POINTS
C           Y       - CARTESIAN ORDINATES OF THE INTEGRATION
C                     POINTS
C           FV      - FUNCTION VALUES
C
C           COMPUTE DEGREE-9 AND DEGREE-11 RESULTS FOR IF/DJ AND
C           DEGREE-9 APPROXIMATION FOR ABS(F)
C
      EMACH = R1MACH(4)
      UFLOW = R1MACH(1)
      U1=U(1)
      U2=U(2)
      U3=U(3)
      V1=V(1)
      V2=V(2)
      V3=V(3)
      DJ = ABS(U1*V2-U2*V1-U1*V3+V1*U3+U2*V3-V2*U3)*0.5E+00
      F0 = F((U1+U2+U3)/3.0E+00,(V1+V2+V3)/3.0E+00)
      RES9 = F0*W90
      RESAB9 = ABS(F0)*W90
      FV(1) = F0
      KOUNT = 1
      RES11 = F0*W110
      DO 50 J=1,15
        Z1 = ZETA1(J)
        Z2 = ZETA2(J)
        Z3 = 1.0E+00-Z1-Z2
        X(1) = Z1*U1+Z2*U2+Z3*U3
        Y(1) = Z1*V1+Z2*V2+Z3*V3
        X(2) = Z2*U1+Z3*U2+Z1*U3
        Y(2) = Z2*V1+Z3*V2+Z1*V3
        X(3) = Z3*U1+Z1*U2+Z2*U3
        Y(3) = Z3*V1+Z1*V2+Z2*V3
        IF(J.LE.6) THEN
           F0 = 0.0E+00
           DF0 = 0.0E+00
           DO 10 L=1,3
             KOUNT = KOUNT+1
             FV(KOUNT) = F(X(L),Y(L))
             F0 = F0+FV(KOUNT)
             DF0 = DF0+ABS(FV(KOUNT))
   10      CONTINUE
           RES9 = RES9+F0*W(J)
           RESAB9 = RESAB9+DF0*W(J)
        ELSE
           F0 = F(X(1),Y(1))+F(X(2),Y(2))+F(X(3),Y(3))
           RES11 = RES11+F0*W(J)
        ENDIF
   50 CONTINUE
C
C           COMPUTE DEGREE-9 APPROXIMATION FOR THE INTEGRAL OF
C           ABS(F-IF/DJ)
C
      DRESC = ABS(FV(1)-RES9)*W90
      KOUNT = 2
      DO 60 J=1,6
        DRESC = DRESC+(ABS(FV(KOUNT)-RES9)+ABS(FV(KOUNT+1)-RES9)+ABS(
     *  FV(KOUNT+2)-RES9))*W(J)
        KOUNT = KOUNT+3
   60 CONTINUE
C
C           COMPUTE DEGREE-9 AND DEGREE-11 APPROXIMATIONS FOR IF,
C           AND ERROR ESTIMATE
C
      RES9 = RES9*DJ
      RES11 = RES11*DJ
      RESAB9 = RESAB9*DJ
      DRESC = DRESC*DJ
      EST = ABS(RES9-RES11)
      IF(DRESC.NE.0.0E+00) EST = AMAX1(EST,DRESC*AMIN1(1.0E+00,(20.0E+00
     *  *EST/DRESC)**1.5E+00))
      IF(RESAB9.GT.UFLOW) EST = AMAX1(EMACH*RESAB9,EST)
      RETURN
      END

      subroutine tridv(node,node1,node2,coef,rank)
      real*8 node(*),node1(*),node2(*),coef
      integer rank
      real*8 s(3),coef1,temp
      integer t(3)
      coef1=1.0-coef
      s(1)=(node(3)-node(5))**2+(node(4)-node(6))**2
      s(2)=(node(5)-node(7))**2+(node(6)-node(8))**2
      s(3)=(node(3)-node(7))**2+(node(4)-node(8))**2
      t(1)=1
      t(2)=2
      t(3)=3
      do 10 i=1,2
        do 10 j=i+1,3
          if(s(i).lt.s(j)) then
            temp=t(i)
            t(i)=t(j)
            t(j)=temp
          end if
10    continue
      if(t(rank).eq.1)then
        node1(3)=coef*node(3)+coef1*node(5)
        node1(4)=coef*node(4)+coef1*node(6)
        node1(5)=node(5)
        node1(6)=node(6)
        node1(7)=node(7)
        node1(8)=node(8)
        node2(3)=node1(3)
        node2(4)=node1(4)
        node2(5)=node(7)
        node2(6)=node(8)
        node2(7)=node(3)
        node2(8)=node(4)
      else if(t(rank).eq.2) then
        node1(3)=coef*node(5)+coef1*node(7)
        node1(4)=coef*node(6)+coef1*node(8)
        node1(5)=node(7)
        node1(6)=node(8)
        node1(7)=node(3)
        node1(8)=node(4)
        node2(3)=node1(3)
        node2(4)=node1(4)
        node2(5)=node(3)
        node2(6)=node(4)
        node2(7)=node(5)
        node2(8)=node(6)
      else
        node1(3)=coef*node(3)+coef1*node(7)
        node1(4)=coef*node(4)+coef1*node(8)
        node1(5)=node(3)
        node1(6)=node(4)
        node1(7)=node(5)
        node1(8)=node(6)
        node2(3)=node1(3)
        node2(4)=node1(4)
        node2(5)=node(5)
        node2(6)=node(6)
        node2(7)=node(7)
        node2(8)=node(8)
      end if
      node1(9)=coef*node(9)
      node2(9)=coef1*node(9)
      end

!DECK R1MACH
      REAL*8 FUNCTION R1MACH (I)
      IMPLICIT NONE
      INTEGER :: I
      REAL*8 :: B, X
!***BEGIN PROLOGUE  R1MACH
!***PURPOSE  Return floating point machine dependent constants.
!***LIBRARY   SLATEC
!***CATEGORY  R1
!***TYPE      SINGLE PRECISION (R1MACH-S, D1MACH-D)
!***KEYWORDS  MACHINE CONSTANTS
!***AUTHOR  Fox, P. A., (Bell Labs)
!           Hall, A. D., (Bell Labs)
!           Schryer, N. L., (Bell Labs)
!***DESCRIPTION
!
!   R1MACH can be used to obtain machine-dependent parameters for the
!   local machine environment.  It is a function subprogram with one
!   (input) argument, and can be referenced as follows:
!
!        A = R1MACH(I)
!
!   where I=1,...,5.  The (output) value of A above is determined by
!   the (input) value of I.  The results for various values of I are
!   discussed below.
!
!   R1MACH(1) = B**(EMIN-1), the smallest positive magnitude.
!   R1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
!   R1MACH(3) = B**(-T), the smallest relative spacing.
!   R1MACH(4) = B**(1-T), the largest relative spacing.
!   R1MACH(5) = LOG10(B)
!
!   Assume single precision numbers are represented in the T-digit,
!   base-B form
!
!              sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
!
!   where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and
!   EMIN .LE. E .LE. EMAX.
!
!   The values of B, T, EMIN and EMAX are provided in I1MACH as
!   follows:
!   I1MACH(10) = B, the base.
!   I1MACH(11) = T, the number of base-B digits.
!   I1MACH(12) = EMIN, the smallest exponent E.
!   I1MACH(13) = EMAX, the largest exponent E.
!
!
!***REFERENCES  P. A. Fox, A. D. Hall and N. L. Schryer, Framework for
!                 a portable library, ACM Transactions on Mathematical
!                 Software 4, 2 (June 1978), pp. 177-188.
!***ROUTINES CALLED  XERMSG
!***REVISION HISTORY  (YYMMDD)
!   790101  DATE WRITTEN
!   960329  Modified for Fortran 90 (BE after suggestions by EG)
!***END PROLOGUE  R1MACH
!
      X = 1.0
      B = RADIX(X)
      SELECT CASE (I)
        CASE (1)
          R1MACH = B**(MINEXPONENT(X)-1) ! the smallest positive magnitude.
        CASE (2)
          R1MACH = HUGE(X)               ! the largest magnitude.
        CASE (3)
          R1MACH = B**(-DIGITS(X))       ! the smallest relative spacing.
        CASE (4)
          R1MACH = B**(1-DIGITS(X))      ! the largest relative spacing.
        CASE (5)
          R1MACH = LOG10(B)
        CASE DEFAULT
          WRITE (*, FMT = 9000)
 9000     FORMAT ('1ERROR    1 IN R1MACH - I OUT OF BOUNDS')
          STOP
      END SELECT
      RETURN
      END


! =============================================================================
!                       Test ellipse multi merge
!
!         This unit test checks the merging of three ellipses. The biggest
!         ellipse is located at the origin. The smaller ellipses are located
!         tangentially at 45 and 225 degrees. The final ellipse is an ellipse
!         located at the origin.
! =============================================================================
program test_ellipse_multi_merge_2
    use unit_test
    use constants, only : pi, one, two, four, five, ten
    use parcel_container
    use parcel_merge, only : merge_ellipses, merge_timer
    use options, only : parcel
    use parameters, only : update_parameters, nx, nz, lower, extent
    use parcel_ellipse
    use parcel_nearest
    use timer
    implicit none

    double precision :: a1b1, a2b2, error

    nx = 1
    nz = 1
    lower  = (/-pi / two, -pi /two/)
    extent = (/pi, pi/)

    call register_timer('parcel merge', merge_timer)
    call register_timer('merge nearest', merge_nearest_timer)
    call register_timer('merge tree resolve', merge_tree_resolve_timer)

    parcel%lambda_max = five
    parcel%min_vratio = ten

    call update_parameters

    call parcel_alloc(3)

    a1b1 = 1.44d0
    a2b2 = 0.25d0

    call parcel_setup

    call merge_ellipses(parcels)

    ! check result
    call eval_max_error

    call print_result_dp('Test ellipse group-merge 2', error)

    call parcel_dealloc

    contains

        subroutine parcel_setup
            double precision :: d

            d = (dsqrt(a1b1) + dsqrt(a2b2)) * f12 * dsqrt(two)

            n_parcels = 3
            parcels%position(:, 1) = zero
            parcels%volume(1) = a1b1 * pi
            parcels%B(1, 1) = a1b1
            parcels%B(2, 1) = zero
            parcels%buoyancy(1) = 1.5d0
#ifndef ENABLE_DRY_MODE
            parcels%humidity(1) = 1.3d0
#endif
            ! small parcel left
            parcels%position(1, 2) = -d
            parcels%position(2, 2) = -d
            parcels%volume(2) = a2b2 * pi
            parcels%B(1, 2) = a2b2
            parcels%B(2, 2) = zero
            parcels%buoyancy(2) = 1.8d0
#ifndef ENABLE_DRY_MODE
            parcels%humidity(2) = 1.2d0
#endif
            ! small parcel right
            parcels%position(1, 3) = d
            parcels%position(2, 3) = d
            parcels%volume(3) = a2b2 * pi
            parcels%B(1, 3) = a2b2
            parcels%B(2, 3) = zero
            parcels%buoyancy(3) = 1.4d0
#ifndef ENABLE_DRY_MODE
            parcels%humidity(3) = 1.1d0
#endif
        end subroutine parcel_setup

        subroutine eval_max_error
            double precision :: ab, B11, B12, B22, vol, d, factor
            double precision :: hum, buoy

            ! reference solution
            d = (dsqrt(a1b1) + dsqrt(a2b2)) * f12 * dsqrt(two)
            ab = a1b1 + two * a2b2
            vol = ab * pi

            buoy = (1.5d0 * a1b1 + (1.8d0 + 1.4d0) * a2b2) / ab
            hum  = (1.3d0 * a1b1 + (1.2d0 + 1.1d0) * a2b2) / ab

            B11 = a1b1 ** 2 / ab + two * a2b2 / ab * (four * d ** 2 + a2b2)
            B12 = two * a2b2 / ab * (four * d ** 2)
            B22 = B11

            factor = ab / dsqrt(B11 * B22 - B12 ** 2)
            B11 = B11 * factor
            B12 = B12 * factor
            B22 = B22 * factor

            error = zero
            error = max(error, abs(dble(n_parcels - 1)))
            error = max(error, abs(parcels%B(1, 1) - B11))
            error = max(error, abs(parcels%B(2, 1) - B12))
            error = max(error, abs(get_B22(parcels%B(1, 1), &
                                           parcels%B(2, 1), &
                                           parcels%volume(1)) - B22))
            error = max(error, sum(abs(parcels%position(:, 1))))
            error = max(error, abs(parcels%volume(1) - vol))
            error = max(error, abs(parcels%buoyancy(1) - buoy))
#ifndef ENABLE_DRY_MODE
            error = max(error, abs(parcels%humidity(1) - hum))
#endif
        end subroutine eval_max_error
end program test_ellipse_multi_merge_2


      REAL             FUNCTION SXPARG (L)
      INTEGER L
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1998-10-29 SXPARG Krogh  Moved external statement up for mangle.
C>> 1994-10-20 SXPARG Krogh  Changes to use M77CON
C>> 1993-05-06 SXPARG WVS JPL Conversion from NSWC to Math 77
c--S replaces "?": ?XPARG
C -------------------------------------------------------------------
C     IF L = 0 THEN  SXPARG(L) = THE LARGEST POSITIVE W FOR WHICH
C     EXP(W) CAN BE COMPUTED.
C
C     IF L IS NONZERO THEN  SXPARG(L) = THE LARGEST NEGATIVE W FOR
C     WHICH THE COMPUTED VALUE OF EXP(W) IS NONZERO.
C
C     NOTE... ONLY AN APPROXIMATE VALUE FOR SXPARG(L) IS NEEDED.
C -------------------------------------------------------------------
      EXTERNAL R1MACH
      REAL             R1MACH
      REAL             FAC, XMAX, XMIN
      SAVE XMAX, XMIN
      DATA XMAX /-1.0E0/
C
      IF (XMAX .LT. 0.0) THEN
         FAC = 1.0E0 - R1MACH(3)
         XMAX = FAC * LOG(R1MACH(2))
         XMIN = FAC * LOG(R1MACH(1))
      END IF
C
      IF (L .NE. 0) THEN
         SXPARG = XMIN
      ELSE
         SXPARG = XMAX
      END IF
      RETURN
      END


!----------------------------------------------------------------------------- best with 100 columns

function matVecMul()
  use modSparse
  integer::matVecMul
  type(linEq)::p
  integer::iA(7),jA(7)
  double precision::A(7)
  double precision::y(4),x(4)

  matVecMul=0
  call p%initLinEq(4,7)
  iA=[1,2,2,3,3,4,4]
  jA=[1,2,1,3,4,4,2]
  A=[1d0,2d0,-1d0,5d0,-4d0,2d0,-1d0]
  x=[1d0,3d0/2d0,14d0/5d0,11d0/4d0]
  call p%setCOO(iA,jA,A,7)
  call p%mulVec(x,y)
  if(norm2(y-[1d0,2d0,3d0,4d0])>1d-9)then
    matVecMul=1
  end if
end function


module mod_moms
  use mod_types
  implicit none
  private
  public momsad
  contains
  subroutine momsad(nx,ny,nz,dxi,dyi,dzi,dzci,dzfi,dzflzi,visc,u,v,w,s,dsdt)
    implicit none
    integer , intent(in) :: nx,ny,nz
    real(rp), intent(in) :: dxi,dyi,dzi,visc
    real(rp), intent(in), dimension(0:) :: dzci,dzfi,dzflzi
    real(rp), dimension(0:,0:,0:), intent(in) :: u,v,w,s
    real(rp), dimension(:,:,:), intent(out) :: dsdt
    integer  :: im,ip,jm,jp,km,kp,i,j,k
    real(rp) :: usip,usim,vsjp,vsjm,wskp,wskm
    real(rp) :: dsdxp,dsdxm,dsdyp,dsdym,dsdzp,dsdzm
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k,im,jm,km,ip,jp,kp) &
    !$OMP PRIVATE(usip,usim,vsjp,vsjm,wskp,wskm) &
    !$OMP PRIVATE(dsdxp,dsdxm,dsdyp,dsdym,dsdzp,dsdzm) &
    !$OMP SHARED(nx,ny,nz,dxi,dyi,dzi,visc,u,v,w,s,dsdt,dzci,dzfi)
    do k=1,nz
      kp = k + 1
      km = k - 1
      do j=1,ny
        jp = j + 1
        jm = j - 1
        do i=1,nx
          ip = i + 1
          im = i - 1
          usim  = 0.5*( s(im,j,k)+s(i,j,k) )*u(im,j,k)
          usip  = 0.5*( s(ip,j,k)+s(i,j,k) )*u(i ,j,k)
          vsjm  = 0.5*( s(i,jm,k)+s(i,j,k) )*v(i,jm,k)
          vsjp  = 0.5*( s(i,jp,k)+s(i,j,k) )*v(i,j ,k)
          wskm  = 0.5*( s(i,j,km)+s(i,j,k) )*w(i,j,km)
          wskp  = 0.5*( s(i,j,kp)+s(i,j,k) )*w(i,j,k )
          dsdxp = (s(ip,j,k)-s(i ,j,k))*dxi
          dsdxm = (s(i ,j,k)-s(im,j,k))*dxi
          dsdyp = (s(i,jp,k)-s(i,j ,k))*dyi
          dsdym = (s(i,j ,k)-s(i,jm,k))*dyi
          dsdzp = (s(i,j,kp)-s(i,j,k ))*dzci(k)
          dsdzm = (s(i,j,k )-s(i,j,km))*dzci(km)
          !
          dsdt(i,j,k) = dxi*(     -usip + usim ) + (dsdxp-dsdxm)*visc*dxi + &
                        dyi*(     -vsjp + vsjm ) + (dsdyp-dsdym)*visc*dyi + &
                        dzfi(k)*( -wskp + wskm ) + (dsdzp-dsdzm)*visc*dzfi(k)
        enddo
      enddo
    enddo
    !$OMP END PARALLEL DO
    return
  end subroutine momsad
end module mod_moms


REAL (C_DOUBLE) FUNCTION dnrm2_noblas(n, x) BIND(C)
    USE ISO_C_BINDING
    IMPLICIT NONE

    INTEGER (C_LONG), VALUE :: n
    REAL (C_DOUBLE), DIMENSION(n) :: x

    dnrm2_noblas = SQRT(DOT_PRODUCT(x, x))

END FUNCTION

REAL (C_DOUBLE) FUNCTION dnrm2_blas(n, x) BIND(C)
    USE ISO_C_BINDING
    IMPLICIT NONE

    INTEGER (C_LONG), VALUE :: n
    REAL (C_DOUBLE), DIMENSION(n) :: x
    DOUBLE PRECISION dnrm2

    dnrm2_blas = dnrm2(n, x, 1)

END FUNCTION


C++--------------------------------------------------------------------
C Program to smooth images with possibility of unsharp masking.
C JLP
C Version of 12-11-91
C--------------------------------------------------------------------
	PROGRAM SMOOTH1
        INTEGER GSIZE
        PARAMETER(GSIZE=31)
	REAL*4 GRID(GSIZE,GSIZE)
	INTEGER*4 PNTR_IN,PNTR_OUT,ISIZE
	INTEGER*4 MADRID(1)
	CHARACTER NAME*40,NAME_OUT*40,COMMENTS*80
        CHARACTER NSMOOTH*30,ANS*1,BUFFER*40
	LOGICAL UNSHARP
	COMMON /VMR/MADRID

10	FORMAT(A)
	PRINT 5
5	FORMAT(' Program smooth1 to smooth 2-D images'
     1	,/,' Possibility of unsharp masking',/,' Version 12-11-91')

        CALL JLP_BEGIN
C Inquires about the format of the files :
	CALL JLP_INQUIFMT

C Read the input image :
        WRITE(6,*) 'Input file: '
        READ(5,10) NAME
	CALL JLP_VM_READIMAG(PNTR_IN,NX,NY,NAME,COMMENTS)

	PRINT 70
70	FORMAT(' MENU : ',/,
     1	' 1. INPUT OF THE VALUES FOR THE GRID',
     1	' AND STORAGE IN A FILE',/,
     1	' 2. GAUSSIAN GRID',/,
     1	' 3. "TOP HAT" ',/,
     1	' 4. GRID FROM A FILE ',/,
     1	' ENTER THE OPTION : ',$)
	READ(5,*) IOPT

	PRINT *,' SIZE OF SMOOTHING GRID (ODD INTEGER IN RANGE 1-',GSIZE,') '
	READ(5,*) NSM

C-------------------------------------------------------------
C IOPT=1 Input of the values and storage in a file :
	IF(IOPT.EQ.1)THEN
        WRITE(BUFFER,11) NSM
11      FORMAT(' Width of spec. grid:',I4)
	IOP=4
	SUM=0.
	DO J=1,NSM
	 PRINT 101,J
101	 FORMAT(' LINE :',I3)
	   DO I=1,NSM
	    PRINT 102,I
102	    FORMAT('  ',I3,' := ',$)
	    READ(5,*) GRID(I,J)
	    SUM=SUM+GRID(I,J)
	   END DO
	END DO

	IF(SUM.NE.1.)THEN
	PRINT 106
106	FORMAT(' WARNING : THE GRID IS NOT NORMALIZED',/,
     1	' DO YOU WANT ME TO NORMALIZE IT ? (Y)')
	READ(5,10) ANS
	  IF(ANS.NE.'N'.AND.ANS.NE.'n')THEN
	   DO I=1,NSM
	    DO J=1,NSM
	     GRID(I,J)=GRID(I,J)/SUM
	    END DO
	   END DO
	   PRINT *,' GRID NORMALIZED'
	  ENDIF
	ENDIF

105	PRINT *,' NAME OF THE OUTPUT FILE (GRID) ?'
	READ(5,10) NSMOOTH
	OPEN(1,FILE=NSMOOTH,STATUS='NEW',ERR=105)
	WRITE(1,*) ((GRID(I,J),I=1,NSM),J=1,NSM)
	CLOSE(1)
	ENDIF

C-------------------------------------------------------------
C IOPT=2  Gaussian grid:
	IF(IOPT.EQ.2)THEN
        WRITE(BUFFER,12) NSM
12      FORMAT(' Width of Gauss grid:',I4)
	  IOP=2
	  PRINT 203
203	  FORMAT(' SIGMA (IN PIXELS) : ',$)
	  READ(5,*) SIGMA
	ENDIF

C-------------------------------------------------------------
C IOPT=3  "Top Hat" :
	IF(IOPT.EQ.3)THEN
          IOP=3
          WRITE(BUFFER,13) NSM
13        FORMAT(' Width of Top Hat grid:',I4)
        ENDIF

C-------------------------------------------------------------
C IOPT=4 Input of a file :
	IF(IOPT.EQ.4)THEN
	  IOP=4
          WRITE(BUFFER,14) NSM
14        FORMAT(' Width of file grid:',I4)
405	  PRINT *,' Name of precalculated smoothing grid'
	  READ(5,10) NSMOOTH

	  OPEN(1,FILE=NSMOOTH,STATUS='OLD',ERR=405)
	  READ(1,*) ((GRID(I,J),I=1,NSM),J=1,NSM)
	  CLOSE(1)

	ENDIF

C--------------------------------------------------------------
C Prints the grid if IOP=4
	IF(IOP.EQ.4)THEN
	  PRINT 801
801	  FORMAT(' SMOOTHING GRID :')
	  DO J=1,NSM
	    DO I=1,NSM
	     PRINT *,I,J,GRID(I,J)
	    END DO
	  END DO
	ENDIF
C-------------------------------------------------------------
C Unsharp masking :
	PRINT *,' DO YOU WANT UNSHARP MASKING ? (N)'
	READ(5,10) ANS
	UNSHARP=(ANS.EQ.'Y'.OR.ANS.EQ.'y')
	 IF(UNSHARP)THEN
	  PRINT *,' FRACTION OF THE SMOOTHED IMAGE YOU WANT TO REMOVE ?'
	  READ(5,*) FRACT
	 ENDIF

C Output file:
	PRINT *,' OUTPUT FILE:'
	READ(5,10) NAME_OUT
	ISIZE=NX*NY*4
	CALL JLP_GETVM(PNTR_OUT,ISIZE)

C Calls SMOOTH2 :
C   IOP=2 Gauss
C   IOP=3 Top hat
C   IOP=4 Input grid

	CALL SMOOTH2(MADRID(PNTR_IN),MADRID(PNTR_OUT),
     1	NX,NY,NX,IOP,GRID,NSM,SIGMA,UNSHARP,FRACT)

C Output :
	IN=INDEX(NAME,' ')
	  IF(UNSHARP)THEN
	   WRITE(COMMENTS,902)NAME(1:IN),BUFFER(1:30)
902	   FORMAT(' Unsharp mask from :',A,A)
	  ELSE
	   WRITE(COMMENTS,903)NAME(1:IN),BUFFER(1:30)
903	   FORMAT('Smoothed image of:',A,A)
	  ENDIF
	CALL JLP_WRITEIMAG(MADRID(PNTR_OUT),NX,NY,NX,
     1	NAME_OUT,COMMENTS)

	CALL JLP_END
	STOP
	END
C------------------------------------------------------------------------
	include 'jlpsub:smooth2.for'


module constants

    real*8, parameter :: pi = 3.141592654
    real*8, parameter :: e = 2.7182818285

end module


! chk_inverse_hyperbolic.f90 --
!     Check: does the compiler support the inverse hyperbolic functions for real arguments?
!
program chk_inverse_hyperbolic
    implicit none

    real, dimension(5) :: xsin = (/ -2.0,-0.9, 0.0, 0.9, 2.0 /)
    real, dimension(5) :: xcos = (/  1.0, 1.1, 1.9, 2.0, 3.0 /)
    real, dimension(5) :: xtan = (/ -0.9,-0.1, 0.0, 0.1, 0.9 /)

    write( *, '(a)'       ) 'Inverse hyperbolic functions:  '
    write( *, '(a,5f7.4)' ) 'asinh:     ', asinh(xsin)
    write( *, '(a,5f7.4)' ) 'acosh:     ', acosh(xcos)
    write( *, '(a,5f7.4)' ) 'atanh:     ', atanh(xtan)
end program chk_inverse_hyperbolic


! Guessing game - guess the number

program guess_my_number
   implicit none
   integer, parameter:: dp=kind(0.d0)

   integer                          :: guess
   real(dp)                         :: rand
   integer                          :: i, clock, count, n
   integer,dimension(:),allocatable :: seed

   real,parameter :: rmax = 100

   !initialize random number generator:
   call random_seed(size=n)
   allocate(seed(n))
   call system_clock(count)
   seed = count
   call random_seed(put=seed)
   deallocate(seed)

   !pick a random number between 1 and rmax:
   call random_number(rand)          !r between 0.0 and 1.0
   i = int((rmax-1.0)*rand + 1.0)    !i between 1 and rmax

   !get user guess:
   write(*,'(A)') 'I''m thinking of a number between 1 and 100.'
   do   !loop until guess is correct
      write(*,'(A)',advance='NO') 'Enter Guess: '
      read(*,'(I5)') guess
      if (guess==i) then
         exit
      else if (guess > i) then
         write(*,*) 'Sorry, try again. the number is smaller than guess'
      else
         write(*,*) 'Sorry, try again. the number is larger than guess'
      end if
   end do

   write(*,*) 'You''ve guessed my number!'

end program guess_my_number


module mod_rational
  implicit none
  type rational
    integer(8) :: n, d
  end type rational
  interface assignment(=)
    module procedure assign0, assign1
  end interface assignment(=)
  interface operator(+)
    module procedure add0, add1, add2
  end interface operator(+)
  interface operator(-)
    module procedure sub0, sub1, sub2
  end interface operator(-)
  interface operator(*)
    module procedure mul0, mul1, mul2
  end interface operator(*)
  interface operator(/)
    module procedure div0, div1, div2
  end interface operator(/)
  interface operator(**)
    module procedure pow1
  end interface operator(**)
  interface operator(.gt.)
    module procedure gt0, gt1, gt2
  end interface operator(.gt.)
  interface operator(.ge.)
    module procedure ge0, ge1, ge2
  end interface operator(.ge.)
  interface operator(.eq.)
    module procedure eq0, eq1, eq2
  end interface operator(.eq.)
  interface operator(.le.)
    module procedure le0, le1, le2
  end interface operator(.le.)
  interface operator(.lt.)
    module procedure lt0, lt1, lt2
  end interface operator(.lt.)
  interface operator(.ne.)
    module procedure ne0, ne1, ne2
  end interface operator(.ne.)
  private
  public :: rational, show, gcd, lcm, ratio_of
  public :: trunc, ceil, round, is_int, int_of
  public :: assignment(=), operator(+), operator(-)
  public :: operator(*), operator(/), operator(**)
  public :: operator(.gt.), operator(.ge.), operator(.eq.)
  public :: operator(.le.), operator(.lt.), operator(.ne.)
contains
  subroutine show(a)
    implicit none
    type(rational), intent(in) :: a
    write(*,'(i0,"/",i0)') a%n, a%d
    return
  end subroutine show
  function trunc(a) result(n)
    implicit none
    type(rational), intent(in) :: a
    integer(8) :: n
    n = a%n/a%d
    if (mod(abs(a%n),a%d).eq.0_8) return
    if (a%n.lt.0_8) n = n-1_8
    return
  end function trunc
  function ceil(a) result(n)
    implicit none
    type(rational), intent(in) :: a
    integer(8) :: n
    n = a%n/a%d
    if (mod(abs(a%n),a%d).eq.0_8) return
    if (a%n.gt.0_8) n = n+1_8
    return
  end function ceil
  function round(a) result(n)
    implicit none
    type(rational), intent(in) :: a
    type(rational) :: b
    integer :: n
    call assign0(b,"1/2")
    n = trunc(a+b)
    return
  end function round
  function is_int(a) result(x)
    implicit none
    type(rational), intent(in) :: a
    logical :: x
    x = a%d.eq.1_8
    return
  end function is_int
  function int_of(a) result(n)
    implicit none
    type(rational), intent(in) :: a
    integer(8) :: n
    n = a%n
    return
  end function int_of
  subroutine assign0(r,s)
    implicit none
    type(rational), intent(inout) :: r
    character(*), intent(in) :: s
    integer :: i, l
    integer(8) :: n, d, g
    l = len_trim(s)
    do i = 2, l-1
      if (s(i:i).eq."/") then
        read(s(1:i-1),*) n
        read(s(i+1:l),*) d
        exit
      end if
    end do
    g = gcd(n,d)
    r%n = n/g
    r%d = d/g
    return
  end subroutine assign0
  subroutine assign1(r,a)
    implicit none
    type(rational), intent(inout) :: r
    integer(8), intent(in) :: a
    r%n = a
    r%d = 1_8
    return
  end subroutine assign1
  function ratio_of(a,b) result(r)
    implicit none
    integer(8), intent(in) :: a, b
    type(rational) :: r
    r%n = a
    r%d = b
    return
  end function ratio_of
  function add0(a,b) result(r)
    implicit none
    type(rational), intent(in) :: a, b
    type(rational) :: r
    integer(8) :: l, g
    l = lcm(a%d,b%d)
    r%n = (a%n*l)/a%d+(b%n*l)/b%d
    r%d = l
    g = gcd(abs(r%n),abs(r%d))
    r%n = r%n/g
    r%d = r%d/g
    return
  end function add0
  function add1(a,b) result(r)
    implicit none
    type(rational), intent(in) :: a
    integer(8), intent(in) :: b
    type(rational) :: r
    call assign1(r,b)
    r = add0(a,r)
    return
  end function add1
  function add2(a,b) result(r)
    implicit none
    integer(8), intent(in) :: a
    type(rational), intent(in) :: b
    type(rational) :: r
    call assign1(r,a)
    r = add0(r,b)
    return
  end function add2
  function sub0(a,b) result(r)
    implicit none
    type(rational), intent(in) :: a, b
    type(rational) :: r
    integer(8) :: l, g
    l = lcm(a%d,b%d)
    r%n = (a%n*l)/a%d-(b%n*l)/b%d
    r%d = l
    g = gcd(abs(r%n),abs(r%d))
    r%n = r%n/g
    r%d = r%d/g
    return
  end function sub0
  function sub1(a,b) result(r)
    implicit none
    type(rational), intent(in) :: a
    integer(8), intent(in) :: b
    type(rational) :: r
    call assign1(r,b)
    r = sub0(a,r)
    return
  end function sub1
  function sub2(a,b) result(r)
    implicit none
    integer(8), intent(in) :: a
    type(rational), intent(in) :: b
    type(rational) :: r
    call assign1(r,a)
    r = sub0(r,b)
    return
  end function sub2
  function mul0(a,b) result(r)
    implicit none
    type(rational), intent(in) :: a, b
    type(rational) :: r
    integer(8) :: g
    r%n = a%n*b%n
    r%d = a%d*b%d
    g = gcd(abs(r%n),abs(r%d))
    r%n = r%n/g
    r%d = r%d/g
    return
  end function mul0
  function mul1(a,b) result(r)
    implicit none
    type(rational), intent(in) :: a
    integer(8), intent(in) :: b
    type(rational) :: r
    call assign1(r,b)
    r = mul0(a,r)
    return
  end function mul1
  function mul2(a,b) result(r)
    implicit none
    integer(8), intent(in) :: a
    type(rational), intent(in) :: b
    type(rational) :: r
    call assign1(r,a)
    r = mul0(r,b)
    return
  end function mul2
  function div0(a,b) result(r)
    implicit none
    type(rational), intent(in) :: a, b
    type(rational) :: r
    r = mul0(a,inv(b))
    return
  end function div0
  function div1(a,b) result(r)
    implicit none
    type(rational), intent(in) :: a
    integer(8), intent(in) :: b
    type(rational) :: r
    call assign1(r,b)
    r = div0(a,r)
    return
  end function div1
  function div2(a,b) result(r)
    implicit none
    integer(8), intent(in) :: a
    type(rational), intent(in) :: b
    type(rational) :: r
    call assign1(r,a)
    r = div0(r,b)
    return
  end function div2
  function inv(n) result(m)
    implicit none
    type(rational), intent(in) :: n
    type(rational) :: m
    m%n = n%d
    m%d = n%n
    return
  end function inv
  recursive function pow1(a,b) result(r)
    implicit none
    type(rational), intent(in) :: a
    integer(8), intent(in) :: b
    type(rational) :: r
    if (b.eq.0_8) then
      call assign1(r,1_8)
      return
    end if
    if (mod(b,2_8).eq.0_8) then
      r = pow1(a,b/2_8)
      r = mul0(r,r)
      return
    end if
    r = mul0(a,pow1(a,b-1_8))
    return
  end function pow1
  function lcm(x,y) result(z)
    implicit none
    integer(8), intent(in) :: x, y
    integer(8) :: z
    z = (x/gcd(x,y))*y
    return
  end function lcm
  recursive function gcd(x,y) result(z)
    implicit none
    integer(8), intent(in) :: x, y
    integer(8) :: z
    if (x.lt.y) then
      z = gcd(y,x)
      return
    end if
    z = x
    if (y.eq.0_8) return
    z = gcd(y,mod(x,y))
    return
  end function gcd
  function gt0(a,b) result(x)
    implicit none
    type(rational), intent(in) :: a, b
    type(rational) :: r
    logical :: x
    r = sub0(a,b)
    x = r%n.gt.0_8
    return
  end function gt0
  function gt1(a,b) result(x)
    implicit none
    type(rational), intent(in) :: a
    integer(8), intent(in) :: b
    type(rational) :: r
    logical :: x
    call assign1(r,b)
    x = gt0(a,r)
    return
  end function gt1
  function gt2(a,b) result(x)
    implicit none
    integer(8), intent(in) :: a
    type(rational), intent(in) :: b
    type(rational) :: r
    logical :: x
    call assign1(r,a)
    x = gt0(r,b)
    return
  end function gt2
  function ge0(a,b) result(x)
    implicit none
    type(rational), intent(in) :: a, b
    type(rational) :: r
    logical :: x
    r = sub0(a,b)
    x = r%n.ge.0_8
    return
  end function ge0
  function ge1(a,b) result(x)
    implicit none
    type(rational), intent(in) :: a
    integer(8), intent(in) :: b
    type(rational) :: r
    logical :: x
    call assign1(r,b)
    x = ge0(a,r)
    return
  end function ge1
  function ge2(a,b) result(x)
    implicit none
    integer(8), intent(in) :: a
    type(rational), intent(in) :: b
    type(rational) :: r
    logical :: x
    call assign1(r,a)
    x = ge0(r,b)
    return
  end function ge2
  function eq0(a,b) result(x)
    implicit none
    type(rational), intent(in) :: a, b
    type(rational) :: r
    logical :: x
    r = sub0(a,b)
    x = r%n.eq.0_8
    return
  end function eq0
  function eq1(a,b) result(x)
    implicit none
    type(rational), intent(in) :: a
    integer(8), intent(in) :: b
    type(rational) :: r
    logical :: x
    call assign1(r,b)
    x = eq0(a,r)
    return
  end function eq1
  function eq2(a,b) result(x)
    implicit none
    integer(8), intent(in) :: a
    type(rational), intent(in) :: b
    type(rational) :: r
    logical :: x
    call assign1(r,a)
    x = eq0(r,b)
    return
  end function eq2
  function le0(a,b) result(x)
    implicit none
    type(rational), intent(in) :: a, b
    type(rational) :: r
    logical :: x
    r = sub0(a,b)
    x = r%n.le.0_8
    return
  end function le0
  function le1(a,b) result(x)
    implicit none
    type(rational), intent(in) :: a
    integer(8), intent(in) :: b
    type(rational) :: r
    logical :: x
    call assign1(r,b)
    x = le0(a,r)
    return
  end function le1
  function le2(a,b) result(x)
    implicit none
    integer(8), intent(in) :: a
    type(rational), intent(in) :: b
    type(rational) :: r
    logical :: x
    call assign1(r,a)
    x = le0(r,b)
    return
  end function le2
  function lt0(a,b) result(x)
    implicit none
    type(rational), intent(in) :: a, b
    type(rational) :: r
    logical :: x
    r = sub0(a,b)
    x = r%n.lt.0_8
    return
  end function lt0
  function lt1(a,b) result(x)
    implicit none
    type(rational), intent(in) :: a
    integer(8), intent(in) :: b
    type(rational) :: r
    logical :: x
    call assign1(r,b)
    x = lt0(a,r)
    return
  end function lt1
  function lt2(a,b) result(x)
    implicit none
    integer(8), intent(in) :: a
    type(rational), intent(in) :: b
    type(rational) :: r
    logical :: x
    call assign1(r,a)
    x = lt0(r,b)
    return
  end function lt2
  function ne0(a,b) result(x)
    implicit none
    type(rational), intent(in) :: a, b
    type(rational) :: r
    logical :: x
    r = sub0(a,b)
    x = r%n.ne.0_8
    return
  end function ne0
  function ne1(a,b) result(x)
    implicit none
    type(rational), intent(in) :: a
    integer(8), intent(in) :: b
    type(rational) :: r
    logical :: x
    call assign1(r,b)
    x = ne0(a,r)
    return
  end function ne1
  function ne2(a,b) result(x)
    implicit none
    integer(8), intent(in) :: a
    type(rational), intent(in) :: b
    type(rational) :: r
    logical :: x
    call assign1(r,a)
    x = ne0(r,b)
    return
  end function ne2
end module mod_rational


      REAL             FUNCTION SBESJ0 (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 SBESJ0 Krogh  Added external statement.
C>> 1995-11-10 SBESJ0 Krogh  Changed data statment for C converstion.
C>> 1995-11-03 SBESJ0 Krogh  Removed blanks in numbers for C conversion.
C>> 1994-11-11 SBESJ0 Krogh   Declared all vars.
C>> 1994-10-20 SBESJ0 Krogh  Changes to use M77CON
C>> 1990-11-29 SBESJ0 CLL
C>> 1985-08-02 SBESJ0 Lawson  Initial code.
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C C.L.LAWSON & S.CHAN, JPL, 1984 FEB ADAPTED TO JPL MATH77 LIBRARY.
c     ------------------------------------------------------------------
c--S replaces "?": ?BESJ0, ?BMP0, ?INITS, ?CSEVL
c     ------------------------------------------------------------------
      EXTERNAL R1MACH, SCSEVL
      INTEGER NTJ0
      REAL             X, BJ0CS(19), AMPL, THETA, XSML, Y,
     1  R1MACH, SCSEVL
C
C SERIES FOR BJ0        ON THE INTERVAL  0.          TO  1.60000E+01
C                                        WITH WEIGHTED ERROR   4.39E-32
C                                         LOG WEIGHTED ERROR  31.36
C                               SIGNIFICANT FIGURES REQUIRED  31.21
C                                    DECIMAL PLACES REQUIRED  32.00
C
      SAVE NTJ0, XSML
C
      DATA BJ0CS / +.10025416196893913701073127264074E+0,
     *  -.66522300776440513177678757831124E+0,
     *  +.24898370349828131370460468726680E+0,
     *  -.33252723170035769653884341503854E-1,
     *  +.23114179304694015462904924117729E-2,
     *  -.99112774199508092339048519336549E-4,
     *  +.28916708643998808884733903747078E-5,
     *  -.61210858663032635057818407481516E-7,
     *  +.98386507938567841324768748636415E-9,
     *  -.12423551597301765145515897006836E-10,
     *  +.12654336302559045797915827210363E-12,
     *  -.10619456495287244546914817512959E-14,
     *  +.74706210758024567437098915584000E-17,
     *  -.44697032274412780547627007999999E-19,
     *  +.23024281584337436200523093333333E-21,
     *  -.10319144794166698148522666666666E-23,
     *  +.40608178274873322700800000000000E-26,
     *  -.14143836005240913919999999999999E-28,
     *  +.43910905496698880000000000000000E-31 /
C
      DATA NTJ0, XSML / 0, 0.E0 /
C     ------------------------------------------------------------------
      IF (NTJ0.NE.0) GO TO 10
      call SINITS (BJ0CS, 19, 0.1E0*R1MACH(3), NTJ0)
      XSML = SQRT (4.0E0*R1MACH(3))
C
 10   Y = ABS(X)
C
      IF (Y .LE. XSML) THEN
        SBESJ0 = 1.E0
      ELSE IF (Y .LE. 4.E0) THEN
        SBESJ0 = SCSEVL (.125E0*Y*Y-1.E0, BJ0CS, NTJ0)
      ELSE
        CALL SBMP0 (Y, AMPL, THETA)
        SBESJ0 = AMPL * COS(THETA)
      END IF
C
      RETURN
      END


      SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED,
     $                   S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK,
     $                   IWORK, INFO )
*
*  -- LAPACK driver routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          EQUED, FACT, UPLO
      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
      DOUBLE PRECISION   RCOND
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
     $                   BERR( * ), FERR( * ), S( * ), WORK( * ),
     $                   X( LDX, * )
*     ..
*
*  Purpose
*  =======
*
*  DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
*  compute the solution to a real system of linear equations
*     A * X = B,
*  where A is an N-by-N symmetric positive definite matrix and X and B
*  are N-by-NRHS matrices.
*
*  Error bounds on the solution and a condition estimate are also
*  provided.
*
*  Description
*  ===========
*
*  The following steps are performed:
*
*  1. If FACT = 'E', real scaling factors are computed to equilibrate
*     the system:
*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
*     Whether or not the system will be equilibrated depends on the
*     scaling of the matrix A, but if equilibration is used, A is
*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
*
*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
*     factor the matrix A (after equilibration if FACT = 'E') as
*        A = U**T* U,  if UPLO = 'U', or
*        A = L * L**T,  if UPLO = 'L',
*     where U is an upper triangular matrix and L is a lower triangular
*     matrix.
*
*  3. If the leading i-by-i principal minor is not positive definite,
*     then the routine returns with INFO = i. Otherwise, the factored
*     form of A is used to estimate the condition number of the matrix
*     A.  If the reciprocal of the condition number is less than machine
*     precision, INFO = N+1 is returned as a warning, but the routine
*     still goes on to solve for X and compute error bounds as
*     described below.
*
*  4. The system of equations is solved for X using the factored form
*     of A.
*
*  5. Iterative refinement is applied to improve the computed solution
*     matrix and calculate error bounds and backward error estimates
*     for it.
*
*  6. If equilibration was used, the matrix X is premultiplied by
*     diag(S) so that it solves the original system before
*     equilibration.
*
*  Arguments
*  =========
*
*  FACT    (input) CHARACTER*1
*          Specifies whether or not the factored form of the matrix A is
*          supplied on entry, and if not, whether the matrix A should be
*          equilibrated before it is factored.
*          = 'F':  On entry, AF contains the factored form of A.
*                  If EQUED = 'Y', the matrix A has been equilibrated
*                  with scaling factors given by S.  A and AF will not
*                  be modified.
*          = 'N':  The matrix A will be copied to AF and factored.
*          = 'E':  The matrix A will be equilibrated if necessary, then
*                  copied to AF and factored.
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  Upper triangle of A is stored;
*          = 'L':  Lower triangle of A is stored.
*
*  N       (input) INTEGER
*          The number of linear equations, i.e., the order of the
*          matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrices B and X.  NRHS >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the symmetric matrix A, except if FACT = 'F' and
*          EQUED = 'Y', then A must contain the equilibrated matrix
*          diag(S)*A*diag(S).  If UPLO = 'U', the leading
*          N-by-N upper triangular part of A contains the upper
*          triangular part of the matrix A, and the strictly lower
*          triangular part of A is not referenced.  If UPLO = 'L', the
*          leading N-by-N lower triangular part of A contains the lower
*          triangular part of the matrix A, and the strictly upper
*          triangular part of A is not referenced.  A is not modified if
*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
*
*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
*          diag(S)*A*diag(S).
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  AF      (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
*          If FACT = 'F', then AF is an input argument and on entry
*          contains the triangular factor U or L from the Cholesky
*          factorization A = U**T*U or A = L*L**T, in the same storage
*          format as A.  If EQUED .ne. 'N', then AF is the factored form
*          of the equilibrated matrix diag(S)*A*diag(S).
*
*          If FACT = 'N', then AF is an output argument and on exit
*          returns the triangular factor U or L from the Cholesky
*          factorization A = U**T*U or A = L*L**T of the original
*          matrix A.
*
*          If FACT = 'E', then AF is an output argument and on exit
*          returns the triangular factor U or L from the Cholesky
*          factorization A = U**T*U or A = L*L**T of the equilibrated
*          matrix A (see the description of A for the form of the
*          equilibrated matrix).
*
*  LDAF    (input) INTEGER
*          The leading dimension of the array AF.  LDAF >= max(1,N).
*
*  EQUED   (input or output) CHARACTER*1
*          Specifies the form of equilibration that was done.
*          = 'N':  No equilibration (always true if FACT = 'N').
*          = 'Y':  Equilibration was done, i.e., A has been replaced by
*                  diag(S) * A * diag(S).
*          EQUED is an input argument if FACT = 'F'; otherwise, it is an
*          output argument.
*
*  S       (input or output) DOUBLE PRECISION array, dimension (N)
*          The scale factors for A; not accessed if EQUED = 'N'.  S is
*          an input argument if FACT = 'F'; otherwise, S is an output
*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
*          must be positive.
*
*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
*          On entry, the N-by-NRHS right hand side matrix B.
*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
*          B is overwritten by diag(S) * B.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
*          the original system of equations.  Note that if EQUED = 'Y',
*          A and B are modified on exit, and the solution to the
*          equilibrated system is inv(diag(S))*X.
*
*  LDX     (input) INTEGER
*          The leading dimension of the array X.  LDX >= max(1,N).
*
*  RCOND   (output) DOUBLE PRECISION
*          The estimate of the reciprocal condition number of the matrix
*          A after equilibration (if done).  If RCOND is less than the
*          machine precision (in particular, if RCOND = 0), the matrix
*          is singular to working precision.  This condition is
*          indicated by a return code of INFO > 0.
*
*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
*          The estimated forward error bound for each solution vector
*          X(j) (the j-th column of the solution matrix X).
*          If XTRUE is the true solution corresponding to X(j), FERR(j)
*          is an estimated upper bound for the magnitude of the largest
*          element in (X(j) - XTRUE) divided by the magnitude of the
*          largest element in X(j).  The estimate is as reliable as
*          the estimate for RCOND, and is almost always a slight
*          overestimate of the true error.
*
*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
*          The componentwise relative backward error of each solution
*          vector X(j) (i.e., the smallest relative change in
*          any element of A or B that makes X(j) an exact solution).
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
*
*  IWORK   (workspace) INTEGER array, dimension (N)
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*          > 0: if INFO = i, and i is
*                <= N:  the leading minor of order i of A is
*                       not positive definite, so the factorization
*                       could not be completed, and the solution has not
*                       been computed. RCOND = 0 is returned.
*                = N+1: U is nonsingular, but RCOND is less than machine
*                       precision, meaning that the matrix is singular
*                       to working precision.  Nevertheless, the
*                       solution and error bounds are computed because
*                       there are a number of situations where the
*                       computed solution can be more accurate than the
*                       value of RCOND would suggest.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            EQUIL, NOFACT, RCEQU
      INTEGER            I, INFEQU, J
      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANSY
      EXTERNAL           LSAME, DLAMCH, DLANSY
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLACPY, DLAQSY, DPOCON, DPOEQU, DPORFS, DPOTRF,
     $                   DPOTRS, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      NOFACT = LSAME( FACT, 'N' )
      EQUIL = LSAME( FACT, 'E' )
      IF( NOFACT .OR. EQUIL ) THEN
         EQUED = 'N'
         RCEQU = .FALSE.
      ELSE
         RCEQU = LSAME( EQUED, 'Y' )
         SMLNUM = DLAMCH( 'Safe minimum' )
         BIGNUM = ONE / SMLNUM
      END IF
*
*     Test the input parameters.
*
      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
     $     THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
     $          THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
     $         ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
         INFO = -9
      ELSE
         IF( RCEQU ) THEN
            SMIN = BIGNUM
            SMAX = ZERO
            DO 10 J = 1, N
               SMIN = MIN( SMIN, S( J ) )
               SMAX = MAX( SMAX, S( J ) )
   10       CONTINUE
            IF( SMIN.LE.ZERO ) THEN
               INFO = -10
            ELSE IF( N.GT.0 ) THEN
               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
            ELSE
               SCOND = ONE
            END IF
         END IF
         IF( INFO.EQ.0 ) THEN
            IF( LDB.LT.MAX( 1, N ) ) THEN
               INFO = -12
            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
               INFO = -14
            END IF
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPOSVX', -INFO )
         RETURN
      END IF
*
      IF( EQUIL ) THEN
*
*        Compute row and column scalings to equilibrate the matrix A.
*
         CALL DPOEQU( N, A, LDA, S, SCOND, AMAX, INFEQU )
         IF( INFEQU.EQ.0 ) THEN
*
*           Equilibrate the matrix.
*
            CALL DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
            RCEQU = LSAME( EQUED, 'Y' )
         END IF
      END IF
*
*     Scale the right hand side.
*
      IF( RCEQU ) THEN
         DO 30 J = 1, NRHS
            DO 20 I = 1, N
               B( I, J ) = S( I )*B( I, J )
   20       CONTINUE
   30    CONTINUE
      END IF
*
      IF( NOFACT .OR. EQUIL ) THEN
*
*        Compute the Cholesky factorization A = U'*U or A = L*L'.
*
         CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF )
         CALL DPOTRF( UPLO, N, AF, LDAF, INFO )
*
*        Return if INFO is non-zero.
*
         IF( INFO.GT.0 )THEN
            RCOND = ZERO
            RETURN
         END IF
      END IF
*
*     Compute the norm of the matrix A.
*
      ANORM = DLANSY( '1', UPLO, N, A, LDA, WORK )
*
*     Compute the reciprocal of the condition number of A.
*
      CALL DPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO )
*
*     Compute the solution matrix X.
*
      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
      CALL DPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO )
*
*     Use iterative refinement to improve the computed solution and
*     compute error bounds and backward error estimates for it.
*
      CALL DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX,
     $             FERR, BERR, WORK, IWORK, INFO )
*
*     Transform the solution matrix X to a solution of the original
*     system.
*
      IF( RCEQU ) THEN
         DO 50 J = 1, NRHS
            DO 40 I = 1, N
               X( I, J ) = S( I )*X( I, J )
   40       CONTINUE
   50    CONTINUE
         DO 60 J = 1, NRHS
            FERR( J ) = FERR( J ) / SCOND
   60    CONTINUE
      END IF
*
*     Set INFO = N+1 if the matrix is singular to working precision.
*
      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
     $   INFO = N + 1
*
      RETURN
*
*     End of DPOSVX
*
      END