      subroutine merge_shifts(irr,mitot,mjtot,lwidth,hx,hy,xlow,ylow,
     . lstgrd, numHoods)

! !   INPUTS:
! !   REQUIRED GRID DATA
! !
! !   irr,mitot,mjtot,lwidth,hx,hy,xlow,ylow,lstgrd
! !
! !   REQUIRED MERGING DATA
! !   volMerge, xcmerge, ycmerge, numHoods,
! !   mi, mj, ncount
! !
! !   OUTPUT
! !   qmshifts
! !
! !   NOTE qmshifts(1,k) = shift for xx
! !        qmshifts(2,k) = shift for xy
! !        qmshifts(3,k) = shift for yy
! !   Called dmergeshift in AG code

      use amr_module
      implicit double precision (a-h, o-z)

      dimension irr(mitot,mjtot), numHoods(mitot,mjtot)

      include "quadrature.i"

      ! recompute the shifts
      do 719 j = 1, mjtot    ! iterate over each cell in the grid
      do 719 i = 1, mitot    ! iterate over each cell in the grid
         k = irr(i,j)

         if (k .eq. -1 .or. k .eq. lstgrd) cycle ! skip solid and whole cells

          shiftmxx = 0.d0
          shiftmxy = 0.d0
          shiftmyy = 0.d0

          x0 = xcentMerge(k)
          y0 = ycentMerge(k)
          arr = volMerge(k)

          do 340 ic = 0, ncount(k) ! my count 1 less than AG
!           AG data structure)
!           ioff = mi(k,ic)
!           joff = mj(k,ic)

!           my data structure
            if (ic .eq. 0) then
               ioff = i  ! first do cell itself
               joff = j
            else ! now pointing to nbor
               ioff = iidx(ic,k)
               joff = jidx(ic,k)
            endif

            koff = irr(ioff, joff)

            if(koff .eq. lstgrd) then ! full cell
               itri = 2
               call makep(poly(1,1,lstgrd),ioff,joff,xlow,ylow,hx,hy)
            else                      ! cut cells
              ivert = 1
              do 239 while (poly(ivert+1,1,koff) .ne. -11.)
                ivert = ivert + 1
 239          continue
              itri = ivert - 3
            endif
            idx1 = 1
            do 219 it = 1, itri ! for each  triangle
             idx2 = it + 1
             idx3 = it + 2

             x1 = poly(idx1,1,koff)
             y1 = poly(idx1,2,koff)

             x2 = poly(idx2,1,koff)
             y2 = poly(idx2,2,koff)

             x3 = poly(idx3,1,koff)
             y3 = poly(idx3,2,koff)

             ! YOU MUST WEIGHT THE TRIANGLE AREA BY NUMHOODS
             artri = triangle_area(x1, x2, x3,  y1, y2, y3) /
     .               numHoods(ioff, joff)

             do 229 itq = 1,ntriquad

                 xval = x1 * rtri(itq) + x2 * stri(itq)
     .               +  x3 * (1.d0-rtri(itq)-stri(itq))
                 yval = y1 * rtri(itq) + y2 * stri(itq)
     .               +  y3 * (1.d0-rtri(itq)-stri(itq))

                 shiftmxx = shiftmxx + (artri/arr)*wtri(itq)*
     .                       (xval-x0)**2 /(hx**2)
                 shiftmxy = shiftmxy + (artri/arr)*wtri(itq)*
     .                       (xval-x0)*(yval-y0)/(hx * hy)
                 shiftmyy = shiftmyy + (artri/arr)*wtri(itq)*
     .                       (yval-y0)**2 /(hy**2)

 229         continue ! for each quadrature point on each triangle
 219        continue ! for each triangle

 340   continue  ! iterate over each cell in the neighborhood

        ! save for use in merge nhood reconstruction
        qmshifts(1,k)  = shiftmxx
        qmshifts(2,k)  = shiftmxy
        qmshifts(3,k)  = shiftmyy

 719  continue ! iterate over each cell in the grid

      return
      end


      subroutine ire_eqipsi(n_a1,n_alpha,n_beta,n_iPHI,n_iPI,nm1_ipsi,np
     &1_ipsi,Nx,ht,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 n_a1(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_iPHI(Nx)
      real*8 n_iPI(Nx)
      real*8 nm1_ipsi(Nx)
      real*8 np1_ipsi(Nx)
      real*8 res
      real*8 qb
      res = 0.0D0
      do i=1, Nx, 1
      qb = 0.5000000000000000D0 * (-0.1D1 * nm1_ipsi(i) + np1_ipsi(i)) /
     # ht - 0.1D1 * n_alpha(i) / n_a1(i) * n_iPI(i) - 0.1D1 * n_beta(i)
     #* n_iPHI(i)
      res = res + qb**2
      end do
      res = sqrt(res/(1*Nx))
      END


*DECK HSTSSP
      SUBROUTINE HSTSSP (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND,
     +   BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W)
C***BEGIN PROLOGUE  HSTSSP
C***PURPOSE  Solve the standard five-point finite difference
C            approximation on a staggered grid to the Helmholtz
C            equation in spherical coordinates and on the surface of
C            the unit sphere (radius of 1).
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B1A1A
C***TYPE      SINGLE PRECISION (HSTSSP-S)
C***KEYWORDS  ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SPHERICAL
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C     HSTSSP solves the standard five-point finite difference
C     approximation on a staggered grid to the Helmholtz equation in
C     spherical coordinates and on the surface of the unit sphere
C     (radius of 1)
C
C             (1/SIN(THETA))(d/dTHETA)(SIN(THETA)(dU/dTHETA)) +
C
C       (1/SIN(THETA)**2)(d/dPHI)(dU/dPHI) + LAMBDA*U = F(THETA,PHI)
C
C     where THETA is colatitude and PHI is longitude.
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C    * * * * * * * *    Parameter Description     * * * * * * * * * *
C
C            * * * * * *   On Input    * * * * * *
C
C   A,B
C     The range of THETA (colatitude), i.e. A .LE. THETA .LE. B.  A
C     must be less than B and A must be non-negative.  A and B are in
C     radians.  A = 0 corresponds to the north pole and B = PI
C     corresponds to the south pole.
C
C
C                  * * *  IMPORTANT  * * *
C
C     If B is equal to PI, then B must be computed using the statement
C
C     B = PIMACH(DUM)
C
C     This insures that B in the user's program is equal to PI in this
C     program which permits several tests of the input parameters that
C     otherwise would not be possible.
C
C                  * * * * * * * * * * * *
C
C
C
C   M
C     The number of grid points in the interval (A,B).  The grid points
C     in the THETA-direction are given by THETA(I) = A + (I-0.5)DTHETA
C     for I=1,2,...,M where DTHETA =(B-A)/M.  M must be greater than 2.
C
C   MBDCND
C     Indicates the type of boundary conditions at THETA = A and
C     THETA = B.
C
C     = 1  If the solution is specified at THETA = A and THETA = B.
C          (see note 3 below)
C
C     = 2  If the solution is specified at THETA = A and the derivative
C          of the solution with respect to THETA is specified at
C          THETA = B (see notes 2 and 3 below).
C
C     = 3  If the derivative of the solution with respect to THETA is
C          specified at THETA = A (see notes 1, 2 below) and THETA = B.
C
C     = 4  If the derivative of the solution with respect to THETA is
C          specified at THETA = A (see notes 1 and 2 below) and the
C          solution is specified at THETA = B.
C
C     = 5  If the solution is unspecified at THETA = A = 0 and the
C          solution is specified at THETA = B.  (see note 3 below)
C
C     = 6  If the solution is unspecified at THETA = A = 0 and the
C          derivative of the solution with respect to THETA is
C          specified at THETA = B (see note 2 below).
C
C     = 7  If the solution is specified at THETA = A and the
C          solution is unspecified at THETA = B = PI. (see note 3 below)
C
C     = 8  If the derivative of the solution with respect to
C          THETA is specified at THETA = A (see note 1 below)
C          and the solution is unspecified at THETA = B = PI.
C
C     = 9  If the solution is unspecified at THETA = A = 0 and
C          THETA = B = PI.
C
C     NOTES:  1.  If A = 0, do not use MBDCND = 3, 4, or 8,
C                 but instead use MBDCND = 5, 6, or 9.
C
C             2.  If B = PI, do not use MBDCND = 2, 3, or 6,
C                 but instead use MBDCND = 7, 8, or 9.
C
C             3.  When the solution is specified at THETA = 0 and/or
C                 THETA = PI and the other boundary conditions are
C                 combinations of unspecified, normal derivative, or
C                 periodicity a singular system results.  The unique
C                 solution is determined by extrapolation to the
C                 specification of the solution at either THETA = 0 or
C                 THETA = PI.  But in these cases the right side of the
C                 system will be perturbed by the constant PERTRB.
C
C   BDA
C     A one-dimensional array of length N that specifies the boundary
C     values (if any) of the solution at THETA = A.  When
C     MBDCND = 1, 2, or 7,
C
C              BDA(J) = U(A,PHI(J)) ,              J=1,2,...,N.
C
C     When MBDCND = 3, 4, or 8,
C
C              BDA(J) = (d/dTHETA)U(A,PHI(J)) ,    J=1,2,...,N.
C
C     When MBDCND has any other value, BDA is a dummy variable.
C
C   BDB
C     A one-dimensional array of length N that specifies the boundary
C     values of the solution at THETA = B.  When MBDCND = 1,4, or 5,
C
C              BDB(J) = U(B,PHI(J)) ,              J=1,2,...,N.
C
C     When MBDCND = 2,3, or 6,
C
C              BDB(J) = (d/dTHETA)U(B,PHI(J)) ,    J=1,2,...,N.
C
C     When MBDCND has any other value, BDB is a dummy variable.
C
C   C,D
C     The range of PHI (longitude), i.e. C .LE. PHI .LE. D.
C     C must be less than D.  If D-C = 2*PI, periodic boundary
C     conditions are usually prescribed.
C
C   N
C     The number of unknowns in the interval (C,D).  The unknowns in
C     the PHI-direction are given by PHI(J) = C + (J-0.5)DPHI,
C     J=1,2,...,N, where DPHI = (D-C)/N.  N must be greater than 2.
C
C   NBDCND
C     Indicates the type of boundary conditions at PHI = C
C     and PHI = D.
C
C     = 0  If the solution is periodic in PHI, i.e.
C          U(I,J) = U(I,N+J).
C
C     = 1  If the solution is specified at PHI = C and PHI = D
C          (see note below).
C
C     = 2  If the solution is specified at PHI = C and the derivative
C          of the solution with respect to PHI is specified at
C          PHI = D (see note below).
C
C     = 3  If the derivative of the solution with respect to PHI is
C          specified at PHI = C and PHI = D.
C
C     = 4  If the derivative of the solution with respect to PHI is
C          specified at PHI = C and the solution is specified at
C          PHI = D (see note below).
C
C     NOTE:  When NBDCND = 1, 2, or 4, do not use MBDCND = 5, 6, 7, 8,
C     or 9 (the former indicates that the solution is specified at
C     a pole; the latter indicates the solution is unspecified).  Use
C     instead MBDCND = 1 or 2.
C
C   BDC
C     A one dimensional array of length M that specifies the boundary
C     values of the solution at PHI = C.   When NBDCND = 1 or 2,
C
C              BDC(I) = U(THETA(I),C) ,              I=1,2,...,M.
C
C     When NBDCND = 3 or 4,
C
C              BDC(I) = (d/dPHI)U(THETA(I),C),       I=1,2,...,M.
C
C     When NBDCND = 0, BDC is a dummy variable.
C
C   BDD
C     A one-dimensional array of length M that specifies the boundary
C     values of the solution at PHI = D.  When NBDCND = 1 or 4,
C
C              BDD(I) = U(THETA(I),D) ,              I=1,2,...,M.
C
C     When NBDCND = 2 or 3,
C
C              BDD(I) = (d/dPHI)U(THETA(I),D) ,      I=1,2,...,M.
C
C     When NBDCND = 0, BDD is a dummy variable.
C
C   ELMBDA
C     The constant LAMBDA in the Helmholtz equation.  If LAMBDA is
C     greater than 0, a solution may not exist.  However, HSTSSP will
C     attempt to find a solution.
C
C   F
C     A two-dimensional array that specifies the values of the right
C     side of the Helmholtz equation.  For I=1,2,...,M and J=1,2,...,N
C
C              F(I,J) = F(THETA(I),PHI(J)) .
C
C     F must be dimensioned at least M X N.
C
C   IDIMF
C     The row (or first) dimension of the array F as it appears in the
C     program calling HSTSSP.  This parameter is used to specify the
C     variable dimension of F.  IDIMF must be at least M.
C
C   W
C     A one-dimensional array that must be provided by the user for
C     work space.  W may require up to 13M + 4N + M*INT(log2(N))
C     locations.  The actual number of locations used is computed by
C     HSTSSP and is returned in the location W(1).
C
C
C            * * * * * *   On Output   * * * * * *
C
C   F
C     Contains the solution U(I,J) of the finite difference
C     approximation for the grid point (THETA(I),PHI(J)) for
C     I=1,2,...,M, J=1,2,...,N.
C
C   PERTRB
C     If a combination of periodic, derivative, or unspecified
C     boundary conditions is specified for a Poisson equation
C     (LAMBDA = 0), a solution may not exist.  PERTRB is a con-
C     stant, calculated and subtracted from F, which ensures
C     that a solution exists.  HSTSSP then computes this
C     solution, which is a least squares solution to the
C     original approximation.  This solution plus any constant is also
C     a solution; hence, the solution is not unique.  The value of
C     PERTRB should be small compared to the right side F.
C     Otherwise, a solution is obtained to an essentially different
C     problem.  This comparison should always be made to insure that
C     a meaningful solution has been obtained.
C
C   IERROR
C     An error flag that indicates invalid input parameters.
C      Except for numbers 0 and 14, a solution is not attempted.
C
C     =  0  No error
C
C     =  1  A .LT. 0 or B .GT. PI
C
C     =  2  A .GE. B
C
C     =  3  MBDCND .LT. 1 or MBDCND .GT. 9
C
C     =  4  C .GE. D
C
C     =  5  N .LE. 2
C
C     =  6  NBDCND .LT. 0 or NBDCND .GT. 4
C
C     =  7  A .GT. 0 and MBDCND = 5, 6, or 9
C
C     =  8  A = 0 and MBDCND = 3, 4, or 8
C
C     =  9  B .LT. PI and MBDCND .GE. 7
C
C     = 10  B = PI and MBDCND = 2,3, or 6
C
C     = 11  MBDCND .GE. 5 and NDBCND = 1, 2, or 4
C
C     = 12  IDIMF .LT. M
C
C     = 13  M .LE. 2
C
C     = 14  LAMBDA .GT. 0
C
C     Since this is the only means of indicating a possibly
C     incorrect call to HSTSSP, the user should test IERROR after
C     the call.
C
C   W
C     W(1) contains the required length of W.
C
C *Long Description:
C
C    * * * * * * *   Program Specifications    * * * * * * * * * * * *
C
C    Dimension of   BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N),
C    Arguments      W(see argument list)
C
C    Latest         June 1, 1977
C    Revision
C
C    Subprograms    HSTSSP,POISTG,POSTG2,GENBUN,POISD2,POISN2,POISP2,
C    Required       COSGEN,MERGE,TRIX,TRI3,PIMACH
C
C    Special        NONE
C    Conditions
C
C    Common         NONE
C    Blocks
C
C    I/O            NONE
C
C    Precision      Single
C
C    Specialist     Roland Sweet
C
C    Language       FORTRAN
C
C    History        Written by Roland Sweet at NCAR in April, 1977
C
C    Algorithm      This subroutine defines the finite-difference
C                   equations, incorporates boundary data, adjusts the
C                   right side when the system is singular and calls
C                   either POISTG or GENBUN which solves the linear
C                   system of equations.
C
C    Space          8427(decimal) = 20353(octal) locations on the
C    Required       NCAR Control Data 7600
C
C     Timing and        The execution time T on the NCAR Control Data
C     Accuracy       7600 for subroutine HSTSSP is roughly proportional
C                    to M*N*log2(N).  Some typical values are listed in
C                    the table below.
C                       The solution process employed results in a loss
C                    of no more than four significant digits for N and M
C                    as large as 64.  More detailed information about
C                    accuracy can be found in the documentation for
C                    subroutine POISTG which is the routine that
C                    actually solves the finite difference equations.
C
C
C                       M(=N)    MBDCND    NBDCND    T(MSECS)
C                       -----    ------    ------    --------
C
C                        32       1-9       1-4         56
C                        64       1-9       1-4        230
C
C    Portability     American National Standards Institute FORTRAN.
C                    The machine dependent constant PI is defined in
C                    function PIMACH.
C
C    Required       COS
C    Resident
C    Routines
C
C    Reference      Schumann, U. and R. Sweet,'A Direct Method For
C                   The Solution Of Poisson's Equation With Neumann
C                   Boundary Conditions On A Staggered Grid Of
C                   Arbitrary Size,' J. Comp. Phys. 20(1976),
C                   pp. 171-182.
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C***REFERENCES  U. Schumann and R. Sweet, A direct method for the
C                 solution of Poisson's equation with Neumann boundary
C                 conditions on a staggered grid of arbitrary size,
C                 Journal of Computational Physics 20, (1976),
C                 pp. 171-182.
C***ROUTINES CALLED  GENBUN, PIMACH, POISTG
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  HSTSSP
C
C
      DIMENSION       F(IDIMF,*) ,BDA(*)     ,BDB(*)     ,BDC(*)     ,
     1                BDD(*)     ,W(*)
C***FIRST EXECUTABLE STATEMENT  HSTSSP
      IERROR = 0
      PI = PIMACH(DUM)
      IF (A.LT.0. .OR. B.GT.PI) IERROR = 1
      IF (A .GE. B) IERROR = 2
      IF (MBDCND.LE.0 .OR. MBDCND.GT.9) IERROR = 3
      IF (C .GE. D) IERROR = 4
      IF (N .LE. 2) IERROR = 5
      IF (NBDCND.LT.0 .OR. NBDCND.GE.5) IERROR = 6
      IF (A.GT.0. .AND. (MBDCND.EQ.5 .OR. MBDCND.EQ.6 .OR. MBDCND.EQ.9))
     1    IERROR = 7
      IF (A.EQ.0. .AND. (MBDCND.EQ.3 .OR. MBDCND.EQ.4 .OR. MBDCND.EQ.8))
     1    IERROR = 8
      IF (B.LT.PI .AND. MBDCND.GE.7) IERROR = 9
      IF (B.EQ.PI .AND. (MBDCND.EQ.2 .OR. MBDCND.EQ.3 .OR. MBDCND.EQ.6))
     1    IERROR = 10
      IF (MBDCND.GE.5 .AND.
     1    (NBDCND.EQ.1 .OR. NBDCND.EQ.2 .OR. NBDCND.EQ.4)) IERROR = 11
      IF (IDIMF .LT. M) IERROR = 12
      IF (M .LE. 2) IERROR = 13
      IF (IERROR .NE. 0) RETURN
      DELTAR = (B-A)/M
      DLRSQ = DELTAR**2
      DELTHT = (D-C)/N
      DLTHSQ = DELTHT**2
      NP = NBDCND+1
      ISW = 1
      JSW = 1
      MB = MBDCND
      IF (ELMBDA .NE. 0.) GO TO 105
      GO TO (101,102,105,103,101,105,101,105,105),MBDCND
  101 IF (A.NE.0. .OR. B.NE.PI) GO TO 105
      MB = 9
      GO TO 104
  102 IF (A .NE. 0.) GO TO 105
      MB = 6
      GO TO 104
  103 IF (B .NE. PI) GO TO 105
      MB = 8
  104 JSW = 2
  105 CONTINUE
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
      IWB = M
      IWC = IWB+M
      IWR = IWC+M
      IWS = IWR+M
      DO 106 I=1,M
         J = IWR+I
         W(J) = SIN(A+(I-0.5)*DELTAR)
         W(I) = SIN((A+(I-1)*DELTAR))/DLRSQ
  106 CONTINUE
      MM1 = M-1
      DO 107 I=1,MM1
         K = IWC+I
         W(K) = W(I+1)
         J = IWR+I
         K = IWB+I
         W(K) = ELMBDA*W(J)-(W(I)+W(I+1))
  107 CONTINUE
      W(IWR) = SIN(B)/DLRSQ
      W(IWC) = ELMBDA*W(IWS)-(W(M)+W(IWR))
      DO 109 I=1,M
         J = IWR+I
         A1 = W(J)
         DO 108 J=1,N
            F(I,J) = A1*F(I,J)
  108    CONTINUE
  109 CONTINUE
C
C     ENTER BOUNDARY DATA FOR THETA-BOUNDARIES.
C
      GO TO (110,110,112,112,114,114,110,112,114),MB
  110 A1 = 2.*W(1)
      W(IWB+1) = W(IWB+1)-W(1)
      DO 111 J=1,N
         F(1,J) = F(1,J)-A1*BDA(J)
  111 CONTINUE
      GO TO 114
  112 A1 = DELTAR*W(1)
      W(IWB+1) = W(IWB+1)+W(1)
      DO 113 J=1,N
         F(1,J) = F(1,J)+A1*BDA(J)
  113 CONTINUE
  114 GO TO (115,117,117,115,115,117,119,119,119),MB
  115 A1 = 2.*W(IWR)
      W(IWC) = W(IWC)-W(IWR)
      DO 116 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  116 CONTINUE
      GO TO 119
  117 A1 = DELTAR*W(IWR)
      W(IWC) = W(IWC)+W(IWR)
      DO 118 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  118 CONTINUE
C
C     ENTER BOUNDARY DATA FOR PHI-BOUNDARIES.
C
  119 A1 = 2./DLTHSQ
      GO TO (129,120,120,122,122),NP
  120 DO 121 I=1,M
         J = IWR+I
         F(I,1) = F(I,1)-A1*BDC(I)/W(J)
  121 CONTINUE
      GO TO 124
  122 A1 = 1./DELTHT
      DO 123 I=1,M
         J = IWR+I
         F(I,1) = F(I,1)+A1*BDC(I)/W(J)
  123 CONTINUE
  124 A1 = 2./DLTHSQ
      GO TO (129,125,127,127,125),NP
  125 DO 126 I=1,M
         J = IWR+I
         F(I,N) = F(I,N)-A1*BDD(I)/W(J)
  126 CONTINUE
      GO TO 129
  127 A1 = 1./DELTHT
      DO 128 I=1,M
         J = IWR+I
         F(I,N) = F(I,N)-A1*BDD(I)/W(J)
  128 CONTINUE
  129 CONTINUE
C
C     ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A
C     SOLUTION.
C
      PERTRB = 0.
      IF (ELMBDA) 139,131,130
  130 IERROR = 14
      GO TO 139
  131 GO TO (139,139,132,139,139,132,139,132,132),MB
  132 GO TO (133,139,139,133,139),NP
  133 CONTINUE
      ISW = 2
      DO 135 J=1,N
         DO 134 I=1,M
            PERTRB = PERTRB+F(I,J)
  134    CONTINUE
  135 CONTINUE
      A1 = N*(COS(A)-COS(B))/(2.*SIN(0.5*DELTAR))
      PERTRB = PERTRB/A1
      DO 137 I=1,M
         J = IWR+I
         A1 = PERTRB*W(J)
         DO 136 J=1,N
            F(I,J) = F(I,J)-A1
  136    CONTINUE
  137 CONTINUE
      A2 = 0.
      A3 = 0.
      DO 138 J=1,N
         A2 = A2+F(1,J)
         A3 = A3+F(M,J)
  138 CONTINUE
      A2 = A2/W(IWR+1)
      A3 = A3/W(IWS)
  139 CONTINUE
C
C     MULTIPLY I-TH EQUATION THROUGH BY  R(I)*DELTHT**2
C
      DO 141 I=1,M
         J = IWR+I
         A1 = DLTHSQ*W(J)
         W(I) = A1*W(I)
         J = IWC+I
         W(J) = A1*W(J)
         J = IWB+I
         W(J) = A1*W(J)
         DO 140 J=1,N
            F(I,J) = A1*F(I,J)
  140    CONTINUE
  141 CONTINUE
      LP = NBDCND
      W(1) = 0.
      W(IWR) = 0.
C
C     CALL POISTG OR GENBUN TO SOLVE THE SYSTEM OF EQUATIONS.
C
      IF (NBDCND .EQ. 0) GO TO 142
      CALL POISTG (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
      GO TO 143
  142 CALL GENBUN (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
  143 CONTINUE
      W(1) = W(IWR+1)+3*M
      IF (ISW.NE.2 .OR. JSW.NE.2) GO TO 150
      IF (MB .NE. 8) GO TO 145
      A1 = 0.
      DO 144 J=1,N
         A1 = A1+F(M,J)
  144 CONTINUE
      A1 = (A1-DLRSQ*A3/16.)/N
      IF (NBDCND .EQ. 3) A1 = A1+(BDD(M)-BDC(M))/(D-C)
      A1 = BDB(1)-A1
      GO TO 147
  145 A1 = 0.
      DO 146 J=1,N
         A1 = A1+F(1,J)
  146 CONTINUE
      A1 = (A1-DLRSQ*A2/16.)/N
      IF (NBDCND .EQ. 3) A1 = A1+(BDD(1)-BDC(1))/(D-C)
      A1 = BDA(1)-A1
  147 DO 149 I=1,M
         DO 148 J=1,N
            F(I,J) = F(I,J)+A1
  148    CONTINUE
  149 CONTINUE
  150 CONTINUE
      RETURN
      END


!
!.... Driver routines that mimic the IMSL Bspline routine
!
!.... Author:  S. Scott Collis
!
!.... Copyright:  (c)2020 S. Scott Collis
!
!.... Be sure to compile with -r8 otherwise you'll get roundoff errors for
!.... large nx
!
      subroutine BSNAK( nx, x, korder, knot )
!
!.... Make a Not-a-Knot sequence.  Modeled on IMSL routine BSNAK
!
!.... S. Collis
!
      integer nx, korder
      real  x(nx), knot(nx+korder)

      do i = 1, korder
         knot(i) = x(1)
         knot(nx+i) = x(nx)
      end do

      if (mod(korder,2).eq.0) then
         do i = korder+1, nx
            knot(i) = x(i-korder/2)
         end do
      else
         do i = korder+1, nx
            knot(i) = 0.5 * ( x(i-(korder+1)+korder/2 + 1) + &
                              x(i-(korder+1)+korder/2 + 2) )
         end do
      end if

      return
      end

      subroutine BSINT( nx, x, u, korder, knot, bs )

      implicit none

      integer :: nx, korder
      real :: x(nx), u(nx), knot(nx+korder), bs(nx)

      real :: work(nx*(2*korder-1)), work2(2*korder)
      integer :: iflag

      call BINTK( x, u, knot, nx, korder, bs, work, work2 )

!      call splint( x, u, knot, nx, korder, work, bs, iflag )
!      if (iflag.ne.1) then
!	       write(*,*) 'Error in BSINT'
!	       stop
!      end if

      return
      end

      real function BSDER( ider, x, korder, knot, nx, bs )

      implicit none

      integer :: ider, korder, nx
      real :: x, knot(nx+korder), bs(nx)
      real, external :: bvalue, BVALU
      real :: work(3*korder)
      integer :: inbv=1

      BSDER = BVALU( knot, bs, nx, korder, ider, x, inbv, work)

!     BSDER = bvalue( knot, bs, nx, korder, x, ider )

      return
      end

      real function BSVAL( x, korder, knot, nx, bs )

      implicit none

      integer :: ider=1, korder, nx
      real :: x, knot(nx+korder), bs(nx)
      real, external :: bvalue, BVALU
      real :: work(3*korder)
      integer :: inbv=1

      BSVAL = BVALU( knot, bs, nx, korder, ider, x, inbv, work)

!     BSVAL = bvalue( knot, bs, nx, korder, x, ider )

      return
      end

      real function BSITG( x1, x2, korder, knot, nx, bs )

      implicit none

      integer :: korder, nx
      real :: x1, x2, knot(nx+korder), bs(nx)
      real :: work(3*korder)
      integer :: inbv=1

      call BSQAD( knot, bs, nx, korder, x1, x2, BSITG, work)

      return
      end

      subroutine QDAG( fun, x1, x2, err1, err2, idum, val, errest)

      implicit none

      external fun
      real :: x1, x2, err1, err2, errest, val
      integer :: idum, ierr

      errest = min(err1,err2)
      call GAUS8( fun, x1, x2, errest, val, ierr)

      return
      end


      function ran2(idum)
!---------------------------------------------------------------------
!  See NUMERICAL RECIPES for detail of the function under the same
!  name
!  PARAMETERS:
!       idum       : random seed
!---------------------------------------------------------------------
      implicit none

      real :: ran2
      integer, intent(inout) :: idum
      integer, parameter :: im1=2147483563, im2=2147483399, imm1=im1-1
      integer, parameter :: ia1=40014, ia2=40692, iq1=53668, iq2=52774
      integer, parameter :: ir1=12211, ir2=3791, ntab=32, ndiv=1+imm1/ntab
      real, parameter :: am=1./im1, eps=1.2e-7, rnmx=1.-eps
      integer :: idum2=123456789, iy=0, j, k
      integer, dimension(ntab) :: iv

      save iv,iy,idum2

      do j=1,ntab
        iv(j)=0
      enddo

      if(idum.le.0) then
        idum=max(-idum,1)
        idum2=idum
        do j=ntab+8,1,-1
          k=idum/iq1
          idum=ia1*(idum-k*iq1)-k*ir1
          if(idum.lt.0) idum=idum+im1
          if(j.le.ntab) iv(j)=idum
        enddo
        iy=iv(1)
      endif
      k=idum/iq1
      idum=ia1*(idum-k*iq1)-k*ir1
      if(idum.lt.0) idum=idum+im1
      k=idum2/iq2
      idum2=ia2*(idum2-k*iq2)-k*ir2
      if(idum2.lt.0) idum2=idum2+im2
      j=1+iy/ndiv
      iy=iv(j)-idum2
      iv(j)=idum
      if(iy.lt.1) iy=iy+imm1
      ran2=min(am*iy,rnmx)

      end function ran2

!**********************************************************************

      FUNCTION GASDEV(IDUM)
!----------------------------------------------------------------------
!  Gaussian white noise generator using uniformly distributed white
!  noise generator
!----------------------------------------------------------------------

      implicit none
      real:: gasdev, ran2
      integer, intent(inout):: idum
      real :: v1, v2, gv1, gv2
      real, parameter :: pi=3.1415927

      V1=RAN2(IDUM)
      V2=RAN2(IDUM)

      gv1=sqrt(-2.0*log(v1))*cos(2.0*pi*v2)
      gv2=sqrt(-2.0*log(v2))*cos(2.0*pi*v1)

      gasdev=gv1

      END FUNCTION GASDEV


c subroutine lfpt (n,m,theta,cp,pb)
c
c dimension of
c arguments
c                        cp((n/2)+1)
c
c purpose                routine lfpt uses coefficients computed by
c                        routine alfk to compute the single precision
c                        normalized associated legendre function pbar(n,
c                        m,theta) at colatitude theta.
c
c usage                  call lfpt(n,m,theta,cp,pb)
c
c arguments
c
c on input               n
c                          nonnegative integer specifying the degree of
c                          pbar(n,m,theta)
c                        m
c                          is the order of pbar(n,m,theta). m can be
c                          any integer however pbar(n,m,theta) = 0
c                          if abs(m) is greater than n and
c                          pbar(n,m,theta) = (-1)**m*pbar(n,-m,theta)
c                          for negative m.
c
c                        theta
c                          single precision colatitude in radians
c
c                        cp
c                          single precision array of length (n/2)+1
c                          containing coefficients computed by routine
c                          alfk
c
c on output              pb
c                          single precision variable containing
c                          pbar(n,m,theta)
c
c special conditions     calls to routine lfpt must be preceded by an
c                        appropriate call to routine alfk.
c
c precision              single
c
c algorithm              the trigonometric series formula used by
c                        routine lfpt to calculate pbar(n,m,th) at
c                        colatitude th depends on m and n as follows:
c
c                           1) for n even and m even, the formula is
c                              .5*cp(1) plus the sum from k=1 to k=n/2
c                              of cp(k)*cos(2*k*th)
c                           2) for n even and m odd. the formula is
c                              the sum from k=1 to k=n/2 of
c                              cp(k)*sin(2*k*th)
c                           3) for n odd and m even, the formula is
c                              the sum from k=1 to k=(n+1)/2 of
c                              cp(k)*cos((2*k-1)*th)
c                           4) for n odd and m odd, the formula is
c                              the sum from k=1 to k=(n+1)/2 of
c                              cp(k)*sin((2*k-1)*th)
c
c accuracy               comparison between routines lfpt and double
c                        precision dlfpt on the cray1 indicates greater
c                        accuracy for greater values on input parameter
c                        n.  agreement to 13 places was obtained for
c                        n=10 and to 12 places for n=100.
c
c timing                 time per call to routine lfpt is dependent on
c                        the input parameter n.
c
      SUBROUTINE DLFPT(N,M,THETA,CP,PB)
      DOUBLE PRECISION THETA
      DOUBLE PRECISION CP
      DOUBLE PRECISION PB
      DOUBLE PRECISION CDT
      DOUBLE PRECISION SDT
      DOUBLE PRECISION CT
      DOUBLE PRECISION ST
      DOUBLE PRECISION SUM
      DOUBLE PRECISION CTH
      DIMENSION CP(1)
c
      PB = 0.D0
      MA = IABS(M)
      IF (MA.GT.N) RETURN
      IF (N) 10,10,30
   10 IF (MA) 20,20,30
   20 PB = SQRT(.5D0)
      GO TO 140
   30 NP1 = N + 1
      NMOD = MOD(N,2)
      MMOD = MOD(MA,2)
      IF (NMOD) 40,40,90
   40 IF (MMOD) 50,50,70
   50 KDO = N/2 + 1
      CDT = COS(THETA+THETA)
      SDT = SIN(THETA+THETA)
      CT = 1.D0
      ST = 0.D0
      SUM = .5D0*CP(1)
      DO 60 KP1 = 2,KDO
          CTH = CDT*CT - SDT*ST
          ST = SDT*CT + CDT*ST
          CT = CTH
          SUM = SUM + CP(KP1)*CT
   60 CONTINUE
      PB = SUM
      GO TO 140
   70 KDO = N/2
      CDT = COS(THETA+THETA)
      SDT = SIN(THETA+THETA)
      CT = 1.D0
      ST = 0.D0
      SUM = 0.D0
      DO 80 K = 1,KDO
          CTH = CDT*CT - SDT*ST
          ST = SDT*CT + CDT*ST
          CT = CTH
          SUM = SUM + CP(K)*ST
   80 CONTINUE
      PB = SUM
      GO TO 140
   90 KDO = (N+1)/2
      IF (MMOD) 100,100,120
  100 CDT = COS(THETA+THETA)
      SDT = SIN(THETA+THETA)
      CT = COS(THETA)
      ST = -SIN(THETA)
      SUM = 0.D0
      DO 110 K = 1,KDO
          CTH = CDT*CT - SDT*ST
          ST = SDT*CT + CDT*ST
          CT = CTH
          SUM = SUM + CP(K)*CT
  110 CONTINUE
      PB = SUM
      GO TO 140
  120 CDT = COS(THETA+THETA)
      SDT = SIN(THETA+THETA)
      CT = COS(THETA)
      ST = -SIN(THETA)
      SUM = 0.D0
      DO 130 K = 1,KDO
          CTH = CDT*CT - SDT*ST
          ST = SDT*CT + CDT*ST
          CT = CTH
          SUM = SUM + CP(K)*ST
  130 CONTINUE
      PB = SUM
  140 RETURN
      END


      SUBROUTINE YLM(XLAT,XLON,LMAX,Y,WK1,WK2,WK3)
C
      COMPLEX TEMP,FAC,DFAC
      DIMENSION WK1(1),WK2(1),WK3(1),Y(1)
C
C     WK1,WK2,WK3 SHOULD BE DIMENSIONED AT LEAST (LMAX+1)*4
C
      DATA RADIAN/57.2957795/
C
      THETA=(90.-XLAT)/RADIAN
      PHI=XLON/RADIAN
C
      IND=0
      LM1=LMAX+1
      DO 10 IL1=1,LM1
      L=IL1-1
      CALL LEGNDR(THETA,L,L,WK1,WK2,WK3)
C
      FAC=(1.,0.)
      DFAC=CEXP(CMPLX(0.,PHI))
C
      DO 20 IM=1,IL1
      TEMP=FAC*CMPLX(WK1(IM),0.)
      IND=IND+1
      Y(IND)=REAL(TEMP)
      IF(IM.EQ.1) GOTO 20
      IND=IND+1
      Y(IND)=AIMAG(TEMP)
   20 FAC=FAC*DFAC
C
   10 CONTINUE
      RETURN
      END
c
      SUBROUTINE LEGNDR(THETA,L,M,X,XP,XCOSEC)
      DIMENSION X(2),XP(2),XCOSEC(2)
      DOUBLE PRECISION SMALL,SUM,COMPAR,CT,ST,FCT,COT,FPI,X1,X2,X3,
     1F1,F2,XM,TH,DFLOAT
      DATA FPI/12.56637062D0/
      DFLOAT(I)=FLOAT(I)
      SUM=0.D0
      LP1=L+1
      TH=THETA
      CT=DCOS(TH)
      ST=DSIN(TH)
      MP1=M+1
      FCT=DSQRT(DFLOAT(2*L+1)/FPI)
      SFL3=SQRT(FLOAT(L*(L+1)))
      COMPAR=DFLOAT(2*L+1)/FPI
      DSFL3=SFL3
      SMALL=1.D-16*COMPAR
      DO 1 I=1,MP1
      X(I)=0.
      XCOSEC(I)=0.
    1 XP(I)=0.
      IF(L.GT.1.AND.ABS(THETA).GT.1.E-5) GO TO 3
      X(1)=FCT
      IF(L.EQ.0) RETURN
      X(1)=CT*FCT
      X(2)=-ST*FCT/DSFL3
      XP(1)=-ST*FCT
      XP(2)=-.5D0*CT*FCT*DSFL3
      IF(ABS(THETA).LT.1.E-5) XCOSEC(2)=XP(2)
      IF(ABS(THETA).GE.1.E-5) XCOSEC(2)=X(2)/ST
      RETURN
    3 X1=1.D0
      X2=CT
      DO 4 I=2,L
      X3=(DFLOAT(2*I-1)*CT*X2-DFLOAT(I-1)*X1)/DFLOAT(I)
      X1=X2
    4 X2=X3
      COT=CT/ST
      COSEC=1./ST
      X3=X2*FCT
      X2=DFLOAT(L)*(X1-CT*X2)*FCT/ST
      X(1)=X3
      X(2)=X2
      SUM=X3*X3
      XP(1)=-X2
      XP(2)=DFLOAT(L*(L+1))*X3-COT*X2
      X(2)=-X(2)/SFL3
      XCOSEC(2)=X(2)*COSEC
      XP(2)=-XP(2)/SFL3
      SUM=SUM+2.D0*X(2)*X(2)
      IF(SUM-COMPAR.GT.SMALL) RETURN
      X1=X3
      X2=-X2/DSQRT(DFLOAT(L*(L+1)))
      DO 5 I=3,MP1
      K=I-1
      F1=DSQRT(DFLOAT((L+I-1)*(L-I+2)))
      F2=DSQRT(DFLOAT((L+I-2)*(L-I+3)))
      XM=K
      X3=-(2.D0*COT*(XM-1.D0)*X2+F2*X1)/F1
      SUM=SUM+2.D0*X3*X3
      IF(SUM-COMPAR.GT.SMALL.AND.I.NE.LP1) RETURN
      X(I)=X3
      XCOSEC(I)=X(I)*COSEC
      X1=X2
      XP(I)=-(F1*X2+XM*COT*X3)
    5 X2=X3
      RETURN
      end


!  This file is an outline of a code to perform a calculation of a
!    charged particle scattered by a spherically-symmetric short-range local
!    potential.
!  There are a number of comments throughout the file beginning with !>>> which
!    indicate sections of code you will need to complete.

! Last modified: May 25 2021
!                Liam Scarlett

program main

  use constants
  implicit none

  real*8, allocatable :: &
      Vmat(:,:),       & !V-matrix elements Vmat(kf,ki)
      V(:),            & !radial potential function V(r)
      rgrid(:),        & !radial grid
      rweights(:),     & !radial integration weights
      kgrid(:),        & !momentum-space grid
      kweights(:),     & !momentum-space integration weights (and Green's func)
      contwaves(:,:),  & !projectile radial continuum waves contwaves(k,r)
      DCS(:),          & !array to hold differential cross section - DCS(theta)
      theta(:),        & !array to hold values of theta - in degrees
      ICS(:)             !integrated cross section per l

  real*8 :: &
      rmax,   & !max value of radial grid
      dr,     & !radial grid step size
      energy, & !projectile energy
      k,      & !projectile momentum
      kg_A, kg_B, kg_P !some parameters for setting up kgrid

  complex*16, allocatable :: Ton(:) !on-shell T-matrix element per l

  integer :: &
      nrmax,      & !number of rgrid points
      nkmax,      & !number of kgrid points
      zproj,      & !projectile charge
      l,          & !partial-wave angular momentum
      lmin, lmax, & !min and max values of l
      iounit,     & !a unit number for input/ouput
      ntheta,     & !an index to iterate over theta
      nthetamax,  & !max number of theta
      kg_Na, kg_Nb, kg_Np !some more parameters for setting up kgrid

  !! additional variables
  character(len=200) :: filename !! for file io
  integer :: status !! for error checking
  integer :: i_r, i_k !! for iterating through r, k grids
  integer :: ii, jj !! for iterating through V matrix

  !set kgrid parameters - leave this as is
  kg_Na = 30; kg_Nb = 30; kg_Np = 10
  kg_a = 0.85; kg_b = 2.5; kg_p = 4.0
  nkmax=kg_Na+kg_Nb+kg_Np+1

!>>> open data.in file and read input parameters
!>>>    note: energy should be read in electron volts
!>>>      and grid parameters in atomic units
  !! open input file for reading
  filename="data/input/data.in"
  open(unit=iounit, file=trim(adjustl(filename)), action="read", &
      iostat=status)

  !! handle invalid open
  if (status /= 0) then
    write (*, *) "[error] ", trim(adjustl(filename)), " could not be opened"
    call exit(status)
  end if

  !! read energy
  read(iounit, *) energy
  read(iounit, *) rmax, dr
  read(iounit, *) zproj, lmin, lmax

  ! debug
  write (*, *) "[debug] read"
  write (*, *) "[debug] <energy> = ", energy
  write (*, *) "[debug] <rmax> = ", rmax
  write (*, *) "[debug] <dr> = ", dr
  write (*, *) "[debug] <zproj> = ", zproj
  write (*, *) "[debug] <lmin> = ", lmin
  write (*, *) "[debug] <lmax> = ", lmax
  write (*, *) "[debug] end read"

  !! close input file
  close(iounit)

!>>> do any input validation you think is necessary here
  !! check input validity
  status = 0

  if (energy < 0d0) status = 1
  if (rmax < 0d0) status = 1
  if (dr < 0d0) status = 1
  if (lmin < 0) status = 1
  if (lmax < 0) status = 1
  if (lmin > lmax) status = 1

  !! handle invalid input
  if (status /= 0) then
    write (*, *) "[error] input data is invalid"
    call exit(status)
  end if

!>>> convert the energy to atomic units and calculate the
!>>>      projectile momentum
  !! scale energy
  energy = energy / 27.2113862459d0

  !! set momentum
  k = sqrt(2d0*energy)

!>>> determine number of rgrid points nrmax
!>>>    note: nrmax should be even for simpson's integration
!>>>          to take into account that the r=0 point has been omitted
  !! set nrmax such that nrmax*dr >= rmax
  nrmax = ceiling(rmax / dr)

  !! increment nrmax if it is odd
  if (mod(nrmax, 2) == 1) nrmax = nrmax + 1

  !allocate memory
  allocate(rgrid(nrmax),rweights(nrmax))
  allocate(kgrid(nkmax),kweights(nkmax))
  allocate(contwaves(nkmax,nrmax))
  allocate(V(nrmax))
  allocate(Ton(lmin:lmax),ICS(lmin:lmax))
  allocate(Vmat(nkmax,nkmax))

  !setup grids
  call setup_rgrid(nrmax, dr, rgrid, rweights)
  call setup_kgrid(k, nkmax, kg_Na, kg_a, kg_Nb, kg_b, kg_Np, kg_p, kgrid, &
      kweights)

!>>> define short-range potential V(r)
  !! v(r) = z*(1 + (1/r))*exp(-2r)
  do i_r = 1, nrmax
    V(i_r) = zproj*(1d0 + (1d0/rgrid(i_r)))*exp(-2d0*rgrid(i_r))
  end do

  ! !! debug: V(:)
  ! filename="data/output/potential.txt"
  ! open(unit=iounit, file=trim(adjustl(filename)), action="write", &
  !     iostat=status)
  ! do i_r = 1, nrmax, (nrmax/1000)
  !   write (iounit, *) rgrid(i_r), V(i_r)
  ! end do
  ! close (iounit)
  ! !! debug: end

  !begin loop over angular momenta
  do l=lmin, lmax
    !populate contwaves matrix with a continuum wave for each off-shell k
    call setup_contwaves(nkmax,kgrid,l,nrmax,rgrid,contwaves)

    ! !! debug: contwaves(:, :)
    ! if (l == 0) then
    !   filename="data/output/contwaves.txt"
    !   open(unit=iounit, file=trim(adjustl(filename)), action="write", &
    !       iostat=status)
    !   do i_r = 1, nrmax, (nrmax/1000)
    !     write (iounit, *) rgrid(i_r), contwaves(1:min(nkmax,100), i_r)
    !   end do
    !   close (iounit)
    ! end if
    ! !! debug: end

    !evaluate the V-matrix elements
    call calculate_Vmatrix(nkmax,kgrid,contwaves,nrmax,rgrid,rweights,V,Vmat)

    ! !! debug: V-matrix half-on-shell
    ! if (l == 0) then
    !   write (*, *) "[debug] V-matrix half-on-shell"
    !   filename="data/output/v-matrix-halfonshell.txt"
    !   open(unit=iounit, file=trim(adjustl(filename)), action="write", &
    !       iostat=status)
    !   do ii = 2, nkmax
    !     write (iounit, *) kgrid(ii), Vmat(ii, 1)
    !   end do
    !   close (iounit)
    ! end if
    ! !! debug: end

    !solve the Lippman-Schwinger equation for the on-shell T-matrix
    call tmatrix_solver(nkmax,kgrid,kweights,Vmat,Ton(l))
  enddo

  !populate theta - theta = 0, 1,..., 180 degrees
  nthetamax = 181
  allocate(theta(nthetamax),DCS(nthetamax))
  do ntheta = 1, nthetamax
    theta(ntheta) = dble(ntheta-1)
  enddo

  !call subroutines to calculate DCS and ICS
  call compute_dcs(nthetamax, theta, lmin, lmax, Ton, k, DCS)
  call compute_ics(lmin, lmax, Ton, k, ICS)

!>>> output the DCS and ICS to files
!>>>    to easily study the convergence you can write the ics to file as a
!>>>    function of l along with a running total so that the running total in
!>>>    the final line is your total ICS summed over l
  !! open dcs output file for writing
  filename="data/output/dcs.txt"
  open(unit=iounit, file=trim(adjustl(filename)), action="write", &
      iostat=status)

  !! handle invalid open
  if (status /= 0) then
    write (*, *) "[error] ", trim(adjustl(filename)), " could not be opened"
    call exit(status)
  end if

  !! write dcs to file
  ! write (iounit, *) "# theta, dcs(theta)"
  do ntheta = 1, nthetamax
    write (iounit, *) theta(ntheta), DCS(ntheta)
  end do

  !! close dcs output file
  close (iounit)

  !! open ics output file for writing
  filename="data/output/ics.txt"
  open(unit=iounit, file=trim(adjustl(filename)), action="write", &
      iostat=status)

  !! handle invalid open
  if (status /= 0) then
    write (*, *) "[error] ", trim(adjustl(filename)), " could not be opened"
    call exit(status)
  end if

  !! write ics to file
  ! write (iounit, *) "# l, ics(l), sum(ics(1:l))"
  do l = lmin, lmax
    write (iounit, *) l, ics(l), sum(ics(lmin:l))
  end do

  !! close ics output file
  close (iounit)

end program main

subroutine compute_ics(lmin, lmax, Ton, k, ICS)
  use constants
  implicit none
  integer, intent(in) :: lmin, lmax
  complex*16, intent(in) :: Ton(lmin:lmax)
  real*8, intent(in) :: k
  real*8, intent(out) :: ICS(lmin:lmax)
  integer :: l

!>>> populate the ICS array with the partial-wave ICS per l
  !! calculate ics unscaled
  do l = lmin, lmax
    ics(l) = (2d0*l + 1d0)*((abs(Ton(l))) ** 2)
  end do

  !! scale by constant term
  ics(:) = ics(:) * ((4d0*(pi ** 3))/(k ** 4))

end subroutine compute_ics

subroutine compute_dcs(nthetamax, theta, lmin, lmax, Ton, k, DCS)
  use constants
  implicit none
  integer, intent(in) :: nthetamax, lmin, lmax
  real*8, intent(in) :: theta(nthetamax), k
  complex*16, intent(in) :: Ton(0:lmax)
  real*8, intent(out) :: DCS(nthetamax)
  integer :: l, ntheta !loop indices
  real*8:: PL !Legendre polynomials - from file plql.f
  real*8 :: costheta !use this to store cos(theta in radians)
  complex*16 :: f(nthetamax) !scattering amplitude

!>>> calculate the scattering amplitude f(theta) for each theta
!>>>    by iterating over l and using the partial-wave
!>>>    expansion of f
  !! calculate scattering amplitude unscaled
  f(:) = 0d0
  do ntheta = 1, nthetamax
    costheta = cos(theta(ntheta) * (pi/180d0))

    do l = lmin, lmax
      f(ntheta) = f(ntheta) + (2d0*l + 1d0)*Ton(l)*PL(l, costheta)
    end do

  end do
  !! scale scattering amplitude
  f(:) = f(:) * (-pi/(k ** 2))

!>>> obtain the DCS from the scattering amplitude
  do ntheta = 1, nthetamax
    dcs(ntheta) = (abs(f(ntheta))) ** 2
  end do

end subroutine compute_dcs

subroutine setup_rgrid(nrmax, dr, rgrid, rweights)
  implicit none
  integer, intent(in) :: nrmax
  real*8, intent(in) :: dr
  real*8, intent(out) :: rgrid(nrmax), rweights(nrmax)
  integer :: ir !index to iterate over r

!>>> iterate over r and populate the rgrid and rweights arrays
!>>>      - rweights should contain Simpson's integration weights:
!>>>        (4, 2, 4, 2, ..., 2, 4) * dr / 3.0
!>>>      - you can make use of the intrinsic MOD function for the
!>>>        alternating 4, 2 terms
!>>>      - note we have neglected the terms with a coefficient of 1 (rather
!>>>        than 4 or 2) since the first term (r=0) is skipped and the last term
!>>>        corresponds to the end of the radial grid where we assume all
!>>>        functions should be zero (and if not the grid is not large enough)
  !! calculate radial grid
  do ir = 1, nrmax
    rgrid(ir) = dr * ir
  end do

  !! calculate simpson's integration weights
  rweights(1:nrmax:2) = 4d0
  rweights(2:nrmax:2) = 2d0
  !! scale weights appropriately
  rweights(:) = rweights(:) * (dr/3d0)

end subroutine setup_rgrid

subroutine setup_contwaves(nkmax, kgrid, l, nrmax, rgrid, contwaves)
  implicit none
  integer, intent(in) :: nkmax, l, nrmax
  real*8, intent(in) :: kgrid(nkmax), rgrid(nrmax)
  real*8, intent(out) :: contwaves(nkmax,nrmax)
  real*8 :: ncontwaves(nkmax,nrmax)
  integer :: nk, nr !indices to loop over k and r
  real*8 :: E
  !! numerov variables
  real*8 :: s_grid(nrmax), g_grid(nrmax), v_grid(nrmax)
  real*8 :: step_size
  integer :: fact_term
  integer :: status
  integer :: ii

!>>> iterate over k, populating the contwaves matrix
  !! set step_size
  step_size = rgrid(2) - rgrid(1)

  !! initialise numerov grids
  s_grid(:) = 0d0
  v_grid(:) = ((l)*(l + 1d0))/(rgrid(:) ** 2)

  !! calculate double factorial term
  fact_term = 1
  do ii = 1, (2*l + 1), 2
    fact_term = fact_term * ii
  end do

  !! iterate over k
  do nk = 1, nkmax
    !! todo: should inline this
    g_grid(:) = (kgrid(nk) ** 2) - v_grid(:)

    !! calculate boundary conditions
    contwaves(nk, 1:2) = ((rgrid(1:2)*kgrid(nk)) ** (l + 1))/dble(fact_term)

    !! perform numerov method
    status = 0
    call numerov_f(nrmax, step_size, s_grid, g_grid, &
        contwaves(nk, :), status)

    !! handle numerov_f failing
    if (status /= 0) then
      write (*, *) "[error] numerov_f failed with <status> = ", status
      call exit(status)
    end if
  end do

end subroutine setup_contwaves

!>>> your forwards Numerov subroutine can go here
!! numerov_f
!!
!! Brief:
!! Calculates the values of $y(x)$, defined by the differential equation
!! $$ y''(x) = -g(x)y(x) + s(x) $$ ,
!! on a grid to fourth-order accuracy using the forward Numerov method.
!!
!! Summary:
!! Suppose, $X = \{x_{1}, \dotsc, x_{n_{x}}\}$, is a grid with $n_{x}$ points,
!! such that $x_{i+1} - x_{i} = h$ for all $i = 1, \dotsc, n_{x}-1$,
!! and that $g(x), s(x) : \mathbb{R} \to \mathbb{R}$ have been evaluated on
!! this grid.
!! Suppose further that $y : \mathbb{R} \to \mathbb{R}$ is defined by the
!! differential equation,
!! $$ y''(x) = -g(x)y(x) + s(x) $$ ,
!! and the values of $y(x_{1}), y(x_{2})$ are known.
!! The values of $y(x_{i})$ for $i = 3, \dotsc, n_{x}$ are calculated to
!! fourth-order accuracy using the forward Numerov method.
!!
!! Input:
!! - `n_x` is the number of grid points.
!! - `step_size` is the distance between consecutive points on the grid $X$.
!! - `s_grid` is the evaluation of $s(x)$ on the grid $X$.
!! - `g_grid` is the evaluation of $g(x)$ on the grid $X$.
!!
!! Output:
!! - `y_grid` is the evaluation of $y(x)$ on the grid $X$, calculated via the
!!   forward Numerov method.
!! - `status` integer status code which takes the following values:
!!   - `status == 0` indicates successful execution;
!!   - `status > 0` indicates that the arguments were invalid;
!!   - `status == -1` indicates that a numerical error (NaN or infinity)
!!     occured during execution.
subroutine numerov_f (n_x, step_size, s_grid, g_grid, y_grid, status)
  integer , intent(in) :: n_x
  double precision , intent(in) :: step_size
  double precision , intent(in) :: s_grid(n_x)
  double precision , intent(in) :: g_grid(n_x)
  double precision , intent(out) :: y_grid(n_x)
  integer , intent(out) :: status
  double precision :: step_s_grid(n_x)
  double precision :: step_g_grid(n_x)
  integer :: ii

  ! check if arguments are valid
  status = 0

  if (n_x < 1) then
    ! no grid points
    status = 1
  end if

  if (step_size < 0d0) then
    ! non-positive step_size
    status = 2
  end if

  ! terminate subroutine if arguments are invalid, otherwise proceed
  if (status /= 0) then
    y_grid(:) = 0d0
    return
  end if

  ! perform forward-numerov method
  step_s_grid(:) = s_grid(:) * (step_size ** 2) / 12d0
  step_g_grid(:) = g_grid(:) * (step_size ** 2) / 12d0

  if (n_x >= 3) then
    do ii = 2, n_x - 1
      y_grid(ii+1) = &
          ((2*y_grid(ii)*(1d0 - 5d0*step_g_grid(ii))) &
          - (y_grid(ii-1)*(1d0 + step_g_grid(ii-1))) &
          + (step_s_grid(ii+1) + 10d0*step_s_grid(ii) + step_s_grid(ii-1)) &
          ) / (1d0 + step_g_grid(ii+1))

      ! check for and handle numerical error (NaN or Infinity) and terminates
      if ((y_grid(ii+1) /= y_grid(ii+1)) .or. (y_grid(ii+1) > huge(0d0))) then
        status = -1

        if (ii + 2 <= n_x) then
          y_grid(ii+2:n_x) = 0d0
        end if

        return
      end if
    end do
  end if

end subroutine numerov_f

subroutine calculate_Vmatrix(nkmax,kgrid,contwaves,nrmax,rgrid,rweights,V,Vmat)
  use constants
  implicit none
  integer, intent(in) :: nkmax, nrmax
  real*8, intent(in) :: kgrid(nkmax), contwaves(nkmax,nrmax), rgrid(nrmax), &
      rweights(nrmax), V(nrmax)
  real*8, intent(out) :: Vmat(nkmax,nkmax)
  integer :: nkf,nki !indices for looping over on- and off-shell k
  !! array intended to utilise cacheing
  real*8 :: cache(nrmax)

!>>> evaluate the V-matrix elements and store in the Vmat matrix
!>>>    note: the V-matrix is symmetric, make use of this fact to reduce the
!>>>          amount of time spent in this subroutine
  !! loop in efficient order which utilises symmetry of V-matrix
  do nki = 1, nkmax
    !! moved parts of the integrand common to all kf outside for cacheing
    cache(:) = V(:) * contwaves(nki, :) * rweights(:)

    do nkf = 1, nki
      !! calculate V_{f, i} by integration
      Vmat(nkf, nki) = sum(contwaves(nkf, :) * cache(:))

      !! set V_{i, f} = V_{f, i} as consequence of symmetric V-matrix
      !! no check for diagonal since setting diagonal to itself is
      !! inconsequential
      Vmat(nki, nkf) = Vmat(nkf, nki)
    end do
  end do

  !! scale V-matrix
  Vmat(:, :) = Vmat(:, :)  * (2d0/pi)

end subroutine calculate_Vmatrix

subroutine tmatrix_solver(nkmax,kgrid,kweights,Vmat,Ton)
  use constants
  implicit none
  integer, intent(in) :: nkmax
  real*8, intent(in) :: kgrid(nkmax), kweights(nkmax), Vmat(nkmax,nkmax)
  complex*16, intent(out) :: Ton !on-shell T-matrix element
  real*8 :: &
      Koff(nkmax-1), & !half-off-shell K-matrix elements
      Kon,           & !on-shell K-matrix element
      Von,           & !on-shell V-matrix element
      A(nkmax-1,nkmax-1) !Coefficient matrix for the linear system Ax=b
  integer :: j, ipiv(nkmax-1), info
  !! local variables
  integer :: ff, nn ! loop variables

!>>> store the on-shell V-matrix element in Von
  Von = Vmat(1, 1)

!>>> populate the matrix A according to Eq (113) in the slides
  !! iterate through A matrix
  do nn = 1, nkmax-1
    !! set all elements (neglecting delta_{i, j} terms)
    do ff = 1, nkmax-1
      A(ff, nn) = - kweights(nn+1)*Vmat(ff+1, nn+1)
    end do
    !! add diagonal delta{i, i} terms
    A(nn, nn) = A(nn, nn) + 1d0
  end do

!>>> populate the vector Koff with the half-on-shell V-matrix elements (RHS of
!>>> Eq (112))
  do nn = 1, nkmax-1
    Koff(nn) = Vmat(nn+1, 1)
  end do

  !Here is the call to DGESV
  call dgesv( nkmax-1, 1, A, nkmax-1, ipiv, Koff, nkmax-1, info )
  if(info /= 0) then
    print*, 'ERROR in dgesv: info = ', info
  endif

!>>> Now use the half-on-shell K matrix which has been stored in Koff to get the
!>>> on-shell K-matrix element Kon
  Kon = Vmat(1,1) + sum(kweights(2:nkmax)*Vmat(1, 2:nkmax)*Koff(:))

!>>> And then use Kon to get the on-shell T-matrix element Ton
  Ton = Kon / (1d0 + ((0d0,1d0)*pi*Kon)/kgrid(1))

  ! !! debug:
  ! write (*, *) "[debug] <Von> = ", Von
  ! write (*, *) "[debug] <Kon> = ", Kon
  ! write (*, *) "[debug] <Ton> = ", Ton
  ! !! debug: end
end subroutine tmatrix_solver

!A subroutine provided for you to set up the kgrid and kweights
!note: the kgrid is setup with the on-shell point in the first element
!      and the corresponding kweights include the integration weights
!      AND the Green's function
subroutine setup_kgrid(k,nkmax,Na,a,Nb,b,Np,p,kgrid,kweights)
  implicit none
  real*8, intent(in) :: k
  integer, intent(in) :: Na, Nb, Np
  integer, intent(in) :: nkmax
  real*8, intent(out) :: kgrid(nkmax), kweights(nkmax)
  integer :: nk
  real*8, intent(in) ::  a, b, p
  real*8 :: grid1(nkmax-1), weight1(nkmax-1)

  call kgrid_igor(0.0,k,a,Na,b,Nb,p,Np,nkmax-1,grid1,weight1)

  kgrid(1) = k
  kgrid(2:nkmax) = grid1
  kweights(1) = 0.0d0
  kweights(2:nkmax) = weight1
  do nk=2, nkmax
    kweights(nk) = 2.0d0* kweights(nk) / (k**2 - kgrid(nk)**2)
  enddo
end subroutine setup_kgrid


************************************************************************
* MATRIX PROCEDURES
* D. Everhart
************************************************************************
* The MIT License (MIT)
*
* Copyright (c) 2016 Daniel Everhart
*
* Permission is hereby granted, free of charge, to any person obtaining
* a copy of this software and associated documentation files (the
* "Software"), to deal in the Software without restriction, including
* without limitation the rights to use, copy, modify, merge, publish,
* distribute, sublicense, and/or sell copies of the Software, and to
* permit persons to whom the Software is furnished to do so, subject
* to the following conditions:
*
* The above copyright notice and this permission notice shall be
* included in all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
* EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
* IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
* CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
* TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
* SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
*
************************************************************************
* These subroutines have evolved significantly over the years.
* They began as a undergraduate classroom assignment, and evolved to
* what they are now.
*
* When writing code for numerical analysis, I inevitability have
* the need to do some matrix operations and most of the time, this
* includes matrix inversion.
*
* The PROGRAM and two (2) following SUBROUTINEs demonstrate how to use
* this module.  They may be commented out in order to compile this as a
* library.
************************************************************************
* AE 227 FALL 1994 - Wichita State University
*   MGAUSJ - Gauss-Jordan elimination
* AE 527 FALL 1996 - Wichita State University
*   MGAUSB - Gauss elimination with back substitution (more efficient)
* 2004 - PRESENT - Abstraction of procedures and cleanup.
* MAR 2016 - Cleanup and preparation of messages for use by others.
************************************************************************
      PROGRAM MTEST
      IMPLICIT NONE
      CALL SMTEST
      WRITE(*,*)
      CALL BNMK
  999 STOP
      END PROGRAM MTEST
************************************************************************
      SUBROUTINE BNMK
      IMPLICIT NONE
      INTEGER ROWS,COLS,SZ,STIME,ETIME,TM(9)
      PARAMETER (ROWS=600, COLS=2*ROWS, SZ=ROWS*COLS)
      DOUBLE PRECISION D(ROWS,COLS)
      DOUBLE PRECISION D1(ROWS,ROWS), D2(ROWS,ROWS)
      EQUIVALENCE (D1(1,1), D(1,1)), (D2(1,1), D(1,ROWS+1))
      DATA D /SZ*0D0/
*
      STIME = TIME()
      WRITE(*,810) 'START MGAUSJ'
      CALL MRND1(D1,ROWS*ROWS,0)
      CALL MIDEN(D2,ROWS,ROWS)
      CALL MGAUSJ(D,ROWS,COLS)
      ETIME = TIME()
      CALL GMTIME(ETIME-STIME, TM)
      WRITE(*,820) 'END MGAUSJ  ', TM(3),':',TM(2),':',TM(1)
*
      WRITE(*,*)
*
      STIME = TIME()
      WRITE(*,810) 'START MGAUSB'
      CALL MRND1(D1,ROWS*ROWS,0)
      CALL MIDEN(D2,ROWS,ROWS)
      CALL MGAUSB(D,ROWS,COLS)
      ETIME = TIME()
      CALL GMTIME(ETIME-STIME, TM)
      WRITE(*,820) 'END MGAUSB  ', TM(3),':',TM(2),':',TM(1)
*
  810 FORMAT('0*** ',A12)
  820 FORMAT('0*** ',A12,I2.2,A,I2.2,A,I2.2)
  999 RETURN
      END SUBROUTINE BNMK
************************************************************************
      SUBROUTINE SMTEST
      IMPLICIT NONE
      INTEGER COLS, ROWS, SZ
      INTEGER I, J
      PARAMETER (COLS=6, ROWS=3, SZ=COLS*ROWS)
      DOUBLE PRECISION D(ROWS,COLS), E(ROWS,ROWS)
      DOUBLE PRECISION D1(ROWS,ROWS), D2(ROWS,ROWS)
      EQUIVALENCE (D1(1,1), D(1,1)), (D2(1,1), D(1,4))
      DATA D /SZ*0D0/
*
      WRITE(6,910)
      WRITE(6,920)
      WRITE(6,910)
      WRITE(6,980)'MATRIX D IS COMPRISED OF D1 AND D2.'
      WRITE(6,980)'       [ D ] =  [ D1 | D2 ]'
      WRITE(6,980)'MATRIX E IS SQUARE DIMENSIONED THE SAME AS'
      WRITE(6,980)'            D1 AND D2'
      WRITE(6,910)
*
      WRITE(6,*)
      WRITE(6,990)'TESTING MINIT1 ON [D].'
      CALL MINIT1(D, COLS*ROWS, 1D0)
      CALL MPRT(D,ROWS,COLS)
*
      WRITE(6,*)
      WRITE(6,990)'TESTING MINIT2 ON [D].'
      CALL MINIT2(D, ROWS, COLS, 2D0)
      CALL MPRT(D,ROWS,COLS)
*
      WRITE(6,*)
      WRITE(6,990)'TESTING MRND1 ON [D1].'
      CALL MRND1(D1,ROWS*ROWS,0)
      CALL MPRT(D,ROWS,COLS)
*
      WRITE(6,*)
      WRITE(6,990)'TESTING MIDEN ON [D2].'
      CALL MIDEN(D2,ROWS,COLS)
      CALL MPRT(D,ROWS,COLS)
*
      WRITE(6,*)
      WRITE(6,990)'ZEROING ELEMENTS D(2,1), D(2,2), D(2,3)...'
      D(2,1) = 0D0
      D(2,2) = 0D0
      D(2,3) = 0D0
      CALL MPRT(D,ROWS,COLS)
*
      WRITE(6,*)
      WRITE(6,990)'RUNNING GAUSS-JORDAN ELIMINATION ON [D]'
      CALL MGAUSJ(D, ROWS, COLS)
      CALL MPRT(D,ROWS,COLS)
*
      WRITE(6,*)
      WRITE(6,990)'RANDOMIZE [D1].'
      CALL MRND1(D1,ROWS*ROWS,0)
      CALL MPRT(D,ROWS,COLS)
*
      WRITE(6,*)
      WRITE(6,990)'IDENTITY [D2].'
      CALL MIDEN(D2,ROWS,ROWS)
      CALL MPRT(D,ROWS,COLS)
*
**    Copy D1 into E
*
      DO 110, I=1,ROWS
      DO 110, J=1,ROWS
  110 E(I,J) = D1(I,J)
*
      WRITE(6,*)
      WRITE(6,990)'RUNNING GAUSS ELIMINATION AND BACK SUBSTITUTION ON'
     &             //' [D]'
      CALL MGAUSB(D, ROWS, COLS)
      CALL MPRT(D,ROWS,COLS)
*
      WRITE(6,*)
      WRITE(6,990)'MULTIPLYING MATRIX BY INVERSE [D1] = [D2] * [E]'
      CALL MMUL(D2,ROWS,ROWS,E,ROWS,ROWS,D1,ROWS,ROWS)
      CALL MPRT(D1,ROWS,ROWS)
*
  910 FORMAT('********************************************************'
     2       '************************')
  920 FORMAT('******************************* RUNNING UNIT TESTS '
     1       '*****************************')
  980 FORMAT(15X,A)
  990 FORMAT('0*** ',A)
  999 RETURN
      END SUBROUTINE SMTEST
************************************************************************
* MINIT1: Matrix INITialize 1-D
************************************************************************
* Initialize matrix elements to a value based on a single dimension.
* It matters not if the value is a 1, 2, N dimensional array, as long
* as the SZ does not overrun the array.
************************************************************************
*   M * Matrix to be initialized
*  SZ * Size of matrix
* VAL * Value to which matrix is initialized.
************************************************************************
      SUBROUTINE MINIT1(M, SZ, VAL)
      IMPLICIT NONE
      DOUBLE PRECISION M(*), VAL
      INTEGER SZ
      INTEGER I
      DO 110 I = 1, SZ
  110 M(I) = VAL
  999 RETURN
      END SUBROUTINE MINIT1
************************************************************************
* MINIT2: Matrix INITialize 2-D
************************************************************************
* Initialize matrix elements to a value based on a two dimensions.  It
* matters not if the value is a 1, 2, N dimensional array, as long as
* the product of ROWS X COLS does not overrun the array.
************************************************************************
*   M  * Matrix to be initialized
* ROWS * Rows (index 1)
* COLS * Columns (index 2)
* VAL  * Value to which matrix is initialized.
************************************************************************
      SUBROUTINE MINIT2(M, ROWS, COLS, VAL)
      IMPLICIT NONE
      DOUBLE PRECISION M(ROWS,COLS), VAL
      INTEGER COLS, ROWS
      INTEGER I, J
      DO 110 I = 1, ROWS
      DO 110 J = 1, COLS
  110 M(I,J) = VAL
  999 RETURN
      END SUBROUTINE MINIT2
************************************************************************
* MIDEN: Matrix IDENtity
************************************************************************
* Initializes given matrix as an identity based on the rows and columns.
* Identity matricies are necessarily square.  However, this procedure
* does not require that ROWS .EQ. COLS.  All elements on the diagonal
* (A(I,J) where I.EQ.J) are initialized to 1D0, and all other element
* are set to 0D0.
************************************************************************
*   M  * Matrix to be initialized to identity.
* ROWS * Rows (index 1)
* COLS * Columns (index 2)
************************************************************************
      SUBROUTINE MIDEN(M,ROWS,COLS)
      IMPLICIT NONE
      DOUBLE PRECISION M(ROWS,COLS)
      INTEGER ROWS,COLS
      INTEGER I, J
      DO 110 I = 1, ROWS
      DO 110 J = 1, COLS
      IF (I.EQ.J) THEN
        M(I,J) = 1D0
      ELSE
        M(I,J) = 0D0
      END IF
  110 CONTINUE
  999 RETURN
      END SUBROUTINE MIDEN
************************************************************************
* MRND1: Matrix RaNDomize 1-D
************************************************************************
* Initialize matrix elements to a random value based on a single
* dimension. It matters not if the value is a 1, 2, N dimensional
* array, as long as the SZ does not overrun the array.
************************************************************************
*   M  * Matrix to be initialized
*  SZ  * Size of matrix
* SEED * Seed for random number generator
************************************************************************
      SUBROUTINE MRND1(M,SZ,SEED)
      IMPLICIT NONE
      DOUBLE PRECISION M(*), VAL
      INTEGER SZ,SEED
      INTEGER I
      CALL SRAND(SEED)
      DO 110 I = 1,SZ
  110 M(I) = DBLE(RAND())
  999 RETURN
      END SUBROUTINE MRND1
************************************************************************
* MRND2: Matrix RaNDomize 2-D
************************************************************************
* Initialize matrix elements to a random value based on a two
* dimensions.  It matters not if the value is a 1, 2, N dimensional
* array, as long as the product of ROWS X COLS does not overrun
* the array.
************************************************************************
*   M  * Matrix to be initialized
* ROWS * Rows (index 1)
* COLS * Columns (index 2)
* SEED * Seed for random number generator
************************************************************************
      SUBROUTINE MRND2(M,ROWS,COLS,SEED)
      IMPLICIT NONE
      DOUBLE PRECISION M(ROWS,COLS)
      INTEGER COLS,ROWS,SEED
      INTEGER I,J
      CALL SRAND(SEED)
      DO 110 I = 1,ROWS
      DO 110 J = 1,COLS
  110 M(I,J) = DBLE(RAND())
  999 RETURN
      END SUBROUTINE MRND2
************************************************************************
* MGJAUS: Matrix GAUSs-Jordan elimination
************************************************************************
*    M : Matrix
* ROWS : Number of rows
* COLS : Number of columns
************************************************************************
* Consider the matrix below representing the system of equations:
*
*                          [A]*[x] = B
*
*                | A11 A12 A13 A14 A15 B16 B17 |
*                | A21 A22 A23 A24 A25 B26 B27 |
*                | A31 A32 A33 A34 A35 B36 B37 |
*                | A41 A42 A43 A44 A45 B46 B47 |
*                | A51 A52 A53 A54 A55 B56 B57 |
*
* This procedure performs Gauss-Jordan elimination with repeated calls
* to MGJECOL to zero out non-diagonal elements, and normalize to 1.0
* resulting in the following:
*
*                | 1.0 0.0 0.0 0.0 0.0 X16 X17 |
*                | 0.0 1.0 0.0 0.0 0.0 X26 X27 |
*                | 0.0 0.0 1.0 0.0 0.0 X36 X37 |
*                | 0.0 0.0 0.0 1.0 0.0 X46 X47 |
*                | 0.0 0.0 0.0 0.0 1.0 X56 X57 |
*
* X values are where the solution matrix is stored.
*
************************************************************************
      SUBROUTINE MGAUSJ(M, ROWS, COLS)
      IMPLICIT NONE
      DOUBLE PRECISION M(ROWS,COLS),TMP
      INTEGER ROWS, COLS
      INTEGER I,J
*
      IF (ROWS.GT.COLS) THEN
        WRITE(0,910), ROWS, COLS
        STOP
      END IF
*
      DO 110 I = 1, ROWS
      CALL MPPVT(M,ROWS,COLS,I)
      CALL MGJECOL(M,ROWS,COLS,I)
      TMP = M(I,I)
      DO 110 J = I, COLS
      M(I,J) = M(I,J) / TMP
  110 CONTINUE
*
  910 FORMAT('*** FATAL ERRROR: MGAUSJ: MATRIX ROWS LARGER THAN'
     1' COLUMNS',/,18X,I8, '   .GT.   ',I8)
  999 RETURN
      END SUBROUTINE
************************************************************************
* MGAUSB: Matrix GAUSs elimination with Back substitution
************************************************************************
*    M : Matrix
* ROWS : Number of rows
* COLS : Number of columns
************************************************************************
* Consider the matrix below representing the system of equations:
*
*                          [A]*[x] = B
*
*                | A11 A12 A13 A14 A15 B16 B17 |
*                | A21 A22 A23 A24 A25 B26 B27 |
*                | A31 A32 A33 A34 A35 B36 B37 |
*                | A41 A42 A43 A44 A45 B46 B47 |
*                | A51 A52 A53 A54 A55 B56 B57 |
*
* This procedure performs Gauss elimination with repeated calls
* to MGECOL leave an upper triangle matrix.  Junk values are left in
* place below the diagonal to save operations.  This results in the
* following:
*
*                | A11 A12 A13 A14 A15 B16 B17 |
*                | JNK A22 A23 A24 A25 B26 B27 |
*                | JNK JNK A33 A34 A35 B36 B37 |
*                | JNK JNK JNK A44 A45 B46 B47 |
*                | JNK JNK JNK JNK A55 B56 B57 |
*
* The final step is to perform back substitution callin MBSUB resulting
* in the following:
*
*                | A11 A12 A13 A14 A15 X16 X17 |
*                | JNK A22 A23 A24 A25 X26 X27 |
*                | JNK JNK A33 A34 A35 X36 X37 |
*                | JNK JNK JNK A44 A45 X46 X47 |
*                | JNK JNK JNK JNK A55 X56 X57 |
*
* X values are where the solution matrix is stored.
*
************************************************************************
      SUBROUTINE MGAUSB(M, ROWS, COLS)
      IMPLICIT NONE
      DOUBLE PRECISION M(ROWS,COLS)
      INTEGER ROWS, COLS
      INTEGER I
*
      IF (ROWS.GT.COLS) THEN
        WRITE(0,910), ROWS, COLS
        STOP
      END IF
*
      CALL MGAUS(M,ROWS,COLS)
      CALL MBSUB(M,ROWS,COLS)
*
  910 FORMAT('*** FATAL ERRROR: MGAUSB: MATRIX ROWS LARGER THAN'
     1' COLUMNS',/,18X,I8, '   .GT.   ',I8)
  999 RETURN
      END SUBROUTINE
************************************************************************
* MGAUS: Matrix GAUSs elimination
************************************************************************
*    M : Matrix
* ROWS : Number of rows
* COLS : Number of columns
************************************************************************
* Consider the matrix below representing the system of equations:
*
*                          [A]*[x] = B
*
*                | A11 A12 A13 A14 A15 B16 B17 |
*                | A21 A22 A23 A24 A25 B26 B27 |
*                | A31 A32 A33 A34 A35 B36 B37 |
*                | A41 A42 A43 A44 A45 B46 B47 |
*                | A51 A52 A53 A54 A55 B56 B57 |
*
* This procedure performs Gauss elimination with repeated calls
* to MGECOL leave an upper triangle matrix.  Junk values are left in
* place below the diagonal to save operations.  This results in the
* following:
*
*                | A11 A12 A13 A14 A15 B16 B17 |
*                | JNK A22 A23 A24 A25 B26 B27 |
*                | JNK JNK A33 A34 A35 B36 B37 |
*                | JNK JNK JNK A44 A45 B46 B47 |
*                | JNK JNK JNK JNK A55 B56 B57 |
*
************************************************************************
      SUBROUTINE MGAUS(M, ROWS, COLS)
      IMPLICIT NONE
      DOUBLE PRECISION M(ROWS,COLS)
      INTEGER ROWS, COLS
      INTEGER I
*
      IF (ROWS.GT.COLS) THEN
        WRITE(0,910), ROWS, COLS
        STOP
      END IF
*
      DO 110 I = 1, ROWS
      CALL MPPVT(M,ROWS,COLS,I)
  110 CALL MGECOL(M,ROWS,COLS,I)
*
  910 FORMAT('*** FATAL ERRROR: MGAUS: MATRIX ROWS LARGER THAN'
     1' COLUMNS',/,18X,I8, '   .GT.   ',I8)
  999 RETURN
      END SUBROUTINE
************************************************************************
* MPPVT: Matrix Partial PiVoT
************************************************************************
      SUBROUTINE MPPVT(M,ROWS,COLS,ROW)
      IMPLICIT NONE
      DOUBLE PRECISION M(ROWS,COLS)
      INTEGER COLS,ROWS,ROW
      INTEGER J,K
      DOUBLE PRECISION TOL,TMP
      PARAMETER (TOL=1.0D-12)
*
      IF (ABS(M(ROW,ROW)).LE.TOL) THEN
      DO 110 J = ROW+1, ROWS
  110 IF (ABS(M(J,ROW)).GE.TOL) EXIT
      DO 120 K = ROW,COLS
      TMP = M(ROW,K)
      M(ROW,K) = M(J,K)
  120 M(J,K) = TMP
      END IF
  999 RETURN
      END SUBROUTINE MPPVT
************************************************************************
* MGJECOL: Matrix Gauss-Jordan Eliminate COLumn
************************************************************************
* Performs Gauss elimination on a particular column.  This procedure is
* called multiple times to columns for Gauss-Jordan elimination.
* Consider the following matrix:
*
*                | A11 A12 A13 A14 A15 A16 A17 |
*                | 0.0 A22 A23 A24 A25 A26 A27 |
*                | 0.0 A32 A33 A34 A35 A36 A37 |
*                | 0.0 A42 A43 A44 A45 A46 A47 |
*                | 0.0 A52 A53 A54 A55 A56 A57 |
*
*
*   Column 2 is the next to be zeroed.  This is done by repeated calls
*   to MGJEROW.  The result is the following:
*
*                | A11 0.0 A13 A14 A15 A16 A17 |
*                | 0.0 A22 A23 A24 A25 A26 A27 |
*                | 0.0 0.0 A33 A34 A35 A36 A37 |
*                | 0.0 0.0 A43 A44 A45 A46 A47 |
*                | 0.0 0.0 A53 A54 A55 A56 A57 |
*
*   Note:  This procedure calls MGJEROW for every row in the matrix.
*   Repeated calls, result in a matrix with non-zero values only on
*   the diagonal.  This is less efficient that elimination resulting
*   in a upper diagonal matrix to be used for backward substitution.
*
************************************************************************
*    M : Matrix
* ROWS : Matrix rows
* COLS : Matrix columns
*  COL : Associated column to be zeroed for elimination.
************************************************************************
      SUBROUTINE MGJECOL(M,ROWS,COLS,COL)
      IMPLICIT NONE
      DOUBLE PRECISION M(ROWS,COLS)
      INTEGER ROWS,COLS,COL
      INTEGER J
*
      DO 110 J = 1, ROWS
  110 IF (J.NE.COL) CALL MGEROW(M,ROWS,COLS,J,COL,1)
  999 RETURN
      END SUBROUTINE MGJECOL
************************************************************************
* MGECOL: Matrix Gauss Eliminate COLumn
************************************************************************
* Performs Gauss elimination on a particular column.  This procedure is
* called multiple times to columns for Gauss-Jordan elimination.
* Consider the following matrix:
*
*                | A11 A12 A13 A14 A15 A16 A17 |
*                | JNK A22 A23 A24 A25 A26 A27 |
*                | JNK A32 A33 A34 A35 A36 A37 |
*                | JNK A42 A43 A44 A45 A46 A47 |
*                | JNK A52 A53 A54 A55 A56 A57 |
*
*
*   Column 2 is the next to be 'zeroed'.  This is done by repeated calls
*   to MGEROW with SCOL=COL+1.  The result is the following:
*
*                | A11 A12 A13 A14 A15 A16 A17 |
*                | JNK A22 A23 A24 A25 A26 A27 |
*                | JNK JNK A33 A34 A35 A36 A37 |
*                | JNK JNK A43 A44 A45 A46 A47 |
*                | JNK JNK A53 A54 A55 A56 A57 |
*
*   Note:  This procedure calls MGEROW for rows below the diagonal at
*   the particular column in the matrix.
*
*   Repeated calls, result in a matrix with junk (JNK) values below
*   the diagonal and actuals values on and above the diagonal.  The
*   junk values are left in place to save operations for large systems.
*
************************************************************************
*    M : Matrix
* ROWS : Matrix rows
* COLS : Matrix columns
*  COL : Associated column to be zeroed for elimination.
************************************************************************
      SUBROUTINE MGECOL(M,ROWS,COLS,COL)
      IMPLICIT NONE
      DOUBLE PRECISION M(ROWS,COLS)
      INTEGER ROWS,COLS,COL
      INTEGER J
*
      DO 110 J = COL+1, ROWS
  110 CALL MGEROW(M,ROWS,COLS,J,COL,COL+1)
  999 RETURN
      END SUBROUTINE MGECOL
************************************************************************
* MGJEROW: Matrix Gauss-Jordan Eliminate ROW
************************************************************************
* Performs Gauss elimination on a particular row.  This procedure is
* called multiple times to eliminate a particular column. Consider
* the following matrix:
*
*                | A11 A12 A13 A14 A15 A16 A17 |
*                | 0.0 A22 A23 A24 A25 A26 A27 |
*                | 0.0 A32 A33 A34 A35 A36 A37 |
*                | 0.0 A42 A43 A44 A45 A46 A47 |
*                | 0.0 A52 A53 A54 A55 A56 A57 |
*
*   Row 3, column 2 is the next to be zeroed.  This is done by
*   subtracting a scaled row 2 from row 3.  Scale factor RATIO is
*   calculated by:
*
*                        RATIO = A32 / A22
*
*   This ratio is chosen so that the result at row 3, column 2 will
*   calculate to zero.
*
*                  A32 = A32 - A22 * A32 / A22  (Results in 0.0)
*                  A33 = A33 - A23 * A32 / A22
*                  A34 = A34 - A24 * A32 / A22
*                  A35 = A35 - A25 * A32 / A22
*                  A36 = A36 - A26 * A32 / A22
*                  A37 = A37 - A27 * A32 / A22
*
*   The resulting state of the matrix after this procedure is:
*
*                | A11 A12 A13 A14 A15 A16 A17 |
*                | 0.0 A22 A23 A24 A25 A26 A27 |
*                | 0.0 0.0 A33 A34 A35 A36 A37 |
*                | 0.0 A42 A43 A44 A45 A46 A47 |
*                | 0.0 A52 A53 A54 A55 A56 A57 |
*
*   Note:  This procedure does not require that ROW .GT. COL.  The
*   result is that in the above example, the same operation could be
*   performed on row 1 to zero out A12.  This is useful if the
*   elimination is Gauss-Jordan where all elements not on the diagonal
*   are zeroed out.
*
*   Additionally, this procedure is called with a starting column. To
*   save operations, the start column may be set to COL+1 when calling
*   and nothing will be done to the elements to the left of COL.  This
*   is useful when reducing the matrix to a upper triangle matrix.
*
************************************************************************
*    M : Matrix
* ROWS : Matrix rows
* COLS : Matrix columns
*  ROW : Matrix row on which to perform elimination
*  COL : Associated column to be zeroed for elimination.
* SCOL : Column to begin elimination
************************************************************************
      SUBROUTINE MGEROW(M,ROWS,COLS,ROW,COL,SCOL)
      IMPLICIT NONE
      DOUBLE PRECISION M(ROWS,COLS)
      INTEGER ROWS,COLS,ROW,COL,SCOL
      DOUBLE PRECISION TOL,RATIO
      PARAMETER (TOL=1.0D-12)
      INTEGER I,J
*
      IF (ABS(M(ROW,COL)).GE.TOL) THEN
        RATIO = M(ROW,COL) / M(COL,COL)
        DO 110 I = SCOL, COLS
        IF (I.EQ.COL) THEN
*
** By definition this location must be zero.  Instead of doing the
** calculation, just set the value to zero.
*
          M(ROW,I) = 0D0
        ELSE
          M(ROW,I) = M(ROW,I) - RATIO * M(COL,I)
        ENDIF
  110   CONTINUE
      ELSE
        M(ROW,COL) = 0D0
      END IF
  999 RETURN
      END SUBROUTINE MGEROW
************************************************************************
* MBSUB: Matrix Back SUBstitution
************************************************************************
* Consider the reduced system.
*
*                | A11 A12 A13 A14 A15 B16 B17 |
*                | JNK A22 A23 A24 A25 B26 B27 |
*                | JNK JNK A33 A34 A35 B36 B37 |
*                | JNK JNK JNK A44 A45 B46 B47 |
*                | JNK JNK JNK JNK A55 B56 B57 |
*
* JNK values are assumed to be 0.0.  Recall that this is a set
* of equations for each B column vector:
*
*      A11*X16 + A12*X26 + A13*X36 + A14*X46 + A15*X56 = B16
*                A22*X26 + A23*X36 + A24*X46 + A25*X56 = B26
*                          A33*X36 + A34*X46 + A35*X56 = B36
*                                    A44*X46 + A45*X56 = B46
*                                              A55*X56 = B56
*
*      A11*X17 + A12*X27 + A13*X37 + A14*X47 + A15*X57 = B17
*                A22*X27 + A23*X37 + A24*X47 + A25*X57 = B27
*                          A33*X37 + A34*X47 + A35*X57 = B37
*                                    A44*X47 + A45*X57 = B47
*                                              A55*X57 = B57
*
* These equations may be solved starting from the bottom:
*
*                          <------------- K --------------->
*
*  |  |     X56 = (B56                                        ) / A55
*  |  |     X46 = (B46 - A45*X56                              ) / A44
*  |  J     X36 = (B36 - A34*X46 - A35*X56                    ) / A33
*  |  |     X26 = (B26 - A23*X36 - A24*X46 - A25*X56          ) / A22
*  |  v     X16 = (B16 - A12*X26 - A13*X36 - A14*X46 - A15*X56) / A11
*  I
*  |  |     X57 = (B57                                        ) / A55
*  |  |     X47 = (B47 - A45*X57                              ) / A44
*  |  J     X37 = (B37 - A34*X47 - A35*X57                    ) / A33
*  |  |     X27 = (B27 - A23*X37 - A24*X47 - A25*X57          ) / A22
*  v  v     X17 = (B17 - A12*X27 - A13*X37 - A14*X47 - A15*X57) / A11
*
* The resulting aray has the solution vectors in place of the B
* vectors.
*
*                | A11 A12 A13 A14 A15 X16 X17 |
*                | JNK A22 A23 A24 A25 X26 X27 |
*                | JNK JNK A33 A34 A35 X36 X37 |
*                | JNK JNK JNK A44 A45 X46 X47 |
*                | JNK JNK JNK JNK A55 X56 X57 |
*
************************************************************************
*    M : Matrix
* ROWS : Matrix rows
* COLS : Matrix columns
************************************************************************
      SUBROUTINE MBSUB(M,ROWS,COLS)
      IMPLICIT NONE
      DOUBLE PRECISION M(ROWS,COLS)
      INTEGER ROWS,COLS
      INTEGER I,J,K
      DOUBLE PRECISION SUM
*
      DO 110 I = ROWS+1, COLS
      DO 110 J = ROWS, 1, -1
      SUM = 0D0
      DO 120 K = ROWS, J+1, -1
  120 SUM = SUM + M(J,K) * M(K,I)
  110 M(J,I) = (M(J,I) - SUM) / M(J,J)
  999 RETURN
      END SUBROUTINE MBSUB
************************************************************************
* MMUL:  Matrix Multipliction
************************************************************************
* Product of [A]*[B] is placed in P.
************************************************************************
* A     : Matrix A
* AROWS : Rows of A
* ACOLS : Cols of A (Must match BROWS)
* B     : Matrix B
* BROWS : Rows of B (Must match ACOLS)
* BCOLS : Cols of B
* P     : Matrix P (product: [P] = [A] * [B])
* PROWS : Rows of P (Must be .GE. AROWS)
* PCOLS : Cols of P (Must be .GE. BCOLS)
************************************************************************
*
*          [A]     *         [B]         =         [P]
*
*      | A11 A12 |   | B11 B12 B13 B14 |   | P11 P12 P13 P14 |
*      | A21 A22 | * | B21 B22 B23 B12 | = | P21 P22 P23 P24 |
*      | A31 A32 |                         | P31 P32 P33 P34 |
*
*
*                      <-------- K -------->
*
*                P11 = A11 * B11 + A12 * B21   ^   ^
*                P21 = A21 * B11 + A22 * B21   I   |
*                P31 = A31 * B11 + A32 * B21   v   |
*                                                  |
*                P12 = A11 * B12 + A12 * B22   ^   |
*                P22 = A21 * B12 + A22 * B22   I   |
*                P32 = A31 * B12 + A32 * B22   v
*                                                  J
*                P13 = A11 * B13 + A12 * B23   ^
*                P23 = A21 * B13 + A22 * B23   I   |
*                P33 = A31 * B13 + A32 * B23   v   |
*                                                  |
*                P14 = A11 * B14 + A12 * B24   ^   |
*                P24 = A21 * B14 + A22 * B24   I   |
*                P34 = A31 * B14 + A32 * B24   v   v
*
************************************************************************
      SUBROUTINE MMUL(A,AROWS,ACOLS,B,BROWS,BCOLS,P,PROWS,PCOLS)
      IMPLICIT NONE
      DOUBLE PRECISION A(AROWS,ACOLS), B(BROWS,BCOLS), P(PROWS,PCOLS)
      INTEGER AROWS, ACOLS, BROWS, BCOLS, PSIZE, PROWS, PCOLS
      INTEGER I, J, K
      DOUBLE PRECISION SUM
*
      IF (ACOLS.NE.BROWS) THEN
      WRITE(0,910) ACOLS, BROWS
      STOP
      END IF
      IF (PROWS.LT.AROWS) THEN
      WRITE(0,920) PROWS, AROWS
      STOP
      END IF
      IF (PCOLS.LT.BCOLS) THEN
      WRITE(0,930) PCOLS, BCOLS
      STOP
      END IF
*
      DO 10 I = 1, PROWS
      DO 10 J = 1, PCOLS
      SUM = 0D0
      DO 20 K = 1, ACOLS
   20 SUM = SUM + A(I,K) * B(K,J)
   10 P(I,J) = SUM
*
  910 FORMAT('*** FATAL ERRROR: MMUL: MATRIX A COLUMNS MUST MATCH'
     1' MATRIX B ROWS:',/,18X,I8, '   .NE.   ', I8)
  920 FORMAT('*** FATAL ERRROR: MMUL: MATRIX P ROWS MUST AT LEAST'
     1' EQUAL MATRIX A ROWS:',/,18X,I8, '   .LT.   ', I8)
  930 FORMAT('*** FATAL ERRROR: MMUL: MATRIX P COLUMNS MUST AT LEAST'
     1' EQUAL MATRIX B COLUMNS:',/,18X,I8, '   .LT.   ', I8)
  999 RETURN
      END SUBROUTINE MMUL
************************************************************************
* MIPADD: Matrix In-Place ADDition
************************************************************************
      SUBROUTINE MIPADD(A,AROWS,ACOLS,B,BROWS,BCOLS)
      IMPLICIT NONE
      DOUBLE PRECISION A(AROWS,ACOLS),B(BROWS,BCOLS)
      INTEGER AROWS,ACOLS,BROWS,BCOLS
      INTEGER I,J
*
      DO 110 I = 1, MIN(AROWS,BROWS)
      DO 110 J = 1, MIN(ACOLS,BCOLS)
  110 A(I,J) = A(I,J) + B(I,J)
  999 RETURN
      END SUBROUTINE MIPADD
************************************************************************
* MIPSUB: Matrix In-Place SUBtraction
************************************************************************
      SUBROUTINE MIPSUB(A,AROWS,ACOLS,B,BROWS,BCOLS)
      IMPLICIT NONE
      DOUBLE PRECISION A(AROWS,ACOLS),B(BROWS,BCOLS)
      INTEGER AROWS,ACOLS,BROWS,BCOLS
      INTEGER I,J
*
      DO 110 I = 1, MIN(AROWS,BROWS)
      DO 110 J = 1, MIN(ACOLS,BCOLS)
  110 A(I,J) = A(I,J) + B(I,J)
  999 RETURN
      END SUBROUTINE MIPSUB
************************************************************************
* MPRT: Matrix PRinT
************************************************************************
      SUBROUTINE MPRT(M,ROWS,COLS)
      IMPLICIT NONE
      DOUBLE PRECISION M(ROWS,COLS)
      INTEGER ROWS, COLS
      INTEGER I, J
      CHARACTER F*9
*
      WRITE(F,'(A1I2A6)') '(', COLS, 'F10.4)'
      DO 10 I = 1, ROWS
   10 WRITE(6,F) (M(I,J), J=1, COLS)
  999 RETURN
      END SUBROUTINE MPRT
************************************************************************


module mod_monolis_c2d4_shape
  use mod_monolis_prm
  use mod_monolis_shape_util
  implicit none

  private

  real(kdouble), parameter :: gsp(2,4) = reshape([ &
    -0.577350269189626d0,-0.577350269189626d0, &
     0.577350269189626d0,-0.577350269189626d0, &
    -0.577350269189626d0, 0.577350269189626d0, &
     0.577350269189626d0, 0.577350269189626d0  &
    ], [2,4])

  real(kdouble), parameter :: np(2,4) = reshape([ &
     -1.0d0, -1.0d0, &
      1.0d0, -1.0d0, &
      1.0d0,  1.0d0, &
     -1.0d0,  1.0d0  &
    ], [2,4])

    public :: monolis_C2D4_num_gauss_point
    public :: monolis_C2D4_weight
    public :: monolis_C2D4_integral_point
    public :: monolis_C2D4_node_point
    public :: monolis_C2D4_shapefunc
    public :: monolis_C2D4_shapefunc_deriv
    public :: monolis_C2D4_get_global_position
    public :: monolis_C2D4_get_global_deriv

contains

  function monolis_C2D4_num_gauss_point()
    implicit none
    integer(kint) :: monolis_C2D4_num_gauss_point
    monolis_C2D4_num_gauss_point = 4
  end function monolis_C2D4_num_gauss_point

  function monolis_C2D4_weight(i)
    implicit none
    integer(kint), optional :: i
    real(kdouble) :: monolis_C2D4_weight
    monolis_C2D4_weight = 1.0d0
  end function monolis_C2D4_weight

  subroutine monolis_C2D4_integral_point(i, r)
    implicit none
    integer(kint) :: i
    real(kdouble) :: r(2)

    r(1) = gsp(1,i)
    r(2) = gsp(2,i)
  end subroutine monolis_C2D4_integral_point

  subroutine monolis_C2D4_node_point(i, r)
    implicit none
    integer(kint) :: i
    real(kdouble) :: r(2)

    r(1) = np(1,i)
    r(2) = np(2,i)
  end subroutine monolis_C2D4_node_point

  subroutine monolis_C2D4_get_global_position(node, r, pos)
    implicit none
    real(kdouble) :: node(3,4), r(2), pos(3)
    real(kdouble) :: func(4)

    call monolis_C2D4_shapefunc(r, func)
    pos = matmul(node, func)
  end subroutine monolis_C2D4_get_global_position

  subroutine monolis_C2D4_get_global_deriv(node, r, dndx, det)
    implicit none
    real(kdouble) :: node(2,4), r(2), dndx(4,2), deriv(4,2)
    real(kdouble) :: xj(2,2), inv(2,2), det

    call monolis_C2D4_shapefunc_deriv(r, deriv)
    xj = matmul(node, deriv)
    call monolis_get_inverse_matrix_2d(xj, inv, det)
    dndx = matmul(deriv, inv)
  end subroutine monolis_C2D4_get_global_deriv

  subroutine monolis_C2D4_shapefunc(local, func)
    implicit none
    real(kdouble) :: local(2), func(4)

    func(1) = 0.25d0*(1.0d0-local(1))*(1.0d0-local(2))
    func(2) = 0.25d0*(1.0d0+local(1))*(1.0d0-local(2))
    func(3) = 0.25d0*(1.0d0+local(1))*(1.0d0+local(2))
    func(4) = 0.25d0*(1.0d0-local(1))*(1.0d0+local(2))
  end subroutine monolis_C2D4_shapefunc

  subroutine monolis_C2D4_shapefunc_deriv(local, func)
    implicit none
    real(kdouble) :: local(2), func(4,2)

    func(1,1) = -0.25d0*(1.0d0-local(2))
    func(2,1) =  0.25d0*(1.0d0-local(2))
    func(3,1) =  0.25d0*(1.0d0+local(2))
    func(4,1) = -0.25d0*(1.0d0+local(2))

    func(1,2) = -0.25d0*(1.0d0-local(1))
    func(2,2) = -0.25d0*(1.0d0+local(1))
    func(3,2) =  0.25d0*(1.0d0+local(1))
    func(4,2) =  0.25d0*(1.0d0-local(1))
  end subroutine monolis_C2D4_shapefunc_deriv

end module mod_monolis_c2d4_shape