      subroutine reorth(n,k,V,ldv,vnew,normv,index,alpha,work,
     c     iflag,nre)
c
c FORTRAN 77 version of MATLAB routine REORTH:
c
c REORTH   Reorthogonalize a vector using iterated Gram-Schmidt
c
c   [R_NEW,NORMR_NEW,NRE] = reorth(Q,R,NORMR,INDEX,ALPHA,METHOD)
c   reorthogonalizes R against the subset of columns of Q given by INDEX.
c   If INDEX==[] then R is reorthogonalized all columns of Q.
c   If the result R_NEW has a small norm, i.e. if norm(R_NEW) < ALPHA*NORMR,
c   then a second reorthogonalization is performed. If the norm of R_NEW
c   is once more decreased by  more than a factor of ALPHA then R is
c   numerically in span(Q(:,INDEX)) and a zero-vector is returned for R_NEW.
c
c   If method==0 then iterated modified Gram-Schmidt is used.
c   If method==1 then iterated classical Gram-Schmidt is used.
c
c   The default value for ALPHA is 0.5.
c   NRE is the number of reorthogonalizations performed (1 or 2).

c References:
c  Aake Bjorck, "Numerical Methods for Least Squares Problems",
c  SIAM, Philadelphia, 1996, pp. 68-69.
c
c  J.~W. Daniel, W.~B. Gragg, L. Kaufman and G.~W. Stewart,
c  ``Reorthogonalization and Stable Algorithms Updating the
c  Gram-Schmidt QR Factorization'', Math. Comp.,  30 (1976), no.
c  136, pp. 772-795.
c
c  B. N. Parlett, ``The Symmetric Eigenvalue Problem'',
c  Prentice-Hall, Englewood Cliffs, NJ, 1980. pp. 105-109

c  Rasmus Munk Larsen, DAIMI, 1998.
      implicit none
      integer n,k,ldv,i,iflag,nre
      double precision V(ldv,*),vnew(*),normv,index(*),work(*)
      double precision alpha,normv_old,dnrm2
      integer MAXTRY
      parameter (MAXTRY=4)
      external dgemv,dnrm2

c     Hack: If index .ne. 1:k we do MGS to avoid reshuffling.
      if (iflag.eq.1) then
         do i=1,k
            if (int(index(i)).ne.i) then
               iflag=0
               goto 100
            endif
         enddo
      endif
 100  normv_old = 0
      nre = 0
      normv = dnrm2(n,vnew,1)
      do while ((normv.lt.alpha*normv_old .or. nre.eq.0))
         if (iflag.eq.1) then
c           CGS:
            call dgemv('T',n,k,1D0,V,ldv,vnew,1,0D0,work,1)
            call dgemv('N',n,k,-1D0,V,ldv,work,1,1D0,vnew,1)
         else
c           MGS:
            call MGS(n,k,V,ldv,vnew,index)
         endif
         normv_old = normv
         normv = dnrm2(n,vnew,1)
         nre = nre + 1

         if  ( nre.gt.MAXTRY )  then
c
c     vnew is numerically in span(V) => return vnew = (0,0,...,0)^T
            normv = 0d0
            do i=1,n
               vnew(i) = 0d0
            enddo
            return
         endif
      enddo
      end
c
c****************************************************************************
c

      subroutine MGS(n,k,V,ldv,vnew,index)
      implicit none
      integer n,k,ldv
      double precision V(ldv,*),vnew(*),index(*)
      integer i,j,idx
      double precision s

c
c     Modified Gram-Schmidt orthogonalization:
c     Orthogalizes vnew against the k vectors in V by the
c     iterative process
c
c     FOR i=1...k DO
c       vnew = vnew - DOT( V(:,i), vnew ) * V(:,i)
c

c     This simple version is faster on Pentium machines.
c     Compile with "g77 -O6 -funroll-all-loops -fomit-frame-pointer"

      do i=1,k
         idx = int(index(i))
         s = 0
         do j=1,n
            s = s + V(j,idx)*vnew(j)
         enddo
         do j=1,n
            vnew(j) = vnew(j) - s*V(j,idx)
         enddo
      enddo
      end
c
c****************************************************************************
c


!================================ constants ==================================80
!
! Provides useful constants
!
!=============================================================================80
module set_constants

  use set_precision, only : dp

  implicit none

  private

  public :: zero, one, onep5, two, three, four, five, six
  public :: sixth, fifth, fourth, third, half

! extremes
  public :: small, large

! transcendental numbers, etc...
  public :: pi, set_pi

  real(dp), parameter :: zero   = 0.0_dp
  real(dp), parameter :: one    = 1.0_dp
  real(dp), parameter :: onep5  = 1.5_dp
  real(dp), parameter :: two    = 2.0_dp
  real(dp), parameter :: three  = 3.0_dp
  real(dp), parameter :: four   = 4.0_dp
  real(dp), parameter :: five   = 5.0_dp
  real(dp), parameter :: six    = 6.0_dp

  real(dp), parameter :: sixth  = one/six
  real(dp), parameter :: fifth  = 0.2_dp
  real(dp), parameter :: fourth = 0.25_dp
  real(dp), parameter :: third  = one/three
  real(dp), parameter :: half   = 0.5_dp

  real(dp), parameter :: small  = tiny(1.0_dp)
  real(dp), parameter :: large  = huge(1.0_dp)

  real(dp) :: pi = 3.14159265358979_dp

contains

!==================================== set_pi =================================80
!
! Sets the value of PI by the acos intrinsic
!
!=============================================================================80
  subroutine set_pi
    use set_precision, only : dp

    implicit none

    pi = acos(-one)

  end subroutine set_pi

end module set_constants


c c c c c
c
c     program sums
c
c   Demonstrate Fortran 90 SUM function with MASK option
c
c    John Mahaffy  2/16/96
c
      implicit none
      integer nd,ndh,nduh, j
      parameter (nd=10,ndh=nd/2,nduh=nd-ndh)
      real csum,cpsum,cbpsum
c
      real, dimension(nd):: c=(/(j,j=-1,nd-2)/), b
c
      data b/ndh*-1.0,nduh*2.0/
      csum = sum(c(1:nd))
      cpsum= sum (c(1:nd),mask=c.gt.0)
      cbpsum= sum(c(1:nd),mask=b.gt.0.0)
c
      print *, 'Sum of all elements in c = ' , csum
      print *, 'Sum of Positive elements in c = ', cpsum
      print *, 'Sum of elements in c when corresponding elements in b>0'
     # ,' =',cbpsum
c
      stop
      end
c
c c c


program test_bit
use lfortran_intrinsic_bit, only: iand, ior, ibclr, ibset, btest
implicit none

integer(kind=4) :: a
integer(kind=4) :: b

integer(kind=8) :: x
integer(kind=8) :: y

a = 4
b = 1
if (iand(a, b) /= 0) error stop

x = 3
y = 1
if (iand(x, y) /= 1) error stop

a = 1
b = 2
if (ior(a, b) /= 3) error stop

x = 2
y = 3
if (ior(x, y) /= 3) error stop

a = 1
if (ibclr(a, 0) /= 0) error stop
if (ibset(a, 2) /= 5) error stop

x = 2
if (ibclr(x, 1) /= 0) error stop
if (ibset(x, 3) /= 10) error stop

a = 2
if (btest(a, 0)) error stop

x = 4
if (btest(x, 0)) error stop

end program


      module cdat

      integer*4 :: ipot

      real*8,public,parameter :: PI=4.d0*atan(1.0)

      integer,parameter :: nmax = 16

      complex*16,public,parameter::im=(0d0,1d0)

      real*8 :: al,beta

      integer*4 ::  Ntraj,kmax,kout,idum1,idum2,order,nbx,nby
      real*8 :: dt,amx,amy,ax0,ay0,ax,ay,qx0,qy0,px0,py0
      real*8 :: xmin,xmax,ymin,ymax
      save
      end module cdat


***********************************************************************
* Recovered gradient technique
*
* This file implements recovered gradient routines in extended calling
* convention, supporting arbitrary grids without COMMON blocks.
*
* For the time being these routines only support ZZ-recovery
* technique on arbitrary quadrilateral grids.
***********************************************************************

**************************************************************************
* Local gradient with transformation to reference element
*
* Computes the local recovered gradient in vertex IVT by a linear
* approach. For this purpose the values in the center of all elements
* around the inner vertex JVT are taken.
*
* JVT must be an inner node with at least 3 elements surrounding.
* IVT can be a boundary node. For inner nodes JVT=IVT is usually
* the best choice.
*
* Approach:
*  -Compute the values of the derivatives of the basis functions
*   in the center of all elements surrounding the node JVT
*  -Create a bilinear polynomial with corners in the midpoints of
*   these elements. Prescribe the values of this polynomial in
*   these points.
*  -Take the value of the polynomial in the center (or better to say,
*   in IVT) and use this as a recovered value.
*
* In:
*  TRIA   - array [1..SZTRIA] of integer
*           Triangulation structure describing the mesh
*  DU     - array [1..*] of double
*           Solution vector
*  DCORVG,
*  KVERT,
*  KMID,
*  KVEL   - Usual geometry information. Must correspond to the handles
*           in the TRIA-structure. Transferred via parameters for
*           easier and quicker access.
*
*  X,
*  Y      - Coordinates of the point where the reconstructed gradient
*           should be computed
*  IVT    - Vertex number where to evaluate. Should correspond to (X,Y)
*           if possible.
*  JVT    - "Inner reference" node, 1..NVT. Must be a vertex in the inner
*           of the domain, completely surrounded by elements. JVT should
*           be as close to (X,Y) as possible.
*
*  NVEL   - Maximum number of elements meeting in a vertex; must
*           correspond to NVEL in the TRIA-structure.
*  NVELJ  - Number of elements meeting in current vertex JVT
*  ELE    - Element that corresponds to solution vector DU; this is
*           also used for reconstruction. Must be conformal, parametric
*           element (Q1,Q2,...).
*  WORK   - array [1..*] of double
*           Workspace vector; will be ignored if LSIZE=-1
*  LWORK  - size of workspace vector, or
*           -1=determine LSIZE, return size of workspace vector in LSIZE
*
* Out:
*  DGRADX,
*  DGRADY - reconstructed gradient in vertex IVT
*
* The routine can be called with a Dummy-call using LSIZE=-1 to determine
* the size of the workspace vector. In this case no computation will be
* done. Instead the routine will return in LSIZE the necessary size of
* the workspace vector WORK. To determine the maximum amount of memory
* necessary for all nodes, the caller should use NVELJ=NNVEL and NVE=NNVE.
*
* The usage of IVT, JVT and (X,Y) is the following:
*
* a) If (X,Y) are the coordinates of a vertex surrounded by at least,
*    3 elementts, IVT=JVT=(X,Y) must be used.
* b) If (X,Y) are the coordinates of a vertex with less than adjacent
*    elements (typically boundary vertex), IVT=(X,Y) must
*    be used, JVT must be an inner vertex surrounded by elements.
* c) If (X,Y) are the coordinates of an inner node, not corresponding
*    to a vertex (element midpoint e.g.),
*    - use IVT=JVT=vertex number of an inner vertex surrounded by elements
*    - use JVT=vertex number of an inner vertex surrounded by elements,
*      IVT=vertex number of a neighbour of JVT
* If IVT is not a neighbour of JVT, the routine will find a neighbour
* automatically.
*
*             *------*------*  *------*------* *------*------*
*             |      |      |  |      |      | |      |      |
*             |      |      |  |      |      | |      |      |
*             |     IVT     |  |      |      | |     IVT     |
*             *-----JVT-----*  *-----JVT-----* *-----JVT-----*
*             |    (X,Y)    |  |      |      | |      |      |
*             |      |      |  |      |      | |      | (X,Y)|
*             |      |      |  |      |      | |      |      |
*             *------*------*  *-----IVT-----* *-----IVT-----*
*                                   (X,Y)

**************************************************************************

      SUBROUTINE GRDLO2(TRIA,DU,DGRADX,DGRADY,
     *                  DCORVG,KVERT,KMID,KVEL,
     *                  X,Y,IVT,JVT,NVELJ,NVEL,ELE,
     *                  WORK, LWORK)

      IMPLICIT NONE

      INCLUDE 'cout.inc'
      INCLUDE 'cerr.inc'

      INCLUDE 'cbasictria.inc'

      INCLUDE 'cbasicelem.inc'
      INCLUDE 'celem.inc'

      INCLUDE 'ccub.inc'

      INCLUDE 'stria.inc'

C parameters

      INTEGER LWORK,TRIA(SZTRIA)
      DOUBLE PRECISION WORK(*)
      DOUBLE PRECISION DU(*),DGRADX,DGRADY

      DOUBLE PRECISION DCORVG(2,*),X,Y
      INTEGER IVT,JVT,NVELJ,NVEL
      INTEGER KVERT(NNVE,*),KVEL(NVEL,*),KMID(NNVE,*)
      EXTERNAL ELE

C externals

      INTEGER NDFL
      EXTERNAL NDFL,E011

C local variables

      INTEGER KDFG(NNBAS),KDFL(NNBAS),IDFL,MTSIZE
      DOUBLE PRECISION DCOORD (2,4),DJF(2,2)
      DOUBLE PRECISION XDER,YDER
      INTEGER IVEL,NROWS,NCOLS,LNEED,ROW,NMXDEG,NMNMS
      DOUBLE PRECISION HSCALE,XCENTR,YCENTR
      DOUBLE PRECISION XX,YY,XHAT,YHAT,XI1,XI2
      INTEGER IELTYP,ICUB,INEIG,IVE,NVE,JP,IBAS,IEQ,ILO,I,J,K
      DOUBLE PRECISION DALPHA, DBETA, DDSTI, DXNEIG, DYNEIG

C Description of the method:
C
C We want to create a local polynom that interpolates the values of
C each partial derivative in the midpoints if the four elements
C surrounding JVT:
C
C   |-------|-------|
C   |       |       |
C   |   X.......X   |
C   |   .   |   .   |
C   |---.--JVT--.--IVT
C   |   .   |   .   |
C   |   X.......X   |
C   |       |       |
C   |-------|-------|
C
C This polynom is then evaluated in the point IVT (where for inner
C vertices IVT=JVT is used), which gives an approximation to the
C (partial) derivative in that point.
C
C In a more general case (not Q1, but Q2, Q3,...), not the midpoints of
C the elements are used, but rather the Gauss-points for that element.
C For every element we have to use "exactly the correct" Gauss-points,
C otherwise no superconvergence is to expect - i.e. Q1=midpoints,
C Q2=2x2 Gauss,...
C
C So at first we check our element about its type. We only support
C conforming elements here, so in case of another element we can
C immediately stop with an error. Otherwise we have to choose the
C correct cubature formula:

      IELTYP=-1
      CALL ELE(0D0,0D0,IELTYP)

      IF (IELTYP.EQ.11) THEN
        ICUB = 1
        NMXDEG = 1
        NCOLS = 4
      ELSE IF (IELTYP.EQ.13) THEN
        ICUB = 4
        NMXDEG = 2
        NCOLS = 9
      ELSE IF (IELTYP.EQ.14) THEN
        ICUB = 8
        NMXDEG = 3
        NCOLS = 16
      ELSE
        WRITE (*,*) 'GRDLO2: Illegal element type: ',IELTYP
      END IF

C Number of monoms per variable is 1 larger that maximum degree:

      NMNMS = NMXDEG+1

C Initialize the cubature formula for quadrilateral elements

      CALL CB2Q(ICUB)

C Get some parameters from the triangulation:

      NVE = TRIA(ONVE)

C Small description of the method:
C
C What we use here is a simple polynomial interpolation. In the
C Gaussian points of the elements surrounding JVT we compute the
C values of the derivatives. Then we create an interpolating polynomial
C that interpolates these values. We evaluate the polynomial in
C IVT to create an approximation to the derivatives of our function
C there.
C
C The polynomial we want to create has the typical form:
C
C    p(x,y) = a + bx + cy + dxy + ...
C
C such that:
C
C    p(Gauss-point) = x-derivative (Gauss-point)
C
C (the same for the Y-derivative) with the number of monoms depending
C on the element type: For Q1 we take a bilinear polynom (4 monoms),
C for Q2 a biquadratic polynom (9 monoms) and so on.
C
C This leads to two linear systems of the form
C
C   (1  X1  Y1  X1Y1  ...)  ( a )   ( DUX (X1,Y1) )
C   (1  X2  Y2  X2Y2  ...)  ( b ) = ( DUX (X2,Y2) )
C   (1  X3  Y3  X3Y3  ...)  ( c )   ( DUX (X3,Y3) )
C   ...
C
C to determine the coefficients a,b,c,... of the polynomial for
C the X-derivative and for the Y-derivative.
C
C The matrix in this system is generally a rectangle matrix.
C For 4 Q1-elements, it's 4x4, for 4 Q2-elements it's 16x9,...
C We overcome the problem of solving this by a Least square
C approach, see later.
C
C The crucial point at the beginning is the memory demand in WORK.
C We organize WORK to take two matrices and a couple of
C vectors. The NCOLS variable set above gives the number of
C columns in the matrix, which is exactly the number of monoms
C in the polynomial. The number of rows are calculated
C by "number of cubature points * number of elements around JVT".
C NCUBP is taken from the /CUB/ Common-block.

      NROWS = NCUBP*MAX(4,NVELJ)

C Where we make sure that we have at least 4 rows
C (also in the case that only 3 elements meet in a vertex! There's
C a trick to handle that case, see later).
C
C We have to store at least 2 matrices + 2 vectors for the X- and
C Y-derivatives in all the points. The size of the matrix is

      MTSIZE = NROWS*NCOLS

C And we need totally a memory amound of:

      LNEED = 2*MTSIZE + 2*NROWS

C Does the caller want to know the memory?

      IF (LWORK.LT.0) THEN
        LWORK = LNEED
        RETURN
      END IF

C Is there enough memory?

      IF (LWORK.LT.LNEED) THEN
C       Should not happen on correct implementation. Therefore we make
C       a direct message to the programmer that something went
C       wrong here
        WRITE (*,*) 'GRDLO2: Not enough memory!'
        RETURN
      END IF

C Calculate local number of degrees of freedom of our element type

      IDFL = NDFL(IELTYP)

C Ok, our central node is JVT. We will now make a loop over all
C elements surrounding that vertex. On each element we will calculate
C in every Gauss-point the values of the X- and Y-derivative.
C Furthermore we will save all the coordinates for later computation.
C These values will be saved in the WORK-array for later use.
C
C So make a loop over the elements surrounding JVT:

      DO IVEL = 1, NVELJ

C       On which element are we?

        IEL = KVEL(IVEL, JVT)

C       Calculate for that element the global degrees of freedom
C       into KDFG:

        CALL NDFGLX(TRIA,IEL,1,IELTYP,KVERT,KMID,KDFG,KDFL)

C       Transfer the coordinates of the corners into the COMMON-Block
C       (for call to ELE) as well as to DCOORD for the calculation of
C       the transformation:

        DO IVE=1,NVE
          JP=KVERT(IVE,IEL)
          KVE(IVE)=JP
          DX(IVE)=DCORVG(1,JP)
          DY(IVE)=DCORVG(2,JP)
          DCOORD(1,IVE) = DCORVG(1,JP)
          DCOORD(2,IVE) = DCORVG(2,JP)
        END DO

C       Calculate auxiliary Jacobian factors of the transformation

        CALL QINIJF (DCOORD,DJF)

C       Loop over the cubature points on our element to calculate the
C       coefficients of the FE-basis functions in that point...

        DO ICUBP = 1, NCUBP

C         Get cubature points on reference element from Common block

          XI1 = DXI(ICUBP,1)
          XI2 = DXI(ICUBP,2)

C         Calculate Jacobian matrix of transformation and its
C         determinant, as well as the real coordinates of our point

          CALL QTRAF (DCOORD,DJF,DJAC,DETJ,XI1,XI2,XX,YY)

C         Evaluate x-and y-derivative at gauss point

          CALL ELE(XI1,XI2,0)

C         Loop over the basis functions. Sum up the node values
C         weighted by the coefficients of the basis functions to
C         calculate the derivative in the gauss point.

          XDER = 0D0
          YDER = 0D0

          DO IBAS = 1,IDFL
            IEQ=KDFG(IBAS)
            ILO=KDFL(IBAS)

C           Sum up X-Derivative

            XDER = XDER + DBAS(ILO,2)*DU(IEQ)

C           Sum up Y-Derivative

            YDER = YDER + DBAS(ILO,3)*DU(IEQ)
          END DO

C         OK, X-derivative is in XDER, Y-derivative in YDER.
C         Save both values as well as the coordinates in our
C         matrix: The X-coordinate in the 2nd column, the Y-coordinate
C         in the 2nd column:

          ROW = (IVEL-1)*NCUBP+ICUBP

          WORK (NROWS + ROW)           = XX
          WORK (2*NROWS + ROW)         = YY
          WORK (2*MTSIZE + ROW)         = XDER
          WORK (2*MTSIZE + NROWS + ROW) = YDER

        END DO

      END DO

C The first column of our matrix is typically filled with 1,
C as it represents x^0*y^0:

      DO I=1,NROWS
        WORK(I) = 1D0
      END DO

C Now we know (in GPTS) all coordinates of all cubature points as well
C as the X- and Y-derivatives there.
C We now want to calculate a matrix A with each line of the form
C    ( 1  X  Y  X*Y ... )
C to calculate the coefficients of our local polynomial, which
C interpolates in the (former cubature-) points the values of the
C derivatives we just collected.
C
C But take care here! Don't use the X/Y-coordinates and try to solve!
C This can easily lead to numerical instabilities, as it would only
C consider the case that we are using a standard coordinate system.
C One example is the Q1-element:
C
C We can of course not directly construct a bilinear polynom of the
C form "a+b*x+c*y+d*x*y" that takes the values in the four midpoints,
C because if the four elements are turned by 45 degrees, the four
C midpoints are forming a "cross":
C
C     / \
C   /  X  \
C  < X-|-X >
C   \  X  /
C     \ /
C
C and the polynom does not exist in that case (not unisolvent!).
C Therefore we introduce a local coordinate system with midpoint in
C JVT. For this we take one neigbour of JVT and take the
C connecting edge as X-axes. The orthogonal vector of this then
C forms the Y-axes.
C
C For this local coordinate system we will use JVT as center.
C To form it, we need to determine a neighbour of JVT:
C
C Try to use IVT as neighbour if possible to avoid numerical
C instabilities a little bit. If this is not possible (e.g. because
C IVT is a diagonal point like on if the current "corner"-elements
C of a quadrilateral), or not necessary (because we are in the "inner"
C of the domain, so IVT=JVT), search for another arbitrary neighbour.

      IF (IVT.NE.JVT) THEN

        DO I=1,IVEL

          IEL = KVEL(I,JVT)

          DO J=1,NNVE

            IF (KVERT(J,IEL).EQ.JVT) THEN

              INEIG = KVERT(MOD (J,NNVE)+1,IEL)
              IF (INEIG.EQ.IVT) GOTO 100
              INEIG = KVERT(MOD (J+NNVE-1,NNVE)+1,IEL)
              IF (INEIG.EQ.IVT) GOTO 100

            END IF

          END DO

        END DO

      END IF

C Take an arbitrary element of JVT and look there for a neighbour

      IEL = KVEL(1,JVT)

      DO I=1,NNVE
        IF (KVERT(I,IEL).EQ.JVT) THEN
          INEIG = KVERT(MOD (I,NNVE)+1,IEL)
          GOTO 100
        END IF
      END DO
      WRITE (*,*) 'GRDLOK: KVERT destroyed!'
      STOP

100   CONTINUE

C Now we have a neighbour INEIG of JVT as well as an element IEL
C containing JVT and INEIG.
C
C Determine the coordinates of our central/reference point
C in the patch. If IVT=JVT we will later reconstruct the gradient there
C directly (or in (X,Y), respectively).
C In case of a boundary node, then IVT <> JVT and JVT is
C the center of our local coordinate system.

      XCENTR = DCORVG(1,JVT)
      YCENTR = DCORVG(2,JVT)

C Determine the coordinates of the neighbour and its coordinates:

      DXNEIG = DCORVG(1,INEIG)
      DYNEIG = DCORVG(2,INEIG)

C Determine local X-axes: vector (DALPHA,DBETA) that points from our
C modpoint to our neighbour:
C            CENTER + (DALPHA,DBETA) = NEIGHBOUR
C DDSTI is 1/length of the vector.
C The transposed vector (-DBETA,DALPHA) will be our Y-axes.

      DDSTI = 1D0/DSQRT((DXNEIG - XCENTR)**2 + (DYNEIG - YCENTR)**2)
      DALPHA = (DXNEIG - XCENTR)*DDSTI
      DBETA =  (DYNEIG - YCENTR)*DDSTI

C We need to scale out coordinate system to maintain numerical
C stability. Determine a local h from the element size of the current
C element IEL:

      HSCALE=1D0/
     *         DSQRT((DCORVG(1,KVERT(1,IEL))-DCORVG(1,KVERT(3,IEL)))**2+
     *               (DCORVG(2,KVERT(1,IEL))-DCORVG(2,KVERT(3,IEL)))**2)

C Next we have to build a matrix for the coefficients of the
C polynomial. A standard way to form such a matrix is the structure:
C   (1  X  Y  XY  X^2Y  XY^2  ...)
C   (1  X  Y  XY  X^2Y  XY^2  ...)
C   (1  X  Y  XY  X^2Y  XY^2  ...)
C   ...
C Here X,Y are not the real coordinates of the cubature points,
C but the local coordinates of the cubature points in our local
C coordinate system!
C
C For the time being we saved the real X- and Y-coordinates there.
C So now we have to make a loop over the lines, translate
C the coordinates into the local coordinate system and compute the
C other monoms.
C
C From here on we define the matrix for the coefficients to have a
C slightly different format than mentioned earlier. We will build
C the following matrix structure:
C
C   (1  X  X^2  X^3 .. Y  XY  X^2Y ...)  ( a )   ( DUX (X1,Y1) )
C   (1  X  X^2  X^3 .. Y  XY  X^2Y ...)  ( b ) = ( DUX (X2,Y2) )
C   (1  X  X^2  X^3 .. Y  XY  X^2Y ...)  ( c )   ( DUX (X3,Y3) )
C
C So the Y-coordinate will be saved not in the 2nd column, but in
C the (degree+1)'th column. This is to have all coefficients
C without the Y at the front, so the polynomials with Y=0 can
C be easier calculated later on.
C
C Make a loop over all "real" rows, ignoring the last line in case
C that we have only 3 quadrs meeting in JVT (i.e. use NCUBP*NVELJ
C instead of NROWS as loop count):

      DO ROW = 1,NCUBP*NVELJ

C       Current coordinates:

        XX = WORK (NROWS + ROW)
        YY = WORK (2*NROWS + ROW)

C       Determine the local coordinates of the cubature point in our
C       local coordinate system.

        XHAT = HSCALE*(DALPHA *(XX - XCENTR) + DBETA* (YY - YCENTR))
        YHAT = HSCALE*(-DBETA *(XX - XCENTR) + DALPHA*(YY - YCENTR))

C       And save these instead of XX/YY into the matrix. The X-
C       coordinate comes again into the 2nd column, the Y-coordinate
C       in the first column of the second monom group:

        WORK (NROWS + ROW)       = XHAT
        WORK (NMNMS*NROWS + ROW) = YHAT

C       Now the next big question: How many additional monoms does our
C       polynom have? Ok, NCOLS-3, but that's not enough to compute
C       them. We have set the maximum degree in the variable NMXDEG:
C       Q1->degree 1 (xy), Q2->degree 2 (x^2y^2),...
C       So now make a loop to calculate the missing monoms.
C       Calculate in the following order:
C       x^2,x^3,x^4,...,X^NMXDEG

        DO J=2,NMXDEG
          WORK(J*NROWS + ROW) = XHAT**J
        END DO

C       xy,x^2y,x^3y,...

        DO J=1,NMXDEG
          WORK((NMNMS+J)*NROWS + ROW) = XHAT**J * YHAT
        END DO

C       and all the rest: y^2,xy^2,x^2y^2,...

        DO I=2,NMXDEG
          DO J=0,NMXDEG
            WORK((I*NMNMS+J)*NROWS + ROW) = XHAT**J * YHAT**I
          END DO
        END DO

      END DO

C Now a little trick for the case, that we only have 3 Q1-elements
C surrounding our node  JVT. Only in this case we have less
C rows than columns - but we don't have less degrees of freedom
C than necessary!
C
C We have a 4x4-system in WORK for the coefficients of the
C local polynomial p(x,y) = a+b*x+c*y+d*x*y. We want to invert
C this to get out coefficients a,b,c,d. Unfortunately if only
C 3 elements meet in the vertex JVT, our system is indefinite,
C and so we are not able to invert the matrix!
C
C The trick is now: In this case we change our local polynomial.
C We seek for a poplynom in the form p(x,y) = a+b*x+c*y, so
C a linear polynomial on a triangle element!
C This differs from the original polynomial only in that way, that
C the last factor is missing.
C
C To obtain a,b,c in this case, we replace the last column/row of
C the matrix by a unary vector. Then the matrix decomposes into a
C 3x3-system for a,b,c and a 1x1-system for the "dummy"-coefficient d.
C    xxx0  a   midp1
C    xxx0  b = midp2
C    xxx0  c   midp3
C    0001  d   0
C We can invert that matrix and multiply it with the RHS to obtain
C a,b,c (and d). Furthermore if we set the last component of our RHS-
C vectors to 0 we ensure, that d=0. This way we can use the formula
C p(x,y) = a + b*x + c*y + d*x*y for all cases regardless of if less
C than 4 elements meet in JVT!

      IF ((NVELJ.EQ.3).AND.(IELTYP.EQ.11)) THEN
C Modify the matrix
        DO I=1,4
          WORK(3*NROWS + I) = 0D0
          WORK(I*NROWS + 4) = 0D0
        END DO
        WORK(3*NROWS + 4) = 1D0

C and the RHS-vectors = X/Y-derivative, which are saved
C behind the two matrix blocks:

        WORK (2*MTSIZE + 4)         = 0D0
        WORK (2*MTSIZE + NROWS + 4) = 0D0
      END IF

C Ok, the matrix is prepared, also the both RHS-vectors are prepared
C behind the two matrix blocks. What is the second matrix block
C good for?
C The problem is the case if more than 4 elements meet in JVT. In this
C case the matrix is not rectangular, i.e. we cannot simply solve
C it to get the coefficients of the polynomial.
C
C A way out of this is the Least-Squares approach:
C Instead of solving a system Ax=b, we solve the system A^TAx=A^Tb.
C This gives a "best approximating" solution X.
C The second matrix block serves as temporary array to compute A^TA.

      IF (NROWS.NE.NCOLS) THEN

C       Multiply both RHS by A^T. The last column of the second
C       matrix structure is used as temporary array.

        CALL LCP1 (WORK (2*MTSIZE+1),WORK (2*MTSIZE-NROWS+1),NROWS)
        CALL DGEMV ( 'T', NROWS, NCOLS, 1D0, WORK(1), NROWS,
     *               WORK (2*MTSIZE-NROWS+1), 1,
     *               0D0, WORK (2*MTSIZE+1), 1 )

        CALL LCP1 (WORK (2*MTSIZE+NROWS+1),WORK (2*MTSIZE-NROWS+1),
     *             NROWS)
        CALL DGEMV ( 'T', NROWS, NCOLS, 1D0, WORK(1), NROWS,
     *               WORK (2*MTSIZE-NROWS+1), 1,
     *               0D0, WORK (2*MTSIZE+NROWS+1), 1 )

C       Build A^TA: Copy the matrix to the 2nd matrix block,
C       multiply by A^T and save back to the first:

        CALL LCP1 (WORK(1),WORK(MTSIZE+1),MTSIZE)
        CALL DGEMM ( 'T', 'N', NCOLS, NCOLS, NROWS, 1D0,
     *               WORK(MTSIZE+1), NROWS, WORK(MTSIZE+1), NROWS,
     *               0D0, WORK(1), NCOLS )

      END IF

C So we now have a matrix at WORK(1) and two RHS-vectors after both
C matrix blocks.
C The next part is to solve two linear systems for the
C both RHS's to determine the coefficients of the polynomial.
C
C This we will do by LAPACK-routines. Use DGETRF at first to factorize
C our matrix in-place. DGETRF will write integers into our WORK-array,
C which is a double-precision array. But since integers are generally
C smaller in size, this will destroy nothing in WORK - there's enough
C space.

      CALL DGETRF ( NCOLS, NCOLS, WORK(1), NCOLS, WORK(MTSIZE+1), I )

      IF (I.NE.0) THEN
        PRINT *,'GRDLO2: Illegal matrix'
        STOP
      END IF

C And solve it two times:

      CALL DGETRS( 'N', NCOLS, 1, WORK(1), NCOLS, WORK(MTSIZE+1),
     *             WORK(2*MTSIZE+1), NCOLS, I )

      CALL DGETRS( 'N', NCOLS, 1, WORK(1), NCOLS, WORK(MTSIZE+1),
     *             WORK(2*MTSIZE+NROWS+1), NCOLS, I )

C That's it, we now have the two coefficient vectors in WORK(MTSIZE+1)
C and WORK(MTSIZE+NROWS+1).
C
C Use the calculated coefficients to compute the value of the
C polynomial in the point (X,Y). For this purpose calculate the
C local coordinates of the midpoint - which should be ~ 0, if
C IVT=JVT=(X,Y) is the center of a quadrilateral patch.

      XHAT = HSCALE*(DALPHA *(X - XCENTR) +
     *                 DBETA* (Y - YCENTR))
      YHAT = HSCALE*(-DBETA *(X - XCENTR) +
     *                 DALPHA*(Y - YCENTR))

C Remark that if IVT=JVT=(X,Y)=midpoint of the patch, XHAT=YHAT=0 and
C so the value is determined by DRECVX(1) / DRECVY(1)!
C
C We perform a loop over all monoms and add them together
C to the reconstructed gradient.

      DGRADX = 0D0
      DGRADY = 0D0

      K=1
      DO I=0,NMXDEG
        DO J=0,NMXDEG
          XX = WORK(2*MTSIZE+K)
          YY = WORK(2*MTSIZE+NROWS+K)

          DGRADX = DGRADX + XX * XHAT**DBLE(J) * YHAT**DBLE(I)
          DGRADY = DGRADY + YY * XHAT**DBLE(J) * YHAT**DBLE(I)

          K=K+1
        END DO
      END DO

      END

**************************************************************************
* Computation of reconstructed gradient with ZZ-technique,
* Extended calling convenction
*
* This routine calculates for a given solution vector DU based on an
* element ELE the reconstructed gradient DGRADX,DGRADY in each node
* of the grid.
*
* In:
*   TRIA    - array [1..SZTRIA] of integer
*             Triangulation structure of the mesh
*   DU      - array [1..NEQ] of double
*             Solution vector
*   NEQ     - Number of equations in DU
*   ELE     - Element that corresponds to solution vector DU.
*             Must be conformal (Q1,Q2,...) parametric element.
*
* Out:
*   DGRADX  - array [1..NEQ] of integer
*             X-Gradient of solution vector
*   DGRADY  - array [1..NEQ] of integer
*             Y-Gradient of solution vector
**************************************************************************

      SUBROUTINE XGRDR2(TRIA,DU,DGRADX,DGRADY,NEQ,ELE)

      IMPLICIT NONE

      INCLUDE 'cout.inc'
      INCLUDE 'cerr.inc'
      INCLUDE 'cmem.inc'

      INCLUDE 'cbasictria.inc'

      INCLUDE 'cbasicelem.inc'

      INCLUDE 'ccub.inc'

      INCLUDE 'stria.inc'

C parameters

      INTEGER NEQ,TRIA(SZTRIA)
      DOUBLE PRECISION DU(NEQ),DGRADX(NEQ),DGRADY(NEQ)
      EXTERNAL ELE

      INTEGER NDFL
      EXTERNAL NDFL

C local variables

      INTEGER KDFG(NNBAS),KDFL(NNBAS),IDFL,IELTYP
      INTEGER IVEL,I,J
      INTEGER IEL1,IEL2

      INTEGER KVERT,KMID,KXNPR,KVEL,KCOUNT,KMEL,KCORVG,LWORK,LNEED
      INTEGER IEL,IVT,JVT,NEL,NVE,NVT,IDG

      INTEGER LCOUNT,NVEL,KV1,KV2,KNP,IJ(1)
      DOUBLE PRECISION D,X,Y,DGX,DGY,DJ(1)

C We need an extended triangulation structure for this routine:

      IF (TRIA(OTRIFL).EQ.0) THEN
        WRITE (*,*) 'XGRDR2: No extended triangulation information!'
        RETURN
      END IF

C Clear the destination arrays at first:

      CALL LCL1 (DGRADX,NEQ)
      CALL LCL1 (DGRADY,NEQ)

C How do we have to perform the recovering of the gradient now?
C Basically we would have to perform a loop about all vertices
C 1..NVT and call GRDLO2 for them. The result is then written into
C DGRADX/DGRADY.
C
C This works fine if Q1 is used. Unfortunately higher order
C elements like Q2,Q3,... do not only use vertices, but also edge
C and element midpoints!
C
C What to do there? Well, taking the mean! In case of Q2 and an
C edge midpoint, there are two elements adjacent to it. Calculate
C the recovered gradient on both elements and take the mean:
C
C *------*------*
C |      |      |
C |   > IMT <   |
C |      |      |
C *------*------*
C
C An element midpoint is surrounded by 4 corner vertices. In this
C case there are 4 patches we have take into considerarion when taking
C the mean:
C
C *------*------*
C |      |      |
C |  X=======X  |
C |  I       I  |
C *--I   M   I--*
C |  I       I  |
C |  X=======X  |
C |      |      |
C *------*------*
C
C At first we have to reserve some memory for easier computation.
C For calculating the mean we need an array KCOUNT. This saves for
C every DOF how many times the recovered gradient has been calculated
C for that DOF. Afterwards it's used to take the mean.

      CALL ZNEW (NEQ,3,LCOUNT,'KCOUNT')

C Ask the recovery routine about how much memory is necessary:

      LNEED = -1
      CALL GRDLO2(TRIA,DJ,DJ(1),DJ(1),DJ,IJ,IJ,IJ,
     *            0D0,0D0,0,0,NNVE,TRIA(ONVEL),
     *            ELE, DJ, LNEED)

      CALL ZNEW (LNEED,-1,LWORK,'WORK  ')

C Transfer some adresses to local variables for easier access

      KCORVG = L(TRIA(OLCORVG))
      KVERT = L(TRIA(OLVERT))
      KMID  = L(TRIA(OLMID))
      KXNPR = L(TRIA(OLXNPR))
      KVEL  = L(TRIA(OLVEL))
      KMEL  = L(TRIA(OLMEL))
      NVEL = TRIA(ONVEL)
      NVE  = TRIA(ONVE)
      NVT = TRIA(ONVT)
      NEL = TRIA(ONEL)

      KCOUNT = L(LCOUNT)

C Ask the element about its type:

      IELTYP = -1
      CALL ELE (0D0,0D0,IELTYP)

C Calculate local number of degrees of freedom of our element type

      IDFL = NDFL(IELTYP)

C Now perform a loop over all elements:

      DO IEL = 1,NEL

C       On the current element calculate the global DOF's into KDFG:

        CALL NDFGLX(TRIA,IEL,1,IELTYP,KWORK(KVERT),KWORK(KMID),
     *              KDFG,KDFL)

C       Loop over the local DOF's to calculate the recovered gradient
C       there:

        DO IDG = 1,IDFL

C         What's the global DOF to I ?

          IVT = KDFG(IDG)

C         If IVT is a corner vertex that has already been tackled,
C         we don't have to do anything. It's enough to calculate
C         that value once :)

          IF ((IVT.LE.NVT).AND.(KWORK(KCOUNT+IVT-1).EQ.0)) THEN

C           Remember the node as being tackled and determine the
C           coordinates of the vertex.

            KWORK(KCOUNT+IVT-1) = KWORK(KCOUNT+IVT-1) + 1
            CALL NDE2XY (IVT,TRIA,X,Y)

C           IVT must be any corner point of the element. So if IVT is
C           not an inner node...

            IF (IVT.GT.NVT) THEN

C             ...take an arbitrary corner instead of IVT, but don't change
C             the (X,Y)-coordinates! : IVT=KVERT(1,IEL)

              IVT = KWORK(KVERT+(IEL-1)*NNVE+1)

            END IF

C           IVT now points to a corner vertex of the current element.
C           Next we have to search for a (is possible: neighbour-) node
C           of IVT which is indide of the domain.
C
C           Count the number of elements surrounding the current vertex:

            DO IVEL = 1, NVEL
              IF(KWORK(KVEL+(IVT-1)*NVEL + IVEL-1).EQ.0) GOTO 10
            ENDDO
10          CONTINUE
            IVEL = IVEL-1

C           If there are at least 3 elements surrounding our vertex IVT,
C           that's enough to recover the gradient:

            IF (IVEL.GE.3) THEN
              JVT = IVT
              CALL GRDLO2(TRIA,DU,DGX,DGY,
     *                  DWORK(KCORVG),KWORK(KVERT),KWORK(KMID),
     *                  KWORK(KVEL),X,Y,IVT,JVT,
     *                  IVEL,TRIA(ONVEL),ELE,
     *                  DWORK(L(LWORK)), LWORK)
            ELSE

C             Ok, too less elements, not so easy. Let's check if there
C             are at least two elements adjacent to our vertex IVT:

              IEL1 = KWORK(KVEL+(IVT-1)*NVEL)
              IEL2 = KWORK(KVEL+(IVT-1)*NVEL+1)

              IF (IEL2.NE.0) THEN

C               We have two elements. Try to find a neighbour of IVT which
C               is an inner node. Use the KXNPR-array to decide about
C               inner nodes:

                DO I = 1,NVE
                  DO J = 1,NVE
                    KV1 = KWORK(KVERT+(IEL1-1)*NNVE+I-1)
                    KV2 = KWORK(KVERT+(IEL2-1)*NNVE+J-1)
                    KNP = KWORK(KXNPR+2*(KV1-1))
                    IF ((KV1.EQ.KV2).AND.(IAND(KNP,2**8).EQ.0)) THEN
C                     We now know: Vertex KV1 is an inner vertex! (Has been
C                     calculated in the loop above). Take this as the new
C                     patch center JVT:
                      JVT = KV1
                      GOTO 20
                    END IF
                  END DO
                END DO

C               Oops, no inner node available! This can only happen on
C               rather coarse grids like the QUAD mesh - but it can
C               happen. We have no chance, we have to go back to the
C               original evaluation routines to get a value vor the
C               gradient :(
C
C               Indicate this by setting JVT=0

                JVT = 0

20              CONTINUE

C               ...and continue with the calculation below.

              ELSE

C               Hmmm, only one element on current node IVT. Loop
C               through all corners to find a vertex that has at least
C               three adjacent elements

                DO I=1,TRIA(ONVE)
                  JVT = KWORK(KVERT+NNVE*(IEL-1)+I-1)
                  IF (KWORK(KVEL+NVEL*(JVT-1)+2).NE.0) THEN
C                   Node JVT is usable as new center.
                    GOTO 30
                  END IF
                END DO

C               Also here: no neighbour vertex with >= 2 elements
C               found. Switch back to standard reconstruction:

                JVT = 0

30              CONTINUE

              END IF

C             Is a node JVT found that we can use as a center of our
C             patch?

              IF (JVT.EQ.0) THEN

C               Unfortunately not. Then we have to fall back to standard
C               evaluation...

                CALL SCEVLQ (NEQ,DU,ELE,.FALSE.,X,Y,IEL,
     *                       TRIA,DWORK(KCORVG),KWORK(KVERT),
     *                       KWORK(KMID),D, DGX, DGY)

              ELSE

C               Nice, we can continue :)
C               Calculate the number of elements surrounding our
C               node JVT:

                DO IVEL = 1, NVEL
                  IF(KWORK(KVEL+(JVT-1)*NVEL + IVEL-1).EQ.0) GOTO 40
                ENDDO
40              CONTINUE
                IVEL = IVEL-1

C               And finally call the recovery routine to calculate
C               the gradient, using JVT as center...

                CALL GRDLO2(TRIA,DU,DGX,DGY,
     *                  DWORK(KCORVG),KWORK(KVERT),KWORK(KMID),
     *                  KWORK(KVEL),X,Y,IVT,JVT,
     *                  IVEL,TRIA(ONVEL),ELE,
     *                  DWORK(L(LWORK)), LWORK)

              END IF

            END IF

C           We now have any kind of gradient in DGX/DGY - either
C           calculated by ZZ or (in special cases) by direct
C           evaluation. Add this to the value in the DGRADX/DGRADY
C           vector. Take into consideration that our current node
C           is actually KDFG(IDFG), not IVT!
C           IVT might have been changed to a corner if KDFG(IDFG)
C           points to an inner/edge vertex/node.

            DGRADX (KDFG(IDG)) = DGRADX (KDFG(IDG)) + DGX
            DGRADY (KDFG(IDG)) = DGRADY (KDFG(IDG)) + DGY

          END IF

        END DO

      END DO

C Ok, everything calculated. Now we have to divide the calculated
C numbers by number of how often we tackled each node. This is of
C course only necessary for nodes corresponding to non-corner
C vertices, as corner vertices are only tackled once.

      DO I=NVT+1,NEQ
        D = 1D0/DBLE(KWORK(KCOUNT+I-1))
        DGRADX (I) = DGRADX (I) * D
        DGRADY (I) = DGRADY (I) * D
      END DO

C Release memory, that's it.

      CALL ZDISP (0,LCOUNT,'LCOUNT')
      CALL ZDISP (0,LWORK,'WORK  ')

      END

**************************************************************************
* Computation of reconstructed gradient with Standard-technique,
* Extended calling convenction
*
* This routine calculates for a given solution vector DU based on an
* element ELE the reconstructed gradient DGRADX,DGRADY in each node
* of the grid.
* The standard 1st-order method is used for reconstructing the
* gradient.
*
* In:
*   TRIA    - array [1..SZTRIA] of integer
*             Triangulation structure of the mesh
*   DU      - array [1..NEQ] of double
*             Solution vector
*   NEQ     - Number of equations in DU
*   ELE     - Element that corresponds to solution vector DU.
*   BNONPR  - =true:  ELE is a nonparametric element
*             =false: ELE is a parametric element
*
* Out:
*   DGRADX  - array [1..NEQ] of integer
*             X-Gradient of solution vector
*   DGRADY  - array [1..NEQ] of integer
*             Y-Gradient of solution vector
**************************************************************************

      SUBROUTINE XGRDR3(TRIA,DU,DGRADX,DGRADY,NEQ,ELE,BNONPR)

      IMPLICIT NONE

      INCLUDE 'cout.inc'
      INCLUDE 'cerr.inc'
      INCLUDE 'cmem.inc'

      INCLUDE 'cbasictria.inc'

      INCLUDE 'cbasicelem.inc'

      INCLUDE 'ccub.inc'

      INCLUDE 'stria.inc'

C parameters

      INTEGER NEQ,TRIA(SZTRIA)
      LOGICAL BNONPR
      DOUBLE PRECISION DU(NEQ),DGRADX(NEQ),DGRADY(NEQ)
      EXTERNAL ELE

      INTEGER NDFL
      EXTERNAL NDFL

C local variables

      INTEGER KDFG(NNBAS),KDFL(NNBAS),IDFL,IELTYP
      INTEGER I

      INTEGER KVERT,KMID,KCOUNT,KCORVG
      INTEGER IEL,IVT,NEL,NVT,IDG

      INTEGER LCOUNT
      DOUBLE PRECISION D,X,Y,DGX,DGY

C We need an extended triangulation structure for this routine:

      IF (TRIA(OTRIFL).EQ.0) THEN
        WRITE (*,*) 'XGRDR3: No extended triangulation information!'
        RETURN
      END IF

C Clear the destination arrays at first:

      CALL LCL1 (DGRADX,NEQ)
      CALL LCL1 (DGRADY,NEQ)

C How do we have to perform the recovering of the gradient now?
C Well, the standard implementation of calculating the gradient
C uses the derivative-calculation methods of the element itself,
C adds  everything together and takes the mean about how many
C times each point is tackled.
C
C For calculating the mean we need an array KCOUNT. This saves for
C every DOF how many times the recovered gradient has been calculated
C for that DOF. Afterwards it's used to take the mean.

      CALL ZNEW (NEQ,3,LCOUNT,'KCOUNT')

C Transfer some adresses to local variables for easier access

      KCORVG = L(TRIA(OLCORVG))
      KVERT = L(TRIA(OLVERT))
      KMID  = L(TRIA(OLMID))
      NVT = TRIA(ONVT)
      NEL = TRIA(ONEL)

      KCOUNT = L(LCOUNT)

C Ask the element about its type:

      IELTYP = -1
      CALL ELE (0D0,0D0,IELTYP)

C Calculate local number of degrees of freedom of our element type

      IDFL = NDFL(IELTYP)

C Now perform a loop over all elements:

      DO IEL = 1,NEL

C       On the current element calculate the global DOF's into KDFG:

        CALL NDFGLX(TRIA,IEL,1,IELTYP,KWORK(KVERT),KWORK(KMID),
     *              KDFG,KDFL)

C       Loop over the local DOF's to calculate the recovered gradient
C       there:

        DO IDG = 1,IDFL

C         What's the global DOF to IDG ?

          IVT = KDFG(IDG)

C         Remember the node as being tackled and determine the
C         coordinates of the vertex.

          KWORK(KCOUNT+IVT-1) = KWORK(KCOUNT+IVT-1) + 1
          CALL NDE2XY (IVT,TRIA,X,Y)

C         Use the standard evaluation routine to calculate an
C         approximate gradient in the point (X,Y). The X-derivative
C         will be saved to DGX, the Y-derivative to DGY. The value
C         of the FE-function in this point, which is saved to D,
C         will be ignored in the following.

          CALL SCEVLQ (NEQ,DU,ELE,BNONPR,X,Y,IEL,
     *                 TRIA,DWORK(KCORVG),KWORK(KVERT),KWORK(KMID),
     *                 D, DGX, DGY)

C         Add the gradient values to the value in the DGRADX/DGRADY
C         vector.

          DGRADX (IVT) = DGRADX (IVT) + DGX
          DGRADY (IVT) = DGRADY (IVT) + DGY

        END DO

      END DO

C Ok, everything calculated. Now we have to divide the calculated
C numbers by number of how often we tackled each node.
C In contrast to the ZZ-technique this is necessary for inner
C nodes as well as boundary nodes.

      DO I=1,NEQ
        D = 1D0/DBLE(KWORK(KCOUNT+I-1))
        DGRADX (I) = DGRADX (I) * D
        DGRADY (I) = DGRADY (I) * D
      END DO

C Release memory, that's it.

      CALL ZDISP (0,LCOUNT,'LCOUNT')

      END


!====================================================================
!
! MODULE: LeastSquareProblem
!
!   SUBROUTINE: Add_LsmSample()
!   SUBROUTINE: Solve_Lsm()
!
!
! Created by Y.Tahara in Aug,02
!
!====================================================================

module LeastSquareProblem

  !--- modules

  use type_kinds, only : fp_kind
  use ParametersGenCoef

  !--- implicit

  implicit none

  !--- private & public

  private
  public Add_LsmSample
  public Solve_Lsm

  !--- module valiables in private

  integer                  ,save :: Nelem_lsm
  integer                  ,save :: Nsample_lsm
  real(fp_kind),allocatable,save :: y(:)     ! Predictand vector
  real(fp_kind),allocatable,save :: x(:,:)   ! Predictors matrix

 contains

  !====================================================================
  !
  ! SUBROUTINE: Alloc_LsmHeap()
  ! SUBROUTINE: Dealloc_LsmHeap()
  !
  !
  !
  !
  !
  !====================================================================

  subroutine Alloc_LsmHeap( Nelem_in, Nsample_max )

    integer,intent(in) :: Nelem_in
    integer,intent(in) :: Nsample_max

    Nelem_lsm   = Nelem_in
    Nsample_lsm = 0

    allocate( y(          Nsample_max) )
    allocate( x(Nelem_lsm,Nsample_max) )

  end subroutine Alloc_LsmHeap

  subroutine Dealloc_LsmHeap()

    deallocate( y )
    deallocate( x )

  end subroutine Dealloc_LsmHeap

  !====================================================================
  !
  ! SUBROUTINE: Add_LsmSample()
  !
  !   Add_LsmSample() adds a set of a predictand and predictors to
  !   module variables, which will be used in Solve_Lsm() to
  !   generate regression coefficients.
  !
  !====================================================================

  subroutine Add_LsmSample( yy, xx )

    !--- interface

    real(fp_kind),intent(in)    :: yy              ! a predictand
    real(fp_kind),intent(in)    :: xx(Nelem_lsm)   ! predictors

    !--- add a set to module variables

    Nsample_lsm = Nsample_lsm + 1

    y(            Nsample_lsm) = yy
    x(1:Nelem_lsm,Nsample_lsm) = xx(1:Nelem_lsm)

  end subroutine Add_LsmSample

  !====================================================================
  !
  ! SUBROUTINE: Solve_Lsm()
  !
  !   Solve_Lsm() calculates regression coefficients by solving
  !   a least square problem.
  !   Sets of predictand and predictor must have been stored in
  !   module variables by calling Add_LsmSample().
  !   Mathmatical library is used for the calculation.
  !
  !====================================================================

  subroutine Solve_Lsm( c, rn, Nda )

    !--- interface

    real(fp_kind),intent(out) :: c(Nel)   ! coefficients
    real(fp_kind),intent(out) :: rn       ! residual of LSM
    integer      ,intent(out) :: Nda      ! total # of sets in module variables

    !--- local variables

    real(fp_kind),parameter   :: tau = ZERO

    real(fp_kind),allocatable :: x1(:,:)
    real(fp_kind)             :: aux
    integer                   :: k

    !--- allocate

    allocate( x1(Nsample_lsm,Nelem_lsm) )

    !--- transpose the predictor matrix

    call DGETMO( x(1,1), Nelem_lsm, Nelem_lsm, Nsample_lsm, x1(1,1), Nsampel_lsm )

    !--- generate regression coefficients

    CALL DGELLS( 1, x1, Nsample_lsm, y, Nsample_lsm, c, Nelem_lsm, rn, tau, Nsample_lsm, Nelem_lsm, 1, k, aux, 0 )

    !--- deallocate

    deallocate( x1 )

  end subroutine Solve_Lsm

end module LeastSquareProblem


*DECK DWNNLS
      SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE,
     +   IWORK, WORK)
C***BEGIN PROLOGUE  DWNNLS
C***PURPOSE  Solve a linearly constrained least squares problem with
C            equality constraints and nonnegativity constraints on
C            selected variables.
C***LIBRARY   SLATEC
C***CATEGORY  K1A2A
C***TYPE      DOUBLE PRECISION (WNNLS-S, DWNNLS-D)
C***KEYWORDS  CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING,
C             EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS,
C             NONNEGATIVITY CONSTRAINTS, QUADRATIC PROGRAMMING
C***AUTHOR  Hanson, R. J., (SNLA)
C           Haskell, K. H., (SNLA)
C***DESCRIPTION
C
C     Abstract
C
C     This subprogram solves a linearly constrained least squares
C     problem.  Suppose there are given matrices E and A of
C     respective dimensions ME by N and MA by N, and vectors F
C     and B of respective lengths ME and MA.  This subroutine
C     solves the problem
C
C               EX = F, (equations to be exactly satisfied)
C
C               AX = B, (equations to be approximately satisfied,
C                        in the least squares sense)
C
C               subject to components L+1,...,N nonnegative
C
C     Any values ME.GE.0, MA.GE.0 and 0.LE. L .LE.N are permitted.
C
C     The problem is reposed as problem DWNNLS
C
C               (WT*E)X = (WT*F)
C               (   A)    (   B), (least squares)
C               subject to components L+1,...,N nonnegative.
C
C     The subprogram chooses the heavy weight (or penalty parameter) WT.
C
C     The parameters for DWNNLS are
C
C     INPUT.. All TYPE REAL variables are DOUBLE PRECISION
C
C     W(*,*),MDW,  The array W(*,*) is double subscripted with first
C     ME,MA,N,L    dimensioning parameter equal to MDW.  For this
C                  discussion let us call M = ME + MA.  Then MDW
C                  must satisfy MDW.GE.M.  The condition MDW.LT.M
C                  is an error.
C
C                  The array W(*,*) contains the matrices and vectors
C
C                       (E  F)
C                       (A  B)
C
C                  in rows and columns 1,...,M and 1,...,N+1
C                  respectively.  Columns 1,...,L correspond to
C                  unconstrained variables X(1),...,X(L).  The
C                  remaining variables are constrained to be
C                  nonnegative. The condition L.LT.0 or L.GT.N is
C                  an error.
C
C     PRGOPT(*)    This double precision array is the option vector.
C                  If the user is satisfied with the nominal
C                  subprogram features set
C
C                  PRGOPT(1)=1 (or PRGOPT(1)=1.0)
C
C                  Otherwise PRGOPT(*) is a linked list consisting of
C                  groups of data of the following form
C
C                  LINK
C                  KEY
C                  DATA SET
C
C                  The parameters LINK and KEY are each one word.
C                  The DATA SET can be comprised of several words.
C                  The number of items depends on the value of KEY.
C                  The value of LINK points to the first
C                  entry of the next group of data within
C                  PRGOPT(*).  The exception is when there are
C                  no more options to change.  In that
C                  case LINK=1 and the values KEY and DATA SET
C                  are not referenced. The general layout of
C                  PRGOPT(*) is as follows.
C
C               ...PRGOPT(1)=LINK1 (link to first entry of next group)
C               .  PRGOPT(2)=KEY1 (key to the option change)
C               .  PRGOPT(3)=DATA VALUE (data value for this change)
C               .       .
C               .       .
C               .       .
C               ...PRGOPT(LINK1)=LINK2 (link to the first entry of
C               .                       next group)
C               .  PRGOPT(LINK1+1)=KEY2 (key to the option change)
C               .  PRGOPT(LINK1+2)=DATA VALUE
C               ...     .
C               .       .
C               .       .
C               ...PRGOPT(LINK)=1 (no more options to change)
C
C                  Values of LINK that are nonpositive are errors.
C                  A value of LINK.GT.NLINK=100000 is also an error.
C                  This helps prevent using invalid but positive
C                  values of LINK that will probably extend
C                  beyond the program limits of PRGOPT(*).
C                  Unrecognized values of KEY are ignored.  The
C                  order of the options is arbitrary and any number
C                  of options can be changed with the following
C                  restriction.  To prevent cycling in the
C                  processing of the option array a count of the
C                  number of options changed is maintained.
C                  Whenever this count exceeds NOPT=1000 an error
C                  message is printed and the subprogram returns.
C
C                  OPTIONS..
C
C                  KEY=6
C                         Scale the nonzero columns of the
C                  entire data matrix
C                  (E)
C                  (A)
C                  to have length one. The DATA SET for
C                  this option is a single value.  It must
C                  be nonzero if unit length column scaling is
C                  desired.
C
C                  KEY=7
C                         Scale columns of the entire data matrix
C                  (E)
C                  (A)
C                  with a user-provided diagonal matrix.
C                  The DATA SET for this option consists
C                  of the N diagonal scaling factors, one for
C                  each matrix column.
C
C                  KEY=8
C                         Change the rank determination tolerance from
C                  the nominal value of SQRT(SRELPR).  This quantity
C                  can be no smaller than SRELPR, The arithmetic-
C                  storage precision.  The quantity used
C                  here is internally restricted to be at
C                  least SRELPR.  The DATA SET for this option
C                  is the new tolerance.
C
C                  KEY=9
C                         Change the blow-up parameter from the
C                  nominal value of SQRT(SRELPR).  The reciprocal of
C                  this parameter is used in rejecting solution
C                  components as too large when a variable is
C                  first brought into the active set.  Too large
C                  means that the proposed component times the
C                  reciprocal of the parameter is not less than
C                  the ratio of the norms of the right-side
C                  vector and the data matrix.
C                  This parameter can be no smaller than SRELPR,
C                  the arithmetic-storage precision.
C
C                  For example, suppose we want to provide
C                  a diagonal matrix to scale the problem
C                  matrix and change the tolerance used for
C                  determining linear dependence of dropped col
C                  vectors.  For these options the dimensions of
C                  PRGOPT(*) must be at least N+6.  The FORTRAN
C                  statements defining these options would
C                  be as follows.
C
C                  PRGOPT(1)=N+3 (link to entry N+3 in PRGOPT(*))
C                  PRGOPT(2)=7 (user-provided scaling key)
C
C                  CALL DCOPY(N,D,1,PRGOPT(3),1) (copy the N
C                  scaling factors from a user array called D(*)
C                  into PRGOPT(3)-PRGOPT(N+2))
C
C                  PRGOPT(N+3)=N+6 (link to entry N+6 of PRGOPT(*))
C                  PRGOPT(N+4)=8 (linear dependence tolerance key)
C                  PRGOPT(N+5)=... (new value of the tolerance)
C
C                  PRGOPT(N+6)=1 (no more options to change)
C
C
C     IWORK(1),    The amounts of working storage actually allocated
C     IWORK(2)     for the working arrays WORK(*) and IWORK(*),
C                  respectively.  These quantities are compared with
C                  the actual amounts of storage needed for DWNNLS( ).
C                  Insufficient storage allocated for either WORK(*)
C                  or IWORK(*) is considered an error.  This feature
C                  was included in DWNNLS( ) because miscalculating
C                  the storage formulas for WORK(*) and IWORK(*)
C                  might very well lead to subtle and hard-to-find
C                  execution errors.
C
C                  The length of WORK(*) must be at least
C
C                  LW = ME+MA+5*N
C                  This test will not be made if IWORK(1).LE.0.
C
C                  The length of IWORK(*) must be at least
C
C                  LIW = ME+MA+N
C                  This test will not be made if IWORK(2).LE.0.
C
C     OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION
C
C     X(*)         An array dimensioned at least N, which will
C                  contain the N components of the solution vector
C                  on output.
C
C     RNORM        The residual norm of the solution.  The value of
C                  RNORM contains the residual vector length of the
C                  equality constraints and least squares equations.
C
C     MODE         The value of MODE indicates the success or failure
C                  of the subprogram.
C
C                  MODE = 0  Subprogram completed successfully.
C
C                       = 1  Max. number of iterations (equal to
C                            3*(N-L)) exceeded. Nearly all problems
C                            should complete in fewer than this
C                            number of iterations. An approximate
C                            solution and its corresponding residual
C                            vector length are in X(*) and RNORM.
C
C                       = 2  Usage error occurred.  The offending
C                            condition is noted with the error
C                            processing subprogram, XERMSG( ).
C
C     User-designated
C     Working arrays..
C
C     WORK(*)      A double precision working array of length at least
C                  M + 5*N.
C
C     IWORK(*)     An integer-valued working array of length at least
C                  M+N.
C
C***REFERENCES  K. H. Haskell and R. J. Hanson, An algorithm for
C                 linear least squares problems with equality and
C                 nonnegativity constraints, Report SAND77-0552, Sandia
C                 Laboratories, June 1978.
C               K. H. Haskell and R. J. Hanson, Selected algorithms for
C                 the linearly constrained least squares problem - a
C                 users guide, Report SAND78-1290, Sandia Laboratories,
C                 August 1979.
C               K. H. Haskell and R. J. Hanson, An algorithm for
C                 linear least squares problems with equality and
C                 nonnegativity constraints, Mathematical Programming
C                 21 (1981), pp. 98-118.
C               R. J. Hanson and K. H. Haskell, Two algorithms for the
C                 linearly constrained least squares problem, ACM
C                 Transactions on Mathematical Software, September 1982.
C               C. L. Lawson and R. J. Hanson, Solving Least Squares
C                 Problems, Prentice-Hall, Inc., 1974.
C***ROUTINES CALLED  DWNLSM, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890618  Completely restructured and revised.  (WRB & RWC)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900510  Convert XERRWV calls to XERMSG calls, change Prologue
C           comments to agree with WNNLS.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DWNNLS
      INTEGER IWORK(*), L, L1, L2, L3, L4, L5, LIW, LW, MA, MDW, ME,
     *     MODE, N
      DOUBLE PRECISION  PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*)
      CHARACTER*8 XERN1
C***FIRST EXECUTABLE STATEMENT  DWNNLS
      MODE = 0
      IF (MA+ME.LE.0 .OR. N.LE.0) RETURN
C
      IF (IWORK(1).GT.0) THEN
         LW = ME + MA + 5*N
         IF (IWORK(1).LT.LW) THEN
            WRITE (XERN1, '(I8)') LW
            CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' //
     *         'ALLOCATED FOR WORK(*), NEED LW = ' // XERN1, 2, 1)
            MODE = 2
            RETURN
         ENDIF
      ENDIF
C
      IF (IWORK(2).GT.0) THEN
         LIW = ME + MA + N
         IF (IWORK(2).LT.LIW) THEN
            WRITE (XERN1, '(I8)') LIW
            CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' //
     *         'ALLOCATED FOR IWORK(*), NEED LIW = ' // XERN1, 2, 1)
            MODE = 2
            RETURN
         ENDIF
      ENDIF
C
      IF (MDW.LT.ME+MA) THEN
         CALL XERMSG ('SLATEC', 'DWNNLS',
     *      'THE VALUE MDW.LT.ME+MA IS AN ERROR', 1, 1)
         MODE = 2
         RETURN
      ENDIF
C
      IF (L.LT.0 .OR. L.GT.N) THEN
         CALL XERMSG ('SLATEC', 'DWNNLS',
     *      'L.GE.0 .AND. L.LE.N IS REQUIRED', 2, 1)
         MODE = 2
         RETURN
      ENDIF
C
C     THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS
C     WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS
C     REQUIRED BY THE MAIN SUBROUTINE DWNLSM( ).
C
      L1 = N + 1
      L2 = L1 + N
      L3 = L2 + ME + MA
      L4 = L3 + N
      L5 = L4 + N
C
      CALL DWNLSM(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, IWORK,
     *            IWORK(L1), WORK(1), WORK(L1), WORK(L2), WORK(L3),
     *            WORK(L4), WORK(L5))
      RETURN
      END


module schroed2d_assembly
use types, only: dp
use sorting, only: sort
implicit none
private
public assemble_2d, Z, exact_energies

real(dp), parameter :: Z = 1._dp

contains

real(dp) elemental function f(x, y)
real(dp), intent(in) :: x, y
real(dp) :: h
h = 0.0
f = -Z/sqrt(x**2 + y**2 + h**2)
end function

subroutine assemble_2d(xin, nodes, elems, ib, xiq, wtq, phihq, dphihq, Am, Bm)
! Assemble on a 2D rectangular uniform mesh
real(dp), intent(in):: xin(:), nodes(:, :), xiq(:), wtq(:, :), &
    phihq(:, :), dphihq(:, :)
integer, intent(in):: elems(:, :), ib(:, :, :)
real(dp), intent(out):: Am(:,:), Bm(:, :)
real(dp), dimension(size(xiq), size(xiq), &
    size(xin), size(xin)) :: phi_v, phi_dx, phi_dy
real(dp), dimension(size(xiq), size(xiq)) :: fq
real(dp), dimension(size(xiq)) :: x, y, xp, yp
integer :: Ne, p, e, i, j, iqx, iqy
real(dp) :: lx, ly
integer :: ax, ay, bx, by
real(dp) :: jacx, jacy, jac_det

Ne = size(elems, 2)
p = size(xin) - 1
! 2D shape functions
do ay = 1, p+1
do ax = 1, p+1
    do iqy = 1, size(xiq)
    do iqx = 1, size(xiq)
        phi_v (iqx, iqy, ax, ay) =  phihq(iqx, ax) *  phihq(iqy, ay)
        phi_dx(iqx, iqy, ax, ay) = dphihq(iqx, ax) *  phihq(iqy, ay)
        phi_dy(iqx, iqy, ax, ay) =  phihq(iqx, ax) * dphihq(iqy, ay)
    end do
    end do
end do
end do
Am=0; Bm=0
! Precalculate as much as possible:
lx = nodes(1, elems(3, 1)) - nodes(1, elems(1, 1)) ! Element sizes
ly = nodes(2, elems(3, 1)) - nodes(2, elems(1, 1))
jacx = lx/2
jacy = ly/2
jac_det = abs(jacx*jacy)
xp = (xiq + 1) * jacx
yp = (xiq + 1) * jacy
phi_dx = phi_dx / jacx
phi_dy = phi_dy / jacy
do e = 1, Ne
    x = xp + nodes(1, elems(1, e))
    y = yp + nodes(2, elems(1, e))
    do iqy = 1, size(xiq)
    do iqx = 1, size(xiq)
        fq(iqx, iqy) = f(x(iqx), y(iqy))
    end do
    end do
    do by = 1, p+1
    do bx = 1, p+1
        j = ib(bx, by, e)
        if (j==0) cycle
        do ay = 1, p+1
        do ax = 1, p+1
            i = ib(ax, ay, e)
            if (i == 0) cycle
            if (j > i) cycle
            Am(i,j) = Am(i,j) + sum(( &
                phi_dx(:, :, ax, ay)*phi_dx(:, :, bx, by) + &
                phi_dy(:, :, ax, ay)*phi_dy(:, :, bx, by)) &
                * jac_det * wtq) / 2
            Am(i,j) = Am(i,j) + sum(fq * &
                phi_v(:, :, ax, ay)*phi_v(:, :, bx, by) &
                * jac_det * wtq)
            Bm(i,j) = Bm(i,j) + sum(( &
                phi_v(:, :, ax, ay) * phi_v(:, :, bx, by) &
                * jac_det * wtq))
        end do
        end do
    end do
    end do
end do
do j = 1, size(Am, 2)
    do i = 1, j-1
        Am(i, j) = Am(j, i)
        Bm(i, j) = Bm(j, i)
    end do
end do
end subroutine

integer pure function calc_size(nmax) result(s)
integer, intent(in) :: nmax
integer :: n, m
s = 0
do n = 1, nmax
    do m = -n+1, n-1
        s = s + 1
    end do
end do
end function

subroutine exact_energies(Z, E)
real(dp), intent(in) :: Z
real(dp), intent(out) :: E(:)
real(dp) :: tmp(calc_size(size(E)))
integer :: n, m, idx
idx = 0
do n = 1, size(E)
    do m = -n+1, n-1
        idx = idx + 1
        tmp(idx) = -Z**2 / (2*(n-1._dp/2)**2)
    end do
end do
E = tmp(:size(E))
end subroutine

end module

!------------------------------------------------------------------------------

program schroed2d

use types, only: dp
use fe_mesh, only: cartesian_mesh_2d, define_connect_tensor_2d
use schroed2d_assembly, only: assemble_2d, Z, exact_energies
use feutils, only: get_parent_nodes, get_parent_quad_pts_wts, phih, dphih
use linalg, only: eigh
implicit none

integer :: Nn, Ne
! nodes(:, i) are the (x,y) coordinates of the i-th mesh node
real(dp), allocatable :: nodes(:, :)
integer, allocatable :: elems(:, :) ! elems(:, i) are nodes of the i-th element
integer :: Nq, p, Nb
real(dp), allocatable :: xin(:), xiq(:), wtq(:), A(:, :), B(:, :), c(:, :), &
    lam(:), wtq2(:, :), phihq(:, :), dphihq(:, :), E_exact(:)
integer, allocatable :: ib(:, :, :), in(:, :, :)
real(dp) :: rmax
integer :: i, j, Nex, Ney

Nex = 2
Ney = 2
p = 20
Nq = p+1
rmax = 15  ! The size of the box in atomic units

call cartesian_mesh_2d(Nex, Ney, [-rmax, -rmax], [rmax, rmax], nodes, elems)
Nn = size(nodes, 2)
Ne = size(elems, 2)

print *, "Number of nodes:", Nn
print *, "Number of elements:", Ne

allocate(xin(p+1))
call get_parent_nodes(2, p, xin)
allocate(xiq(Nq), wtq(Nq), wtq2(Nq, Nq))
call get_parent_quad_pts_wts(1, Nq, xiq, wtq)
forall(i=1:Nq, j=1:Nq) wtq2(i, j) = wtq(i)*wtq(j)
allocate(phihq(size(xiq), size(xin)))
allocate(dphihq(size(xiq), size(xin)))
! Tabulate parent basis at quadrature points
forall(i=1:size(xiq), j=1:size(xin))  phihq(i, j) =  phih(xin, j, xiq(i))
forall(i=1:size(xiq), j=1:size(xin)) dphihq(i, j) = dphih(xin, j, xiq(i))

call define_connect_tensor_2d(Nex, Ney, p, 1, in)
call define_connect_tensor_2d(Nex, Ney, p, 2, ib)
Nb = maxval(ib)
print *, "p =", p
print *, "DOFs =", Nb
allocate(A(Nb, Nb), B(Nb, Nb), c(Nb, Nb), lam(Nb))

print *, "Assembling..."
call assemble_2d(xin, nodes, elems, ib, xiq, wtq2, phihq, dphihq, A, B)
print *, "Solving..."
call eigh(A, B, lam, c)
print *, "Eigenvalues:"
allocate(E_exact(20))
call exact_energies(Z, E_exact)
do i = 1, min(Nb, 20)
    print "(i4, f12.6, f12.6, es12.2)", i, lam(i), E_exact(i), rel(lam(i), E_exact(i))
end do

contains

real(dp) pure function rel(a, b)
real(dp), intent(in) :: a, b
rel = abs(a-b) / max(abs(a), abs(b))
end function

end program


C This program computes the integral of a known function with known
C ranges and compares them against analytically derived answers. If the
C program determines that the computed value is not what you expected, then
C it will print out FAILURE, otherwise it will print out SUCCESS
C Written by psilord 08/08/2000

      PROGRAM AREAUC

      DOUBLE PRECISION XL(4), XR(4), IVL, AREA(4), RES(4)
      INTEGER I
      INTEGER SUCC
C Don't increase C above 4 because it converges faster than bits of precision
C in the real representation. You'll just end up introducing error into the
C system and getting bad numbers out. Also, IVL MUST be even for this adapted
C algorithm to work.
      PARAMETER (IVL = 4)

C Assume the tests are going to succeed
      SUCC = 1

C A simple test set
      XL(1) = 0.0
      XR(1) = 1.0
      XL(2) = -1.0
      XR(2) = 0.0
      XL(3) = -1.0
      XR(3) = 1.0
      XL(4) = -1.0
      XR(4) = 7.0

C These are the results I should expect.
      RES(1) = 0.25000
      RES(2) = -0.2500
      RES(3) = 0.00000
      RES(4) = 600.00000

C Compute the tests for the ranges specified
       DO 42 I = 1, 4
          AREA(I) = SIMPSN(XL(I), XR(I), IVL)
C          PRINT '(A, F9.5, A, F9.5)', 'AREA UNDER CURVE IS ', AREA(I),
C     +       ' EXPECTED: ', RES(I)
       CALL CKPT_AND_EXIT
   42  CONTINUE

C Compare the tests to see if all is ok
       DO 43 I = 1, 4
          IF (AREA(I) .NE. RES(I)) THEN
             SUCC = 0
          END IF
   43  CONTINUE

C Print out the results
       IF (SUCC .EQ. 1) THEN
          PRINT '(A)', 'SUCCESS'
       ELSE
          PRINT '(A)', 'FAILURE'
       END IF

       STOP
       END

C ----------------------------------------------------------------------

       REAL FUNCTION SIMPSN(A, B, N)
C Computes the area under x^3 from between A and B using Simpson's
C rule for N intervals
C Precondition: A must be less than B and N is defined
C Postcondition: returns the area under F(X) from X = A to X = B
C Adapted from Friedmann's fortran book page 641

C Input Arguments
C	A, B - the endpoints of the integration region
C	N - the number of intervals

C Argument Declarations
       DOUBLE PRECISION A, B, N

C Local Declarations
       DOUBLE PRECISION PI
       PARAMETER (PI = 3.14159)
       DOUBLE PRECISION H, DELTAZ, SUMODD, SUMEVE, Z
       INTEGER I

C Function I am integrating over...
       DOUBLE PRECISION F, X
       F(X) = X ** 3

C Compute required increments
       H = (B - A) / N
       DELTAZ = 2.0 * H

C Compute SUMODD
C This collects all of the odd coeffs into one sum
       SUMODD = 0.0
       Z = A + H
       DO 10 I = 2, N, 2
          SUMODD = SUMODD + F(Z)
          CALL CKPT_AND_EXIT
          Z = Z + DELTAZ
  10   CONTINUE

C Compute SUMEVE
C This collects all of the even coeffs into one sum
       SUMEVE = 0.0
       Z = A + DELTAZ
       DO 20 I = 2, N-2, 2
          SUMEVE = SUMEVE + F(Z)
          CALL CKPT_AND_EXIT
          Z = Z + DELTAZ
  20   CONTINUE

C Compute the integral and return
       SIMPSN = (F(A) + F(B) + 4.0 * SUMODD + 2.0 * SUMEVE) * (H / 3.0)
       RETURN
       END


      subroutine DTGEXT(x, y, z, dz, triang, bdry, mb, ncont,
     *                  q, indtri, MODE, zout, wantdz, dzout)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2000-12-01 DTGEXT Krogh Removed unused parameters three & four.
c>> 1997-07-01 DTGEXT Krogh Reversed subscripts in B (CLL suggestion)
c>> 1997-06-23 DTGEXT Krogh Removed "_" in names, set up for M77CON.
c>> 1997-06-22 cll
c>> 1997-06-18 DTGEXT CLL
c>> 1996-10-15 DTGEXT CLL
c
c  This subroutine handles extrapolation outside the convex hull
c  of given data points.
c
c  We partition the (infinite) space exterior to the convex hull by
c  constructing two rays into the exterior space rooted at each boundary
c  vertex, one ray perpendicular to each of the two boundary edges that
c  meet at the vertex.  The boundary has NB vertices.  This partitions
c  the exterior into 2*NB (infinite) cells.  We call these cells wedges
c  and blocks.  A wedge is a cell bounded by two boundary rays rooted at
c  a single vertex point.  A block is a cell bounded by a boundary edge
c  and the two rays perpendicular to each end of the edge.
c
c  We first determine which of these cells contains the specified point,
c  q, and then use an extrapolation formula in that cell that is
c  designed to maintain C0 continuity if Ncont = 0, or C1 continuity if
c  Ncont = 1.
c
c  The C0 extrapolation is exact for a linear function but not for
c  polynomials of degree > 1.
c  The C1 extrapolation is exact for a linear function but not for
c  polynomials of degree > 1.
c     ------------------------------------------------------------------
c                      Subroutine arguments
c
c  wantdz, dzout(1:2)
c   X(), Y() [in]  (x,y) coordinates of vertices of the
c                          triangular grid.
c
c   Z() [in]  Z(i) is the value at (X(i),Y(i)) of the data to
c                 be interpolated.
c
c   DZ(1:2, *) [in]  DZ(1:2, i) are the values of the partial
c         derivatives of the interpolation function at (X(i),Y(i)) with
c         respect to x and y, respectively.
c
c   Triang() [integer, in]  Array of integer pointers defining the
c            connectivity of the triangular grid.

c   Bdry(1:4, MB) [integer, in]  Array containing pointers defining the
c      boundary of the (convex) triangular grid.
C         Bdry(1, K) = FWD POINTER. Points to next vertex in
c                     counterclockwise order.
C         Bdry(2, K) = BACKWARD POINTER. Points to next vertex in
c                     clockwise order.
C         Bdry(3, K) = A BOUNDARY POINT
C         Bdry(4, K) = A BOUNDARY TRIANGLE
c      The triangle Bdry(4, K) has a boundary edge that
c      connects the points Bdry(3, K) and Bdry(3, K+1).
c      In general not all elements of the array Bdry() are members of
c      the linked list defining the boundary.
c      The entry with K = 1 is a member of the boundary list.  To scan
c      the boundary, start at K = 1 and follow the forward or backward
c      pointers.
c
c   MB [in]
c
c   NCONT [in]  = 0 or 1 to request either C0 or C1 continuity.
c
c   Q(1:2) [floating, in]  The (x,y) coordinates of the point for which
c          this subr will compute an extrapolated value.
c
c   indtri [integer, inout]  On entry, this is the index of a boundary
c          triangle, relative to which Q is outside a boundary edge.
c          On return, this will be the index of a boundary triangle,
c          containing a boundary vertex that is a closest vertex on the
c          boundary to Q.  This is being returned for use as a starting
c          point for the next search, if desired.
c
c   MODE [integer, in]
c
c   ZOUT [out]  Extrapolated function value computed by this subroutine.
c
c   WANTDZ [in]  =.TRUE. means compute DZOUT() as well as ZOUT.
c              =.FALSE. means compute only ZOUT and not DZOUT().
c
c   DZOUT(1:2) [out]  First partial derivs w.r.t. x and y of the
c              extrapolated surface at the point, Q().
c     ------------------------------------------------------------------
c               Internal Variables
c
c  TRI(1:8)  Integer array of pointers defining one triangle.
c     TRI(1:3) are pointers to neighboring triangles in counterclockwise
c     order.
c     TRI(4:6) are pointers to vertex points in counterclockwise order.
c     Subroutine _TGGET sets TRI(1:6).  When needed in this subroutine
c     we set TRI(7) = TRI(4) and TRI(8) = TRI(5).
c     For i = 1, 2, or 3, the points TRI(i+3) and TRI(i+4) are endpoints
c     of the edge that is shared between this triangle and triangle
c     TRI(i).
c     If there is no adjacent triangle across this edge then TRI(i) = 0.
c
c  p0, p1, p2, ib [integers]  P0, p1 and p2 are indices of points.
c     Ib is the index into Bdry() such that p1 = Bdry(3, ib).
c
c     If Q is found to be in a "block", the block is rooted on the
c     boundary segment connecting vertices p0 and p1 in the clockwise
c     direction.  p0 = Bdry(3, Bdry(1, ib)), p1 = Bdry(3, ib).  The
c     index of the boundary triangle containing points p0 and p1 is
c     Bdry(4, ib).  P2 is not used in this case.
c
c     If Q is found to be in a "wedge", the wedge is rooted at p1.
c     P0, p1, and ib have the same relations as described above for Q
c     in a block.  In addition p2 is the next boundary vertex clockwise
c     from p1.  Thus p2 = Bdry(3, Bdry(2, ib)).  The index
c     of the boundary triangle containing points p1 and p2 is
c     Bdry(4, Bdry(2, ib)).
c     ------------------------------------------------------------------
c--D replaces "?": ?TGEXT, ?TGGET, ?TGQS, ?TGC0
c     ------------------------------------------------------------------
      integer mb
      integer bdry(4, mb), i, ib, indtri
      integer mode, ncont
      integer p0, p1, p2, tri(8), triang(*)
      double precision alpha, b, beta, bsq, c
      double precision derk0s, derk1s, dz(2,*), dzout(2)
      double precision fu0, fuu0, fuuv, fvu0, fvuv
      double precision g0, g1, h0s, h1s, k0s, k1s
      double precision mean, one
      double precision p0test, p1test
      double precision q(2), q0(2), q2(2), recipb, s, ss, st
      double precision sarray(3,4), six
      double precision t, tt, two
      double precision ugrad0, ugrad1
      double precision vgrad0, vgrad1, vq, w0(2), w0norm, w2(2), w2norm
      double precision x(*), xloc(3)
      double precision y(*), yloc(3)
      double precision z(*), z0, z2, zero, zout
        parameter(zero=0.0d0, one=1.0d0, two=2.0d0)
        parameter(six=6.0d0)
      logical wantdz

c     ------------------------------------------------------------------
      call DTGGET(indtri, tri, triang)
      tri(7) = tri(4)
      p1 = tri(mode+3)
      p0 = tri(mode+4)
c
c        Set ib to be the index of p1 in the boundary list.
c
      ib = 1
        do 5 i = 1, MB
         if(Bdry(3, ib) .eq. p1) go to 10
           ib = Bdry(1, ib)
    5   continue
c     call IERM1(SUBNAM,INDIC,LEVEL,MSG,LABEL,VALUE,FLAG)
      call ierm1('DTGEXT',1,2,'Index p0 not found in boundary list.',
     *     'P0',p0,'.')
      zout = zero
      return

   10 continue
c
c        Define a (u,v) coordinate system, with p0 as the origin and the
c        positive u axis in the direction of p1.  The point q is above
c        this u axis.
c
c        Is q to the right of p0 in the (u,v) system?
c
      p0test = (q(1) - x(p0)) * (x(p1)-x(p0)) +
     *         (q(2) - y(p0)) * (y(p1)-y(p0))
        if(p0test .ge. zero) then
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
c            Searching to right (clockwise around boundary)
c
c        Is q to the left of p1 in the (u,v) system?
c
   20    continue
           p1test = (q(1) - x(p1)) * (x(p1)-x(p0)) +
     *            (q(2) - y(p1)) * (y(p1)-y(p0))
           if(p1test .le. zero) then
c
c              Q is in the block rooted on the segment from p0 to p1.
c
            bsq = (x(p1)-x(p0))**2 + (y(p1)-y(p0))**2
              s = one + p1test/bsq
              go to 200
         endif
c
c           Move one segment to right around boundary.
c           New (u,v) system is based on new p0 and p1.
c
         p0 = p1
         ib = Bdry(2, ib)
           p1 = Bdry(3, ib)
c
c           Is q to the left of p0 in the (u,v) system?
c
         p0test = (q(1) - x(p0)) * (x(p1)-x(p0)) +
     *            (q(2) - y(p0)) * (y(p1)-y(p0))
           if(p0test .le. zero) then
c
c              Q is in the wedge rooted at p0.
c              Change names so wedge is rooted at p1.
c
            p2 = p1
              p1 = p0
            ib = Bdry(1, ib)
                p0 = Bdry(3, Bdry(1, ib))
            go to 100
           endif
           go to 20
        else
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
c            Searching to left (counterclockwise around boundary)
c
   30    continue
c
c           Move one segment to left around boundary.
c           New (u,v) system is based on new p0 and p1.
c
         p1 = p0
           ib = Bdry(1, ib)
           p0 = Bdry(3, Bdry(1, ib))
c
c           Is q to the right of p1 in the (u,v) system?
c
           p1test = (q(1) - x(p1)) * (x(p1)-x(p0)) +
     *            (q(2) - y(p1)) * (y(p1)-y(p0))
           if(p1test .ge. zero) then
c
c              Q is in the wedge rooted at p1.
c
            p2 = Bdry(3, Bdry(2, ib))
              go to 100
         endif
c
c           Is q to the right of p0 in the (u,v) system?
c
         p0test = (q(1) - x(p0)) * (x(p1)-x(p0)) +
     *            (q(2) - y(p0)) * (y(p1)-y(p0))
           if(p0test .ge. zero) then
c
c           Q is in the block rooted on the segment from p0 to p1.
c
            bsq = (x(p1)-x(p0))**2 + (y(p1)-y(p0))**2
              s = p0test/bsq
              go to 200
c            Compute value ...
           endif
           go to 30
        endif
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  100 continue
c
c        Here the point q is in a wedge rooted at p1 and
c        p1 = Bdry(3, ib).  We also have p0 and p2 as the next boundary
c        vertices in the counterclockwise and clockwise directions,
c        respectively.
c
c                Compute Zout, and optionally Dzout(1:2).
c
      if(ncont .eq. 0) then
c
c        Let d0 be the vector from p1 to p0. Let w0 be the vector
c        resulting from rotating d0 90 degrees clockwise.
c        Let d2 be the vector from p1 to p2. Let w2 be the vector
c        resulting from rotating d2 90 degrees counterclockwise.
c
c        Rescale w0 and w2 so they have the same length, say the
c        geometric mean of their original lengths.
c        Set q0 = p1+w0 and q2 = p1+w2.
c
c        Let z0 be the z value obtained by using DTGC0 to do C0
c        extrapolation at q0 using the data of the boundary
c        triangle containing vertices p0 and p1.
c
c        Let z2 be the z value obtained by using DTGC0 to do C0
c        extrapolation at q2 using the data of the boundary
c        triangle containing vertices p1 and p2.
c
c        Construct a triangle with vertices p1, q2, and q0,
c        and give it vertex z values z(p1), z2 and z0, respectively.
c
c        Use DTGC0 with this triangle to interpolate/extrapolate
c        for a z value and/or for partial derivatives at Q.
c
           w0(1) =   y(p0) - y(p1)
           w0(2) = -(x(p0) - x(p1))
           w0norm = sqrt(w0(1)**2 + w0(2)**2)
           w2(1) = -(y(p2) - y(p1))
           w2(2) =   x(p2) - x(p1)
           w2norm = sqrt(w2(1)**2 + w2(2)**2)
           mean = sqrt(w0norm*w2norm)
         q0(1) = x(p1) + w0(1) * mean / w0norm
           q0(2) = y(p1) + w0(2) * mean / w0norm
           q2(1) = x(p1) + w2(1) * mean / w2norm
           q2(2) = y(p1) + w2(2) * mean / w2norm
         call DTGGET(Bdry(4, ib), tri, triang)
         tri(7) = tri(4)
           tri(8) = tri(5)
           call DTGQS(q0, tri, x, y, sarray)
           do 110 i = 1,3
              sarray(i,4) = z(tri(5+i))
  110    continue
         call DTGC0  (Sarray, z0, .false., DZOUT)

         call DTGGET(Bdry(4, Bdry(2, ib)), tri, triang)
         tri(7) = tri(4)
           tri(8) = tri(5)
           call DTGQS(q2, tri, x, y, sarray)
           do 120 i = 1,3
              sarray(i,4) = z(tri(5+i))
  120    continue
         call DTGC0  (Sarray, z2, .false., DZOUT)
           xloc(1) = x(p1)
           yloc(1) = y(p1)
           xloc(2) = q2(1)
           yloc(2) = q2(2)
           xloc(3) = q0(1)
           yloc(3) = q0(2)
           tri(4) = 1
           tri(5) = 2
           tri(6) = 3
           tri(7) = 1
           call DTGQS(q, tri, xloc, yloc, sarray)
           sarray(1,4) = z0
           sarray(2,4) = z(p1)
           sarray(3,4) = z2
         call DTGC0  (Sarray, ZOUT, WANTDZ, DZOUT)
      else
c                   Here we assume Ncont = 1
c
         zout = z(p1) + dz(1,p1)*(q(1)-x(p1)) + dz(2,p1)*(q(2)-y(p1))
           if(wantdz) then
            dzout(1) = dz(1,p1)
            dzout(2) = dz(2,p1)
           endif
      endif
      go to 800
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  200 continue
c
c        Here the point q is in a block rooted at the boundary edge
c        connecting p0 and p1.
c        Also, p0 = Bdry(3, Bdry(1, ib)), p1 = Bdry(3, ib)
c        Our goal is to compute Zout, and optionally Dzout(1:2).
c
c        P1 is in the clockwise direction around the boundary from p0.
c        The (x,y) coordinates of p0 and p1 are (x(p0), y(p0)) and
c        (x(p1), y(p1)) respectively.
c        We use an (x',y') system which is the translate of the
c        (x,y) system to have p0 as its origin.  Thus x' = x - x(p0) and
c        y' = y - y(p0).
c        We use a (u,v) coordinate system, which is a rotation of the
c        (x',y') system having its origin at p0 and the positive
c        u axis in the direction of p1.
c
c        Let b denote the (positive) distance from p0 to p1. The (u,v)
c        coordinates of p0 and p1 are (0,0) and (0,b) respectively.
c        We already have bsq (= b**2) computed so we can compute
c        b = sqrt(bsq).
c
c        Let uq and vq denote the u and v coordinates of q.  Define
c        s = uq/b.  We already have s computed, so we can compute
c        uq = b*s.
c
c        In cases where needed we will compute alpha and/or beta.
c        These allow construction of the (orthogonal) matrix for
c        transformations between the (x',y') and (u,v) coordinate
c        systems.  Alpha and beta are respectively the x' and y'
c        coordinates of p1.
c
c        Let J denote the 2x2 orthogonal matrix:
c                   J = |alpha   -beta|
c                       | beta   alpha|
c        Then
c                   J * |u| = |x'|
c                         |v|   |y'|
c
c                   J_transposed * |x'| = |u|
c                                  |y'|   |v|
c
c                   J * |df/du| = |df/dx|
c                       |df/dv| = |df/dy|
c
c                   J_transposed * |df/dx| = |df/du|
c                                    |df/dy|   |df/dv|
c
      if(ncont .eq. 0) then
         call DTGGET(Bdry(4, ib), tri, triang)
         tri(7) = tri(4)
           tri(8) = tri(5)
           call DTGQS(q, tri, x, y, sarray)
           do 210 i = 1,3
              sarray(i,4) = z(tri(5+i))
  210    continue
         call DTGC0  (Sarray, ZOUT, WANTDZ, DZOUT)
*          zout = z(p0)*t + z(p1)*s
*          if(wantdz) then
*             ugrads = recipb * (z(p1) - z(p0))
*             alpha = (x(p1) - x(p0)) * recipb
*             beta = (y(p1) - y(p0)) * recipb
*             dzout(1) = alpha*ugrads
*             dzout(2) =  beta*ugrads
*        endif
        else
c                   Here we assume Ncont = 1
c
         b = sqrt(bsq)
           recipb = one/b
           t = one-s
           alpha = (x(p1) - x(p0)) * recipb
           beta  = (y(p1) - y(p0)) * recipb
           vq = -beta * (q(1)-x(p0)) + alpha * (q(2)-y(p0))
c
c           Test for and treat special cases of q at p0 or p1.
c           When q is at p0 we have vq and s both zero.
c           When q is at p1 we have vq and t both zero.
c
           if(vq .eq. zero) then
              if(s .eq. zero) then
                 zout = z(p0)
                 if(wantdz) then
                    dzout(1) = dz(1,p0)
                    dzout(2) = dz(2,p0)
                 endif
                 go to 800
              endif
              if(t .eq. zero) then
                 zout = z(p1)
                 if(wantdz) then
                    dzout(1) = dz(1,p1)
                    dzout(2) = dz(2,p1)
                 endif
                 go to 800
              endif
           endif
c
c           Partial derivs w.r.t. u and v at p0.
c
           ugrad0 = alpha*dz(1,p0) +  beta*dz(2,p0)
           vgrad0 = -beta*dz(1,p0) + alpha*dz(2,p0)
c
c           Partial derivs w.r.t. u and v at p1.
c
         ugrad1 = alpha*dz(1,p1) +  beta*dz(2,p1)
           vgrad1 = -beta*dz(1,p1) + alpha*dz(2,p1)

           ss = s**2
           tt = t**2
           h0s = (one + two*s) * tt
           h1s = (one + two*t) * ss
           k0s = s*tt
           k1s = -t*ss
           fu0 = z(p0)*h0s + z(p1)*h1s + b*(ugrad0*k0s + ugrad1*k1s)
           fvu0 = t*vgrad0 + s*vgrad1
           c = (vgrad1 - vgrad0) * recipb
           g0 = c*vq/(b*s + vq)
           g1 = c*vq/(b*t + vq)
           zout = fu0 + vq * fvu0 - b*vq*(k0s*g0 + k1s*g1)

           if(wantdz) then
              st = s*t
              derk0s = tt - two * st
              derk1s = ss - two * st
              fuu0 = recipb * six * st * (z(p1) - z(p0)) +
     *               ugrad0 * derk0s + ugrad1 * derk1s
              fuuv = fuu0 + c*vq -
     *               b*vq*(recipb * derk0s * g0
     *                     - k0s*g0/(b*s+vq)
     *                     + recipb * derk1s *g1
     *                     + k1s*g1/(b*t+vq))
              fvuv = fvu0 - b*(k0s*g0 + k1s*g1)
     *                      -b*c*vq*(k0s*b*s/(b*s+vq)**2
     *                               +k1s*b*t/(b*t+vq)**2)

              dzout(1) = alpha * fuuv -  beta * fvuv
              dzout(2) =  beta * fuuv + alpha * fvuv
         endif
      endif
  800 continue
        end
c     ==================================================================
      subroutine dtgqs(q, tri, x, y, s)
c>> 1997-06-21 cll
c  Given point q() and the triangle described by tri(), this
c  subroutine puts values into s(1:3,1:3) to prepare for use of
c  subroutine DTGC0 to evaluate the C0 interpolation/extrapolation
c  formulas.
c  The point q() is not required to be inside the triangle tri().
c  This subroutine uses tri(4:7)
c  See comments in subroutines DTGC0 or DTGFND for specifications of the
c  elements of tri() and s().
c     ------------------------------------------------------------------
      integer j, j1, j2, tri(7)
      double precision q(2), s(3,4), x(*), y(*)
c     ------------------------------------------------------------------
      DO 10 J=1,3
         J1= TRI(J+3)
         J2 = TRI(J+4)
         S(J,2) = X(J2)-X(J1)
         S(J,3) = Y(J2)-Y(J1)
         S(J,1) = S(J,2) * (Q(2)-Y(J1)) - S(J,3) * (Q(1)-X(J1))
   10 continue
      end


      implicit none
c
      integer :: i, node
      double precision :: gamma, beta, alpha, pi, toler, gamma_r,
     &                    beta_r,  alpha_r, c, s, mag
      double precision, parameter :: zero = 0.0d0, one=1.0d0, two=2.0d0
      double precision :: rotx(3,3), roty(3,3), rotz(3,3), q(3,3),
     &                    qchk(3,3),  x_old(3), x_new(3), unit_y(3),
     &                    p1(3), p2(3), p3(3), v1(3), v2(3), v3(3),
     &                    q_local_global(3,3), q_global_local(3,3)
c
c                   given rotated coordinates, compute the local->global
c                   rotation, then transpose is global->local for
c                   constraint transformation matrix
c
c                   coordinates of 3 nodes in rotated system
c
      p1(1) =-0.118811416E+01
      p1(2) = 0.672382423E+00
      p1(3) = 0.326016658E+00

      p2(1) = -0.115275882E+01
      p2(2) = 0.707737768E+00
      p2(3) =  0.412619212E+00

      p3(1) =-0.127550476E+01
      p3(2) = 0.717884314E+00
      p3(3) = 0.343117650E+00

      v1 = p2 - p1
      v2 = p3 - p1
      call normalize( v1, mag )
      call normalize( v2, mag )
      call cross_prod( v1, v2, v3 )
      call normalize( v3, mag )
      q_local_global(1:3,1) = v1
      q_local_global(1:3,2) = v2
      q_local_global(1:3,3) = v3
      q_global_local = transpose( q_local_global )
       write(*,*) '... q_global_local ...'
      do i = 1, 3
         write(*,9100) q_global_local(i,1:3)
      end do
      unit_y(1) = zero
      unit_y(2) = one
      unit_y(3) = zero
c
      unit_y = matmul( q_global_local, unit_y )
      write(*,*) '... unit_y rotated ...'
      write(*,*) unit_y

c
c              compute rotation to original coordinates to
c              give general position in space
c

      gamma = 20.0d0
      beta  = -60.0d0
      alpha = 45.0d0
      pi = atan(one)*4.0d0
c
      toler = 0.00001d0
c
      rotx = zero
      roty = zero
      rotz = zero
      q    = zero
      qchk = zero

      gamma_r = gamma * pi/180.d0
      beta_r  = beta *  pi/180.d0
      alpha_r = alpha * pi/180.d0
c
      c = cos(gamma_r)
      s = sin(gamma_r)
      rotx(1,1) = one
      rotx(2,2) = c
      rotx(3,3) = c
      rotx(3,2) = s
      rotx(2,3) = -s

      c = cos(beta_r)
      s = sin(beta_r)
      roty(1,1) = c
      roty(1,3) = s
      roty(2,2) = one
      roty(3,1) = -s
      roty(3,3) = c

      c = cos(alpha_r)
      s = sin(alpha_r)
      rotz(1,1) = c
      rotz(1,2) = -s
      rotz(2,1) = s
      rotz(2,2) = c
      rotz(3,3) = one

      q = matmul( roty, rotx )
      q = matmul( rotz, q )
      write(*,*) '... Q ...'
      do i = 1, 3
         write(*,9100) q(i,1:3)
      end do

      write(*,*) '... trans(q) * q ...'
      qchk = matmul( transpose( q ), q )
      do i = 1, 3
         write(*,9000) qchk(i,1:3)
      end do

      do i = 1, 3020
       read(*,*,end=100) node, x_old
       x_new = matmul( q, x_old )
       if( abs(x_new(1) ) <= toler ) x_new(1) = zero
       if( abs(x_new(2) ) <= toler ) x_new(2) = zero
       if( abs(x_new(3) ) <= toler ) x_new(3) = zero
       write(*,1000) node, x_new
      end do
c
 100  stop
 1000 format(i8,3e17.9)
 9000 format(10x,3f10.3)
 9100 format(10x,3e16.8)
      end

      subroutine cross_prod (vec1, vec2, vec_out)
c
c
      double precision
     &     vec1(3), vec2(3), vec_out(3)
      data zero /0.0/
c
      vec_out(1) = vec1(2)*vec2(3) -
     &     vec2(2)*vec1(3)
      vec_out(2) = vec2(1)*vec1(3) -
     &     vec1(1)*vec2(3)
      vec_out(3) = vec1(1)*vec2(2) -
     &     vec2(1)*vec1(2)
c
      return
      end
c
c
      subroutine normalize (vec, mag)
c
c
      double precision
     &     vec(3), zero, mag
      integer i, j
      data zero /0.0/
c
      mag = sqrt ( vec(1)**2 + vec(2)**2 + vec(3)**2 )
c
      do i=1, 3
         vec(i) = vec(i) / mag
      enddo
c
      return
      end


PROGRAM F040

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, PARAMETER :: MAX_E = 7; ! 1E+x

    INTEGER, DIMENSION(MAX_E), PARAMETER :: N = &
    (/ 1, 10, 100, 1000, 10000, 100000, 1000000 /)

    CHARACTER (LEN=10) :: NUM_STR

    INTEGER, DIMENSION(MAX_E) :: INDICES

    INTEGER :: PRODUCT_VAL = 1

    INTEGER :: I, J, NUM, INDEX_VAL

    INDICES(1) = 1

    DO I = 2, MAX_E
        INDICES(I) = INDICES(I-1) + (9 * (I - 1) * INT(10 ** (I - 2)))
    END DO

    DO I = 1, MAX_E

        J = 1
        DO WHILE (J <= MAX_E)
            IF (N(I) < INDICES(J)) EXIT
            J = J + 1
        END DO
        J = J - 2

        NUM = INT(10 ** J) + INT((N(I) - INDICES(J+1)) / (J + 1))

        WRITE(NUM_STR, '(I10)') NUM
        NUM_STR = ADJUSTL(NUM_STR)

        INDEX_VAL = MOD(N(I) - INDICES(J+1), J + 1) + 1

        PRODUCT_VAL = PRODUCT_VAL &
                    * (IACHAR(NUM_STR(INDEX_VAL:INDEX_VAL)) - IACHAR('0'));

    END DO

    PRINT ('(I0)'), PRODUCT_VAL

END PROGRAM F040