!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Makes local spectral grid.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] nn_loc number of local node
!> @param[in,out] xx_loc x-coordinate of GLL node
!> @param[in,out] yy_loc y-coordinate of GLL node
!> @param[in,out] zz_loc z-coordinate of GLL node
!> @param[in] cs_nnz_loc length of cs_loc
!> @param[in] cs_loc  local spectral connectivity vector
!> @param[in] nm number of materials
!> @param[in] tm material labels
!> @param[in] sd polynomial degree vector
!> @param[in] loc_n_num  local node numeration
!> @param[in] ne_loc number of local elements
!> @param[out] alfa11 costant values for the bilinear map
!> @param[out] alfa12 costant values for the bilinear map
!> @param[out] alfa13 costant values for the bilinear map
!> @param[out] alfa21 costant values for the bilinear map
!> @param[out] alfa22 costant values for the bilinear map
!> @param[out] alfa23 costant values for the bilinear map
!> @param[out] alfa31 costant values for the bilinear map
!> @param[out] alfa32 costant values for the bilinear map
!> @param[out] alfa33 costant values for the bilinear map
!> @param[out] beta11 costant values for the bilinear map
!> @param[out] beta12 costant values for the bilinear map
!> @param[out] beta13 costant values for the bilinear map
!> @param[out] beta21 costant values for the bilinear map
!> @param[out] beta22 costant values for the bilinear map
!> @param[out] beta23 costant values for the bilinear map
!> @param[out] beta31 costant values for the bilinear map
!> @param[out] beta32 costant values for the bilinear map
!> @param[out] beta33 costant values for the bilinear map
!> @param[out] gamma1 costant values for the bilinear map
!> @param[out] gamma2 costant values for the bilinear map
!> @param[out] gamma3 costant values for the bilinear map
!> @param[out] delta1 costant values for the bilinear map
!> @param[out] delta2 costant values for the bilinear map
!> @param[out] delta3 costant values for the bilinear map

      subroutine MAKE_SPX_GRID_LOC(nn_loc, xx_loc, yy_loc, zz_loc, &
                               cs_nnz_loc, cs_loc, nm, tm, sd, ne_loc, loc_n_num, &
                               alfa11,alfa12,alfa13, &
                               alfa21,alfa22,alfa23, &
                               alfa31,alfa32,alfa33, &
                               beta11,beta12,beta13, &
                               beta21,beta22,beta23, &
                               beta31,beta32,beta33, &
                               gamma1,gamma2,gamma3, &
                               delta1,delta2,delta3 )

      use speed_exit_codes

      implicit none

      integer*4 :: nn_loc, cs_nnz_loc,nm, ne_loc
      integer*4 :: n1,n2,n3,n4,n5,n6,n7,n8
      integer*4 :: ic1,ic2,ic3,ic4,ic5,ic6,ic7,ic8
      integer*4 :: im,ie,i,j,k,nn,ip, ic

      integer*4, dimension(nn_loc) :: loc_n_num
      integer*4, dimension(0:cs_nnz_loc) :: cs_loc
      integer*4, dimension(nm) :: tm
      integer*4, dimension(nm) :: sd

      real*8 :: xp,yp,zp,jac
      real*8 :: x1,x2,x3,x4,x5,x6,x7,x8
      real*8 :: y1,y2,y3,y4,y5,y6,y7,y8
      real*8 :: z1,z2,z3,z4,z5,z6,z7,z8

      real*8, dimension(:), allocatable :: ct,ww
      real*8, dimension(ne_loc) :: alfa11,alfa12,alfa13
      real*8, dimension(ne_loc) :: alfa21,alfa22,alfa23
      real*8, dimension(ne_loc) :: alfa31,alfa32,alfa33
      real*8, dimension(ne_loc) :: beta11,beta12,beta13
      real*8, dimension(ne_loc) :: beta21,beta22,beta23
      real*8, dimension(ne_loc) :: beta31,beta32,beta33
      real*8, dimension(ne_loc) :: gamma1,gamma2,gamma3
      real*8, dimension(ne_loc) :: delta1,delta2,delta3
      real*8, dimension(nn_loc), intent(inout) :: xx_loc,yy_loc,zz_loc

      real*8, dimension(:,:), allocatable :: dd

      nn = 2
      allocate(ct(nn),ww(nn),dd(nn,nn))
      call MAKE_LGL_NW(nn,ct,ww,dd)

      do im = 1,nm
         if ((sd(im) +1).ne.nn) then
            deallocate(ct,ww,dd)
            nn = sd(im) +1
            allocate(ct(nn),ww(nn),dd(nn,nn))
            call MAKE_LGL_NW(nn,ct,ww,dd)
         endif

         do ie = 1,ne_loc
            if (cs_loc(cs_loc(ie -1) +0).eq.tm(im)) then
               n1 = nn*nn*(1 -1) +nn*(1 -1) +1
               n2 = nn*nn*(1 -1) +nn*(1 -1) +nn
               n3 = nn*nn*(1 -1) +nn*(nn -1) +nn
               n4 = nn*nn*(1 -1) +nn*(nn -1) +1
               n5 = nn*nn*(nn -1) +nn*(1 -1) +1
               n6 = nn*nn*(nn -1) +nn*(1 -1) +nn
               n7 = nn*nn*(nn -1) +nn*(nn -1) +nn
               n8 = nn*nn*(nn -1) +nn*(nn -1) +1

               ic1 = cs_loc(cs_loc(ie -1) +n1)
               ic2 = cs_loc(cs_loc(ie -1) +n2)
               ic3 = cs_loc(cs_loc(ie -1) +n3)
               ic4 = cs_loc(cs_loc(ie -1) +n4)
               ic5 = cs_loc(cs_loc(ie -1) +n5)
               ic6 = cs_loc(cs_loc(ie -1) +n6)
               ic7 = cs_loc(cs_loc(ie -1) +n7)
               ic8 = cs_loc(cs_loc(ie -1) +n8)

               x1 = xx_loc(ic1)
               y1 = yy_loc(ic1)
               z1 = zz_loc(ic1)

               x2 = xx_loc(ic2)
               y2 = yy_loc(ic2)
               z2 = zz_loc(ic2)

               x3 = xx_loc(ic3)
               y3 = yy_loc(ic3)
               z3 = zz_loc(ic3)

               x4 = xx_loc(ic4)
               y4 = yy_loc(ic4)
               z4 = zz_loc(ic4)

               x5 = xx_loc(ic5)
               y5 = yy_loc(ic5)
               z5 = zz_loc(ic5)

               x6 = xx_loc(ic6)
               y6 = yy_loc(ic6)
               z6 = zz_loc(ic6)

               x7 = xx_loc(ic7)
               y7 = yy_loc(ic7)
               z7 = zz_loc(ic7)

               x8 = xx_loc(ic8)
               y8 = yy_loc(ic8)
               z8 = zz_loc(ic8)

               alfa11(ie) = 0.125d0*(-x1 +x2 +x3 -x4 -x5 +x6 +x7 -x8)  !1/8 * e1
               alfa21(ie) = 0.125d0*(-y1 +y2 +y3 -y4 -y5 +y6 +y7 -y8)  !1/8 * e2
               alfa31(ie) = 0.125d0*(-z1 +z2 +z3 -z4 -z5 +z6 +z7 -z8)  !1/8 * e3

               alfa12(ie) = 0.125d0*(-x1 -x2 +x3 +x4 -x5 -x6 +x7 +x8)  !1/8 * f1
               alfa22(ie) = 0.125d0*(-y1 -y2 +y3 +y4 -y5 -y6 +y7 +y8)  !1/8 * f2
               alfa32(ie) = 0.125d0*(-z1 -z2 +z3 +z4 -z5 -z6 +z7 +z8)  !1/8 * f3

               alfa13(ie) = 0.125d0*(-x1 -x2 -x3 -x4 +x5 +x6 +x7 +x8)  !1/8 * g1
               alfa23(ie) = 0.125d0*(-y1 -y2 -y3 -y4 +y5 +y6 +y7 +y8)  !1/8 * g2
               alfa33(ie) = 0.125d0*(-z1 -z2 -z3 -z4 +z5 +z6 +z7 +z8)  !1/8 * g3

               beta11(ie) = 0.125d0*(+x1 +x2 -x3 -x4 -x5 -x6 +x7 +x8)  !1/8 * c1
               beta21(ie) = 0.125d0*(+y1 +y2 -y3 -y4 -y5 -y6 +y7 +y8)  !1/8 * c2
               beta31(ie) = 0.125d0*(+z1 +z2 -z3 -z4 -z5 -z6 +z7 +z8)  !1/8 * c3

               beta12(ie) = 0.125d0*(+x1 -x2 -x3 +x4 -x5 +x6 +x7 -x8)  !1/8 * d1
               beta22(ie) = 0.125d0*(+y1 -y2 -y3 +y4 -y5 +y6 +y7 -y8)  !1/8 * d2
               beta32(ie) = 0.125d0*(+z1 -z2 -z3 +z4 -z5 +z6 +z7 -z8)  !1/8 * d3

               beta13(ie) = 0.125d0*(+x1 -x2 +x3 -x4 +x5 -x6 +x7 -x8)  !1/8 * b1
               beta23(ie) = 0.125d0*(+y1 -y2 +y3 -y4 +y5 -y6 +y7 -y8)  !1/8 * b2
               beta33(ie) = 0.125d0*(+z1 -z2 +z3 -z4 +z5 -z6 +z7 -z8)  !1/8 * b3

               gamma1(ie) = 0.125d0*(-x1 +x2 -x3 +x4 +x5 -x6 +x7 -x8)  !1/8 * a1
               gamma2(ie) = 0.125d0*(-y1 +y2 -y3 +y4 +y5 -y6 +y7 -y8)  !1/8 * a2
               gamma3(ie) = 0.125d0*(-z1 +z2 -z3 +z4 +z5 -z6 +z7 -z8)  !1/8 * a3

               delta1(ie) = 0.125d0*(+x1 +x2 +x3 +x4 +x5 +x6 +x7 +x8)  !1/8 * h1
               delta2(ie) = 0.125d0*(+y1 +y2 +y3 +y4 +y5 +y6 +y7 +y8)  !1/8 * h2
               delta3(ie) = 0.125d0*(+z1 +z2 +z3 +z4 +z5 +z6 +z7 +z8)  !1/8 * h3

               jac = alfa31(ie)*(alfa12(ie)*alfa23(ie) -alfa13(ie)*alfa22(ie)) &
                   - alfa32(ie)*(alfa11(ie)*alfa23(ie) -alfa13(ie)*alfa21(ie)) &
                   + alfa33(ie)*(alfa11(ie)*alfa22(ie) -alfa12(ie)*alfa21(ie))

               if (jac.le.0.d0) then
                  write(*,*)'Error ! Orientation non-conforming !'
                  write(*,*)'(element ',ie,' is clockwise oriented)'
                  call EXIT(EXIT_ELEM_ORIENT)
               endif

               do k = 1,nn
                  do j = 1,nn
                     do i = 1,nn
                        xp = alfa11(ie)*ct(i) + alfa12(ie)*ct(j) &
                           + alfa13(ie)*ct(k) + beta11(ie)*ct(j)*ct(k) &
                           + beta12(ie)*ct(i)*ct(k) + beta13(ie)*ct(i)*ct(j) &
                           + gamma1(ie)*ct(i)*ct(j)*ct(k) + delta1(ie)

                        yp = alfa21(ie)*ct(i) + alfa22(ie)*ct(j) &
                           + alfa23(ie)*ct(k) + beta21(ie)*ct(j)*ct(k) &
                           + beta22(ie)*ct(i)*ct(k) + beta23(ie)*ct(i)*ct(j) &
                           + gamma2(ie)*ct(i)*ct(j)*ct(k) + delta2(ie)

                        zp = alfa31(ie)*ct(i) + alfa32(ie)*ct(j) &
                           + alfa33(ie)*ct(k) + beta31(ie)*ct(j)*ct(k) &
                           + beta32(ie)*ct(i)*ct(k) + beta33(ie)*ct(i)*ct(j) &
                           + gamma3(ie)*ct(i)*ct(j)*ct(k) + delta3(ie)

                        ip = nn*nn*(k -1) +nn*(j -1) +i

                        xx_loc(cs_loc(cs_loc(ie -1) + ip)) = xp
                        yy_loc(cs_loc(cs_loc(ie -1) + ip)) = yp
                        zz_loc(cs_loc(cs_loc(ie -1) + ip)) = zp

                     enddo
                  enddo
               enddo

            endif
         enddo
      enddo

      return

      end subroutine MAKE_SPX_GRID_LOC


      PROGRAM TABLES
      IMPLICIT NONE
C
C     Produce a formatted multiplication table of the kind memorised by rote
C     when in primary school. Only print the top half triangle of products.
C
C     23 Nov 15 - 0.1   - Adapted from original for VAX FORTRAN - MEJT
C
      INTEGER I,J,K                                             ! Counters.
      CHARACTER*32 S                                            ! Buffer for format specifier.
C
      K=12
C
      WRITE(S,1) K,K
    1 FORMAT(8H(4H0  |,,I2.2,11HI4,/,4H --+,I2.2,9H(4H----)))
      WRITE(6,S) (I,I = 1,K)                                    ! Print heading.
C
      DO 3 I=1,K		                                ! Step down the lines.
        WRITE(S,2) (I-1)*4+1,K                                  ! Update format string.
    2   FORMAT(12H(1H ,I2,1H|,,I2.2,5HX,I3,,I2.2,3HI4),8X)      ! Format string includes an explicit carridge control character.
        WRITE(6,S) I,(I*J, J = I,K)                             ! Use format to print row with leading blanks, unused fields are ignored.
    3 CONTINUE
C
      END


SUBROUTINE EOP (mjd, EOP_cr, CRS2TRS, TRS2CRS, d_CRS2TRS, d_TRS2CRS)

! ----------------------------------------------------------------------
! Subroutine:  EOP.f90
! ----------------------------------------------------------------------
! Purpose:
!  IERS Earth Orientation Parameters (EOP) data reading and processing.
!  Corrections computing due to tidal variations
!  Computation of the ICRF-ITRF transformation matrix (direct/inverse)
!  and its derivatives.
!  Earth Orientation Matrix computation is based on the EOP data corrected
!  due to tidal variations.
! ---------------------------------------------------------------------------
! Input arguments:
! - mjd:                Modified Julian Day number of the epoch (in TT scale)
!
! Output arguments:
! - EOP_cr:       Array of the EOP data after applying the tidal corrections
!   EOP_cr = [MJD xp_cor yp_cor UT1-UTC_cor LOD_cor dX dY]  1x6 matrix
!   MJD:                MJD of the input epoch (in TT)
!   xp_cor,yp_cor:      Polar motion coordinates (arcsec) at input epoch considering
!                             corrections due to tidal variations (ocean tidal and libration effects)
!   UT1UTC_cor:         UT1-UTC difference (sec) at input epoch considering corrections
!                             due to tidal variations (ocean tidal and libration effects)
!   LOD:                Length of Day (LOD)
!   dX, dY:             Corrections to the Precession-Nutation model (arcsec)
! - CRS2TRS:            GCRS to ITRS transformation matrix
! - TRS2CRS:            ITRS to GCRS transformation matrix
! - d_CRS2TRS:          Derivative of GCRS to ITRS transformation matrix
! - d_TRS2CRS:          Derivative of ITRS to GCRS transformation matrix
! ----------------------------------------------------------------------
! Note 1:
!  Values of the EOP_sol input argument:
!  1. EOP_sol = 1 : refers to EOP data format of the C04 solution
!                     provided by the IERS Earth Orientation Center
!  2. EOP_sol = 2 : refers to EOP data format of the daily solution (finals2000A.daily)
!                     provided by the IERS Rapid Service/Prediction Center
!  3. EOP_sol = 3 : refers to EOP data format of the ultra-rapid products
!                     provided by the IGS (per every 6 hours)
! ---------------------------------------------------------------------------
! ---------------------------------------------------------------------------
! Dr. Thomas Papanikolaou
! Cooperative Research Centre for Spatial Information, Australia
! 12 July 2017
! ---------------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      use pod_yaml
      USE mdl_eop
      USE m_eop_cor
      USE m_eop_igu
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: mjd

! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: EOP_cr(EOP_MAX_ARRAY)
      REAL (KIND = prec_d), INTENT(OUT) :: CRS2TRS(3,3), TRS2CRS(3,3)
      REAL (KIND = prec_d), INTENT(OUT) :: d_CRS2TRS(3,3), d_TRS2CRS(3,3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER i, arc_length
      REAL (KIND = prec_d) :: mjd_TT
! ----------------------------------------------------------------------

mjd_TT = mjd
EOP_cr = 0.d0

! ----------------------------------------------------------------------
! EOP data
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Case 1. EOP by IERS data: EOP reading, interpolation and corrections
! ----------------------------------------------------------------------
! - IERS Earth Orientation Center:              C04 solution
! - IERS Rapid Service/Prediction Center: finals2000A.daily solution
! ----------------------------------------------------------------------
      IF (EOP_sol == EOP_C04T .OR. EOP_sol == EOP_FAST) THEN
            CALL eop_cor (mjd_TT, EOP_day_glb, EOP_sol, EOP_Nint, EOP_cr)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Case 2. ERP by IGS ultra-rapid data (ERP reading and interpolation) +
!             dX,dY w.r.t. IAU2000A by IERS RS/PC (finals2000A.daily)
! ----------------------------------------------------------------------
      ELSEIF (EOP_sol == EOP_SUPER_FAST)  THEN
            arc_length = yml_orbit_arc_determination + yml_orbit_arc_prediction +&
                    yml_orbit_arc_backwards
            CALL eop_igu (mjd_TT, ERP_fname, ERP_day_glb, EOP_day_glb, EOP_Nint, EOP_cr)
      END IF
! ----------------------------------------------------------------------
      ! debug
      if (.false.) then
              print *, EOP_cr
      end if
! ----------------------------------------------------------------------
!SCM 20190606 Removed the nutation model correction terms from EOP array,
!             These terms were adding noise to the orbit fits to IGS products.
!             Add flag to turn on/off in the future!
      EOP_cr(EOP_DX) = 0.D0
      EOP_cr(EOP_DY) = 0.D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Tranformation: ITRF to ICRF
! ----------------------------------------------------------------------
! ICRF-ITRF transformation matrix (including derivatives)
      CALL crs_trs (mjd_TT, EOP_cr, iau_model, CRS2TRS, TRS2CRS, d_CRS2TRS, d_TRS2CRS)
! ----------------------------------------------------------------------

      ! just some debug
      if (.false.) then
      print *, "mjd=", mjd_TT

      print *, "ECI-ECEF matrix"
      do i = 1, 3
          print *, crs2trs(i, 1), crs2trs (i, 2), crs2trs (i,3)
      end do

      print *, "derivative of ECI-ECEF matrix"
      do i = 1, 3
          print *, d_crs2trs(i, 1), d_crs2trs(i, 2), d_crs2trs(i, 3)
      end do
      end if

END


module bessel

  use precision
  use globals
  use nswclib

  implicit none

  interface f_besselj

     module procedure f_dbesselj
     module procedure f_zbesselj

  end interface

  interface f_besseli

     module procedure f_dbesseli
     module procedure f_zbesseli

  end interface

contains

  function f_dbesselj(n, z) result(bessel)

    integer(idp), intent(in) :: n
    real(fdp), intent(in) :: z

    real(fdp) :: bessel
    complex(cdp) :: bessel_t, z_t

    z_t = z

    call bsslj(z_t, n, bessel_t)

    bessel = real(bessel_t)

  end function f_dbesselj

   function f_zbesselj(n, z) result(bessel)

    integer(idp), intent(in) :: n
    complex(cdp), intent(in) :: z

    complex(cdp) :: bessel

    call bsslj(z, n, bessel)

  end function f_zbesselj

  function f_dbesseli(n, z) result(bessel)

    integer(idp), intent(in) :: n
    real(fdp), intent(in) :: z

    real(fdp) :: bessel
    complex(cdp) :: bessel_t, z_t

    z_t = z

    call bssli(0, z_t, n, bessel_t)

    bessel = real(bessel_t)

  end function f_dbesseli

  function f_zbesseli(n, z) result(bessel)

    integer(idp), intent(in) :: n
    complex(cdp), intent(in) :: z

    complex(cdp) :: bessel, z_t

    call bssli(0, z, n, bessel)

  end function f_zbesseli

end module bessel


!=====================================================|
module geometry_def
!=====================================================|
  integer, parameter :: nx = 400
  integer, parameter :: margin = 2
  integer, parameter :: nxg = nx + 2*margin
  integer, parameter :: mtype = 8

  ! geometry
  real(KIND(0.d0)), save :: xmax, xmin, dx
  real(KIND(0.d0)), dimension(nxg), save :: x  ! geometry
  real(KIND(0.d0)), dimension(nxg,mtype), save :: qq, qqm, qqp ! variable
  real(KIND(0.d0)), dimension(nxg), save :: cc ! characteristic velocity

  ! time variable
  integer, save :: ns, nd
  real(KIND(0.d0)), save :: time,dt

  ! data directory
  character (len = 10),save :: data_dir
end module geometry_def


C----------------------------------------------------------------------
C----------------------------------------------------------------------
C   wav :    Periodic waves in an a nonlinear parabolic PDE
C----------------------------------------------------------------------
C----------------------------------------------------------------------
C
      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
C     ---------- ----
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION U(NDIM),PAR(*),F(NDIM)
C
       R= U(2)/(PAR(5)+U(2)) * U(1)/(1+U(1)+PAR(6)*U(1)*U(1))
       F(1)=-PAR(1)*( PAR(4)*R - (PAR(2)-U(1)) )
       F(2)=-PAR(1)*( PAR(4)*R - PAR(7)*(PAR(3)-U(2)) )
C
      RETURN
      END
C
      SUBROUTINE STPNT(NDIM,U,PAR)
C     ---------- -----
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION U(NDIM),PAR(*)
C
       PAR(1) = 3.0
       PAR(2) = 145
       PAR(3) = 539.23
       PAR(4) = 210
       PAR(5) = 3.4
       PAR(6) = 0.023
       PAR(7) = 0.2
C
       U(1) = 59.702
       U(2) = 112.752
C
       PAR(10) = 0.05
       PAR(15) = 1.0
       PAR(16) = 5.0
C
      RETURN
      END
C
      SUBROUTINE BCND
      RETURN
      END
C
      SUBROUTINE ICND
      RETURN
      END
C
      SUBROUTINE FOPT
      RETURN
      END
C
      SUBROUTINE PVLS
      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2007 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine calcstabletimeincvol(ne0,lakon,co,kon,ipkon,mi,
     &  ielmat,dtvol,alpha,wavespeed)
!
!     Calculates the critical time increment (CTI) based on the Courant
!     Criterion for Explicit Dynamics calculations. Temperature is
!     assumed averaged from the centroid of the element and material
!     wave propagation speeds must be calculated before.
!
      implicit none
!
      character*8 lakon(*),lakonl
!
      integer i,j,ne0,nope,kon(*),ipkon(*),indexe,konl(26),nelem,
     &  iflag,nopes,nfaces,ig,ifaceq(8,6),ifacet(6,4),ifacew(8,5),
     &  mi(*),ielmat(mi(3),*),imat,elemmin
!
      real*8 xi,et,ze,weight,co(3,*),xl(3,26),xsj,shp(4,26),xl2(3,9),
     &  xsj2(3),xs2(3,7),shp2(7,9),hmin,area,volume,
     &  wavspd,dtvol,safefac,alpha,bet,gam,critom,damping,
     &  wavespeed(*),geomfac,quadfac
!
      data ifaceq /4,3,2,1,11,10,9,12,
     &     5,6,7,8,13,14,15,16,
     &     1,2,6,5,9,18,13,17,
     &     2,3,7,6,10,19,14,18,
     &     3,4,8,7,11,20,15,19,
     &     4,1,5,8,12,17,16,20/
      data ifacet /1,3,2,7,6,5,
     &     1,2,4,5,9,8,
     &     2,3,4,6,10,9,
     &     1,4,3,8,10,7/
      data ifacew /1,3,2,9,8,7,0,0,
     &     4,5,6,10,11,12,0,0,
     &     1,2,5,4,7,14,10,13,
     &     2,3,6,5,8,15,11,14,
     &     4,6,3,1,12,15,9,13/
!
      include "gauss.f"
!
      iflag=2
      dtvol=1.d30
      safefac=0.80d0
      quadfac=0.3d0
!
      damping=0
!
      bet=(1.d0-alpha)*(1.d0-alpha)/4.d0
      gam=0.5d0-alpha
!
!     Omega Critical
!     Om_cr=dt*freq_max
!
      critom=dsqrt(damping*damping*(1+2*alpha*(1-gam))
     &     *(1+2*alpha*(1-gam))
     &     +2*(gam+2*alpha*(gam-bet)) )
      critom=0.98*(-damping*(1+2*alpha*(1-gam))+critom)
     &     /(gam+2*alpha*(gam-bet)) !eq 25 miranda
!
!     ** DO per element
      do nelem=1,ne0
         if(ipkon(nelem).lt.0) cycle
         indexe=ipkon(nelem)
!
         lakonl=lakon(nelem)
         imat=ielmat(1,nelem)
!
         geomfac=1.d0
!
         if(lakon(nelem)(4:5).eq.'20')then
!
            nope=20
            nopes=8
            nfaces=6
            geomfac=quadfac
         elseif(lakon(nelem)(4:4).eq.'8') then
            nope=8
            nopes=4
            nfaces=6
         elseif(lakon(nelem)(4:5).eq.'10')then
            nope=10
            nopes=6
            nfaces=4
            geomfac=quadfac
         elseif(lakon(nelem)(4:4).eq.'4') then
            nope=4
            nopes=3
            nfaces=4
         elseif(lakon(nelem)(4:5).eq.'15')then
            nope=15
            nfaces=5
            geomfac=quadfac
         elseif(lakon(nelem)(4:4).eq.'6') then
            nope=6
            nfaces=5
         else
            cycle
         endif
!
!     Find center of the element for avg temp value on the element  to
!     get properties later
!     if HEX
         if((lakon(nelem)(4:5).eq.'20').or.
     &        (lakon(nelem)(4:4).eq.'8')) then
            xi=0.d0
            et=0.d0
            ze=0.d0
            weight=8.d0
!     if TET
         elseif((lakon(nelem)(4:5).eq.'10').or.
     &           (lakon(nelem)(4:4).eq.'4')) then
            xi=gauss3d4(1,1)
            et=gauss3d4(2,1)
            ze=gauss3d4(3,1)
            weight=weight3d4(1)
!     elseif WEDGES
         elseif((lakonl(4:5).eq.'15').or.
     &          (lakonl(4:4).eq.'6'))then
            xi=1.d0/3.d0
            et=1.d0/3.d0
            ze=0.d0
            weight=1.d0
         endif
!
         do i=1,nope
            konl(i)=kon(indexe+i)
            do j=1,3
               xl(j,i)=co(j,konl(i))
            enddo
         enddo
!
         if   (nope.eq.20)then
            call shape20h(xi,et,ze,xl,xsj,shp,iflag)
         elseif(nope.eq.8) then
            call shape8h(xi,et,ze,xl,xsj,shp,iflag)
         elseif(nope.eq.10)then
            call shape10tet(xi,et,ze,xl,xsj,shp,iflag)
         elseif(nope.eq.4) then
            call shape4tet (xi,et,ze,xl,xsj,shp,iflag)
         elseif(nope.eq.15)then
            call shape15w(xi,et,ze,xl,xsj,shp,iflag)
         else
            call shape6w(xi,et,ze,xl,xsj,shp,iflag)
         endif
!
         wavspd=wavespeed(imat)
!
!     Divides volume accordingly per geometry of element
!     Carlo MT proposal
!     if HEX
         if((lakon(nelem)(4:5).eq.'20').or.
     &        (lakon(nelem)(4:4).eq.'8')) then
            volume=weight*xsj
!     if TET
         elseif((lakon(nelem)(4:5).eq.'10').or.
     &           (lakon(nelem)(4:4).eq.'4')) then
            volume=weight*xsj/3.d0
!     if WEDGES
         elseif ( (lakonl(4:5).eq.'15').or.
     &           (lakonl(4:4).eq.'6'))then
            volume=weight*xsj/2.d0
         endif
!
         hmin=1.d30
!
!     DO over sides
         do ig=1,nfaces
            if(lakon(nelem)(4:4).eq.'6')then
               if(ig.le.2)then
                  nopes=3
               else
                  nopes=4
               endif
            elseif(lakon(nelem)(4:5).eq.'15')then
               if(ig.le.2)then
                  nopes=6
               else
                  nopes=8
               endif
            endif
!
            if((nope.eq.20).or.(nope.eq.8))then
               do i=1,nopes
                  do j=1,3
                     xl2(j,i)=co(j,konl(ifaceq(i,ig)))
                  enddo
               enddo
            elseif((nope.eq.10).or.(nope.eq.4))then
               do i=1,nopes
                  do j=1,3
                     xl2(j,i)=co(j,konl(ifacet(i,ig)))
                  enddo
               enddo
            else
               do i=1,nopes
                  do j=1,3
                     xl2(j,i)=co(j,konl(ifacew(i,ig)))
                  enddo
               enddo
            endif
!
            if((nopes.eq.4).or.(nopes.eq.8))then
               xi=0.d0
               et=0.d0
               weight=4.d0
            else
               xi=1.d0/3.d0
               et=1.d0/3.d0
               weight=0.5d0
            endif
!
            if    (nopes.eq.8) then
               call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag)
            elseif(nopes.eq.4) then
               call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag)
            elseif(nopes.eq.6) then
               call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag)
            elseif(nopes.eq.7) then
               call shape7tri(xi,et,xl2,xsj2,xs2,shp2,iflag)
            else
               call shape3tri(xi,et,xl2,xsj2,xs2,shp2,iflag)
            endif
!
            area=weight*dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+
     &           xsj2(3)*xsj2(3))
            hmin=min(hmin,(volume/area))
!
         enddo
!     ENDDO over sides
!
         if(critom/2*hmin/wavspd*geomfac.lt.dtvol)then
            elemmin=nelem
         endif

         dtvol=min(dtvol,critom/2* hmin/wavspd*geomfac)
      enddo
!     ** ENDDO per element
!
      dtvol=dtvol* safefac
!
      return
      end


C................................................................       SOL   10
      SUBROUTINE SOLUTN(X, Z, DMVAL)                                    SOL   20
      implicit real*8 (a-h, o-z)
      COMMON /p2/ EPS, DMU, EPS4MU, GAMMA, XT
      DIMENSION Z(4), DMVAL(2)
      CONS = GAMMA*X*(1.-.5*X*X)
      DCONS = GAMMA*(1.-1.5*X*X)
      D2CONS = -3.*GAMMA*X
      IF (X.GT.XT) GO TO 10
      Z(1) = 2.*X
      Z(2) = 2.
      Z(3) = -2.*X + CONS
      Z(4) = -2. + DCONS
      DMVAL(2) = D2CONS
      GO TO 20
   10 Z(1) = 0.
      Z(2) = 0.
      Z(3) = -CONS
      Z(4) = -DCONS
      DMVAL(2) = -D2CONS
   20 DMVAL(1) = 0.
      RETURN
      END


c
c     dpodi computes the determinant and inverse of a certain
c     double precision symmetric positive definite matrix (see below)
c     using the factors computed by dpoco, dpofa or dqrdc.
c
c     on entry
c
c        a       double precision(lda, n)
c                the output  a  from dpoco or dpofa
c                or the output  x  from dqrdc.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c        job     integer
c                = 11   both determinant and inverse.
c                = 01   inverse only.
c                = 10   determinant only.
c
c     on return
c
c        a       if dpoco or dpofa was used to factor  a  then
c                dpodi produces the upper half of inverse(a) .
c                if dqrdc was used to decompose  x  then
c                dpodi produces the upper half of inverse(trans(x)*x)
c                where trans(x) is the transpose.
c                elements of  a  below the diagonal are unchanged.
c                if the units digit of job is zero,  a  is unchanged.
c
c        det     double precision(2)
c                determinant of  a  or of  trans(x)*x  if requested.
c                otherwise not referenced.
c                determinant = det(1) * 10.0**det(2)
c                with  1.0 .le. det(1) .lt. 10.0
c                or  det(1) .eq. 0.0 .
c
c     error condition
c
c        a division by zero will occur if the input factor contains
c        a zero on the diagonal and the inverse is requested.
c        it will not occur if the subroutines are called correctly
c        and if dpoco or dpofa has set info .eq. 0 .
c
c     linpack.  this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal
c     fortran mod
c
      subroutine dpodi(a,lda,n,det,job)
      integer lda,n,job
      double precision a(lda,*)
      double precision det(2)
c
c     internal variables
c
      double precision t
      double precision s
      integer i,j,jm1,k,kp1
c
c     compute determinant
c
      if (job/10 .eq. 0) go to 70
         det(1) = 1.0d0
         det(2) = 0.0d0
         s = 10.0d0
         do 50 i = 1, n
            det(1) = a(i,i)**2*det(1)
c        ...exit
            if (det(1) .eq. 0.0d0) go to 60
   10       if (det(1) .ge. 1.0d0) go to 20
               det(1) = s*det(1)
               det(2) = det(2) - 1.0d0
            go to 10
   20       continue
   30       if (det(1) .lt. s) go to 40
               det(1) = det(1)/s
               det(2) = det(2) + 1.0d0
            go to 30
   40       continue
   50    continue
   60    continue
   70 continue
c
c     compute inverse(r)
c
      if (mod(job,10) .eq. 0) go to 140
         do 100 k = 1, n
            a(k,k) = 1.0d0/a(k,k)
            t = -a(k,k)
            call dscal(k-1,t,a(1,k),1)
            kp1 = k + 1
            if (n .lt. kp1) go to 90
            do 80 j = kp1, n
               t = a(k,j)
               a(k,j) = 0.0d0
               call daxpy(k,t,a(1,k),1,a(1,j),1)
   80       continue
   90       continue
  100    continue
c
c        form  inverse(r) * trans(inverse(r))
c
         do 130 j = 1, n
            jm1 = j - 1
            if (jm1 .lt. 1) go to 120
            do 110 k = 1, jm1
               t = a(k,j)
               call daxpy(k,t,a(1,j),1,a(1,k),1)
  110       continue
  120       continue
            t = a(j,j)
            call dscal(j,t,a(1,j),1)
  130    continue
  140 continue
      return
      end


      subroutine brooks_corey_cap3(sg, sr_g, smax_g, cmax, lambda,
     &     prop2, dprop21, dprop22)
!***********************************************************************
! Copyright 2009 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Brooks-Corey 3-phase capillary pressure model.
!D1
!***********************************************************************
! 3-phase cap pressure model
! input:  sg is gas saturation
!         sr_g is residual gas saturation
!         smax_g is max gas saturation
!         cmax is maximum cap pressure
!         lambda is exponent
!***********************************************************************

      implicit none
      real*8 sg,sr_g,smax_g,cmax,lambda,prop2,dprop21,dprop22
      if(sg.le.sr_g) then
         prop2 = 0.d0
         dprop21 = 0.d0
         dprop22 = 0.d0
      elseif(sg.le.lambda) then
         if(lambda.eq.1) then
            prop2 = cmax*(sg-sr_g)/(smax_g-sr_g)
            dprop21 = 0.d0
            dprop22 = cmax/(smax_g-sr_g)
         else
            prop2 = cmax*(sg-sr_g)**lambda/(smax_g-sr_g)
            dprop21 = 0.0
            dprop22 = cmax*lambda*((sg-sr_g)**(lambda-1))/(smax_g-sr_g)
         endif
      else
         prop2 = cmax
         dprop21 = 0.d0
         dprop22 = 0.d0
      endif

      end subroutine brooks_corey_cap3


    module pub
    implicit none
    integer yn,kn,ne,N,enn,hn
    real eta,dk,de
    parameter(yn = 50,hn =  4,kn = 50, ne = 50,N = yn*4,eta = 0.01,dk = 0.01,de = dk)
    real,parameter::pi = 3.1415926535
    complex,parameter::im = (0.,1.0)
    complex Ham(N,N),one(N,N)
!=================================
    real m0,mu
    real tx,ty
    real ax,ay,gamma
    complex g1(hn,hn)
    complex g2(hn,hn)
    complex g3(hn,hn)
!================cheev===============
    integer::lda = N
    integer,parameter::lwmax = 2*N + N**2
    real,allocatable::w(:)
    complex,allocatable::work(:)
    real,allocatable::rwork(:)
    integer,allocatable::iwork(:)
    integer lwork
    integer lrwork
    integer liwork
    integer info
    end module pub
!================= PROGRAM START ============================
    program sol
    use pub
    integer i1
!====空间申请==================
    allocate(w(N))
    allocate(work(lwmax))
    allocate(rwork(1+5*N+2*N**2))
    allocate(iwork(3+5*N))
!======parameter value setting =====
    m0 = 1.5
    mu = 0
    tx = 1.0
    ty = 1.0
    ax = 1.0
    ay = 1.0
    do i1 = 1,N
        one(i1,i1) = 1  !单位矩阵
    end do
    call main()
    stop
    end program sol
!=============================================================================================
    subroutine main()
    !  Calculate edge spectrum function
    use pub
    integer m1,m2,i1
    real kx,ky,omega,re2
    complex h1(N,N),h2(N,N)
    complex re1
    open(30,file="openy-bhz.dat")
    !-------------------------------------------------
    !   y-direction is open
    do omega = -3.0,3.0,de
        do kx = -pi,pi,dk
            re1 = 0
            call openy(kx)
            h1 = omega*one - ham + im*eta*one
            call inv(h1,h2)
            do i1 = 1,N
                re1 = re1 + h2(i1,i1)
            end do
            re2 = -2*aimag(re1)/pi/N
            write(30,999)kx/pi,omega,re2
        end do
        write(30,*)" "
    end do
    close(30)
    !---------------------------------------------------------------------
    !  x-direction is open
    open(31,file="openx-bhz.dat")
    do omega = -3.0,3.0,de
        do ky = -pi,pi,dk
            re1 = 0
            call openx(ky)
            h1 = omega*one - ham + im*eta*one
            call inv(h1,h2)
            do i1 = 1,N
                re1 = re1 + h2(i1,i1)
            end do
            re2 = -2*aimag(re1)/pi/N
            write(31,999)ky/pi,omega,re2
        end do
        write(31,*)" "
    end do
    close(31)
999 format(3f11.5)
    return
    end subroutine main
!======================== Pauli Matrix driect product============================
    subroutine Pauli()
    use pub
    !   TI
!=== Kinetic energy
    g1(1,1) = 1
    g1(2,2) = -1
    g1(3,3) = 1
    g1(4,4) = -1
!====== SOC-x
    g2(1,2) = 1
    g2(2,1) = 1
    g2(3,4) = -1
    g2(4,3) = -1
!====== SOC-y
    g3(1,2) = -im
    g3(2,1) = im
    g3(3,4) = -im
    g3(4,3) = im
    return
    end subroutine Pauli
!==========================================================
    subroutine openx(ky)
    use pub
    real ky
    integer m,l,k
    call Pauli()
    Ham = 0
!========== Positive energy ========
    do k = 0,yn-1
        if (k == 0) then ! Only right block in first line
            do m = 1,hn
                do l = 1,hn
                    Ham(m,l) = (m0-ty*cos(ky))*g1(m,l) + ay*sin(ky)*g3(m,l)

                    Ham(m,l + hn) = (-tx*g1(m,l) - im*ax*g2(m,l))/2
                end do
            end do
        elseif ( k==yn-1 ) then ! Only left block in last line
            do m = 1,hn
                do l = 1,hn
                    Ham(k*hn + m,k*hn + l) = (m0-ty*cos(ky))*g1(m,l) + ay*sin(ky)*g3(m,l)

                    Ham(k*hn + m,k*hn + l - hn) = -tx*g1(m,l)/2 + im*ax*g2(m,l)/2
                end do
            end do
        else
            do m = 1,hn
                do l = 1,hn ! k start from 1,matrix block from 2th row
                    Ham(k*hn + m,k*hn + l) = (m0 - ty*cos(ky))*g1(m,l) + ay*sin(ky)*g3(m,l)

                    Ham(k*hn + m,k*hn + l + hn) = (-tx*g1(m,l) - im*ax*g2(m,l))/2
                    Ham(k*hn + m,k*hn + l - hn) = -tx*g1(m,l)/2 + im*ax*g2(m,l)/2
                end do
            end do
        end if
    end do
    !------------------------
    call isHermitian()
    ! call eigsol()
    return
    end subroutine openx
!==========================================================
    subroutine openy(kx)
    use pub
    real kx
    integer m,l,k
    call Pauli()
    Ham = 0
!========== Positive energy ========
    do k = 0,yn-1
        if (k == 0) then ! Only right block in first line
            do m = 1,hn
                do l = 1,hn
                    Ham(m,l) = (m0-tx*cos(kx))*g1(m,l) + ax*sin(kx)*g2(m,l)

                    Ham(m,l + hn) = (-ty*g1(m,l) - im*ay*g3(m,l))/2
                end do
            end do
        elseif ( k==yn-1 ) then ! Only left block in last line
            do m = 1,hn
                do l = 1,hn
                    Ham(k*hn + m,k*hn + l) = (m0-tx*cos(kx))*g1(m,l) + ax*sin(kx)*g2(m,l)

                    Ham(k*hn + m,k*hn + l - hn) = -ty*g1(m,l)/2 + im*ay*g3(m,l)/2
                end do
            end do
        else
            do m = 1,hn
                do l = 1,hn ! k start from 1,matrix block from 2th row
                    Ham(k*hn + m,k*hn + l) = (m0-tx*cos(kx))*g1(m,l) + ax*sin(kx)*g2(m,l)

                    Ham(k*hn + m,k*hn + l + hn) = (-ty*g1(m,l) - im*ay*g3(m,l) )/2
                    Ham(k*hn + m,k*hn + l - hn) = -ty*g1(m,l)/2 + im*ay*g3(m,l)/2
                end do
            end do
        end if
    end do
    !---------------------------------
    call isHermitian()
    ! call eigsol()
    return
    end subroutine openy
!============================================================
    subroutine isHermitian()
    use pub
    integer i,j
    do i = 1,N
        do j = 1,N
            if (Ham(i,j) .ne. conjg(Ham(j,i)))then
                open(160,file = 'hermitian.dat')
                write(160,*)i,j
                write(160,*)Ham(i,j)
                write(160,*)Ham(j,i)
                write(160,*)"===================="
                write(*,*)"Hamiltonian is not hermitian"
                stop
            end if
        end do
    end do
    close(160)
    return
    end subroutine isHermitian
!================= 矩阵本征值求解 ==============
    subroutine eigSol()
    use pub
    integer m
    lwork = -1
    liwork = -1
    lrwork = -1
    call cheevd('V','Upper',N,Ham,lda,w,work,lwork &
        ,rwork,lrwork,iwork,liwork,info)
    lwork = min(2*N+N**2, int( work( 1 ) ) )
    lrwork = min(1+5*N+2*N**2, int( rwork( 1 ) ) )
    liwork = min(3+5*N, iwork( 1 ) )
    call cheevd('V','Upper',N,Ham,lda,w,work,lwork &
        ,rwork,lrwork,iwork,liwork,info)
    if( info .GT. 0 ) then
        open(110,file="mes.dat",status="unknown")
        write(110,*)'The algorithm failed to compute eigenvalues.'
        close(110)
    end if
    ! open(120,file="eigval.dat")
    ! do m = 1,N
    !     write(120,*)w(m)
    ! end do
    ! close(120)
    return
    end subroutine eigSol
!=================================================================
    subroutine inv(matin,matout)
    use pub
    complex,intent(in) :: matin(N,N)
    complex:: matout(size(matin,1),size(matin,2))
    real:: work2(size(matin,1))            ! work array for LAPACK
    integer::info2,ipiv(size(matin,1))     ! pivot indices
    ! Store A in Ainv to prevent it from being overwritten by LAPACK
    matout = matin
    ! SGETRF computes an LU factorization of a general M-by-N matrix A
    ! using partial pivoting with row interchanges.
    call CGETRF(N,N,matout,N,ipiv,info2)
    if (info2.ne.0)then
      write(*,*)'Matrix is numerically singular!'
      stop
    end if
    ! SGETRI computes the inverse of a matrix using the LU factorization
    ! computed by SGETRF.
    call CGETRI(N,matout,N,ipiv,work2,N,info2)
    if (info2.ne.0)then
        write(*,*)'Matrix inversion failed!'
        stop
    end if
    return
    end subroutine inv


!Write by Liao Yuanda
!
!###############################################################

module dou_ex

contains

    subroutine calcu_p_nearest( p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L )
        implicit none
        integer :: p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L
        integer :: i, j, i_pl, j_pl, i_mi, j_mi

        i = int((p-1)/L)
        j = mod(p-1,L)
        i_pl = mod(i+1,L)
        j_pl = mod(j+1,L)
        if (i==0) then
            i_mi = L-1
        else
            i_mi = i-1
        end if
        if (j==0) then
            j_mi = L-1
        else
            j_mi = j-1
        end if

        p_i_pl = i_pl*L+j+1
        p_i_mi = i_mi*L+j+1
        p_j_pl = i*L+j_pl+1
        p_j_mi = i*L+j_mi+1
        p_i_pl_j_mi = i_pl*L+j_mi+1
        p_i_mi_j_pl = i_mi*L+j_pl+1

    end subroutine calcu_p_nearest

    subroutine calcu_H( L, N, M, H, t)

        implicit none
        integer :: L, N, M, i, j
        integer :: p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl
        real*8 :: t, H(M, M)

        do i = 1, M
            do j = 1, M
                H(i,j) = 0.0
            end do
        end do

        do i = 0, L-1, 1
            do j = 0, L-1, 1
                p = i*L+j+1
                call calcu_p_nearest( p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L )

                H(p, p_i_pl) = -t
                H(p, p_i_mi) = -t
                H(p, p_j_pl) = -t
                H(p, p_j_mi) = -t
                H(p, p_i_pl_j_mi) = -t
                H(p, p_i_mi_j_pl) = -t

                H(p+N, p_i_pl+N) = -t
                H(p+N, p_i_mi+N) = -t
                H(p+N, p_j_pl+N) = -t
                H(p+N, p_j_mi+N) = -t
                H(p+N, p_i_pl_j_mi+N) = -t
                H(p+N, p_i_mi_j_pl+N) = -t
            end do
        end do
    end subroutine calcu_H

end module dou_ex

program skyrmionlattice
    use dou_ex
    implicit none
    !#########################################
    !L, size of lattice
    !N = L*L, num of lattice
    !t, J_para, the parameter if H
    !##########################################
    integer, parameter :: L = 60, N = L*L, M = 2*N, LDZ = 1
    real*8, parameter :: t = 1.0
    integer :: i, j, info
	real*8 :: Emax, Emin, a, b
    real*8, dimension(M) :: Eig
    real*8, dimension(3*M-2) :: Rwork
    real*8, dimension(M,M) :: H
    real*8, dimension(3*M) :: Work
    real*8, dimension(M*(M+1)/2) :: AP
    real*8, dimension(LDZ,M) :: Z
    Emax = 3.0*t
    Emin = -6.0*t
    a = (Emax-Emin)/2.0
    b = (Emax+Emin)/2.0
    call calcu_H( L, N, M, H, t)

    do i = 1,M
		H(i,i) = H(i,i)-b
        do j = i,M
			H(i,j) = H(i,j)/a
            AP(i+(j-1)*j/2) = H(i,j)
        end do
    end do
    call dspev( 'N', 'U', M, AP, Eig, Z, LDZ, work, info )
    if (info /= 0) then
    	write(*,*) 'info_erro =', info
    end if

    open(unit = 14, file = 'eig.out')
    do i = 1, M
        write(14,*) Eig(i)
    end do
    close(14)

    write(*,*) 'end'
end program skyrmionlattice


      subroutine minvrt(aamatr,aimatr,delvec,gmmatr,ier,ipivot,
     $ kdim,kmax,noutpt,nttyo,qpr)
c
c     This subroutine inverts the matrix aamatr. The inverted matrix
c     is returned in aimatr. Thus
c
c       [aamatr][aimatr] = I
c
c     where I is the unit matrix (1's on the diagonal, 0's elsewhere).
c
c     The method is L-U decomposition of the matrix, in combination
c     with the subsequent solution of a series of matrix equations,
c     each using the same decomposed matrix but with a different unit
c     vector as the right hand side. The original aamatr matrix is
c     preserved. The workspace vector gmmatr holds the L-U
c     decomposition.
c
c     A companion subroutine ginvrt.f has the same function as the
c     present routine. However, it assumes that aamatr has already
c     been factored into gmmatr.
c
c     This subroutine uses the following subroutines, which are
c     adaptations of 1979 Linpack subroutines of the same names:
c
c       EQLIBU/dgefa.f
c       EQLIBU/dgesl.f
c
c     The calling sequences have been preserved to facilitate
c     substituting equivalents optimized for specific platforms,
c     for anyone desiring to do so.
c
c     This subroutine is called by:
c
c       EQ6/path.f
c
c-----------------------------------------------------------------------
c
c     Input:
c
c       aamatr = the matrix
c       kdim   = the actual dimention of the matrix
c       kmax   = the maximum dimension of the matrix
c       noutpt = the unit number of the output file
c       nttyo  = the unit number of the screen file
c       qpr    = logical switch to print messages from this subroutine
c
c     Workspace:
c
c       delvec = at one point, the right-hand-side vector; at another,
c                  the solution vector
c       gmmatr = work space for a copy of the matrix; holds the
c                  L-U decomposition
c       ipivot = the pivot vector
c
c     Output:
c
c       aimatr = the inverted matrix
c       ier    = error flag:
c                  =  1  Encountered a zero matrix
c                  =  2  Encountered a non-zero, computationally
c                          singular matrix
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer kmax
c
      integer noutpt,nttyo
c
      integer ipivot(kmax)
      integer ier,kdim
c
      logical qpr
c
      real*8 aamatr(kmax,kmax),aimatr(kmax,kmax),gmmatr(kmax,kmax),
     $ delvec(kmax)
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer info,j,k
c
c-----------------------------------------------------------------------
c
c     Copy aamatr to gmmatr.
c
      do k = 1,kdim
        do j = 1,kdim
          gmmatr(j,k) = aamatr(j,k)
        enddo
      enddo
c
c     OR
c
c     do k = 1,kdim
c       call copyaa(aamatr(1,k),gmmatr(1,k),kdim)
c     enddo
c
c     OR
c
c     integer nmax
c     nmax = kmax*kdim
c     call copyaa(aamatr,gmmatr,nmax)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Avoid trying to decompose a zero matrix.
c
      do k = 1,kdim
        do j = 1,kdim
          if (gmmatr(j,k) .ne. 0.) go to 100
        enddo
      enddo
      ier = 1
      if (qpr) then
        write (noutpt,1000)
        write (nttyo,1000)
 1000   format(/' * Note - (EQLIBU/minvrt) Have a zero matrix to',
     $  ' invert.')
      endif
      go to 999
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Factor the matrix (make the L-U decomposition).
c
  100 call dgefa(gmmatr,kmax,kdim,ipivot,info)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Test info.
c
      if (info .ne. 0) then
        ier = 2
        if (qpr) then
          write (noutpt,1010)
          write (nttyo,1010)
 1010     format(/' * Note - (EQLIBU/minvrt) Have a computationally',
     $    ' singular matrix.')
        endif
        go to 999
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Complete the inversion. Loop over columns for the inverted
c     matrix (aimatr).
c
      do k = 1,kdim
c
c       Put the corresponding unit vector in delvec. This serves to
c       set the right-hand-side vector.
c
        do j = 1,kdim
          delvec(j) = 0.
        enddo
        delvec(k) = 1.
c
c       Solve for the unknown vector (delvec). Note that delvec
c       initially contains the right-hand-side vector. Normally
c       separate arrays would be used for the two vectors. This
c       example of bad programming is made here to retain consistency
c       with the original Linpack routine.
c
        call dgesl(gmmatr,kmax,kdim,ipivot,delvec)
c
c       Load the result in the inverted matrix.
c
        do j = 1,kdim
          aimatr(j,k) = delvec(j)
        enddo
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  999 continue
      end


 MODULE module_lightning_nox_ott
 IMPLICIT NONE
 CONTAINS
 SUBROUTINE lightning_nox_ott ( &
                            dx, dy, xlat, xland, ht, rho, z, &
                            ic_flashrate, cg_flashrate, &
                            N_IC, N_CG, &
                            ids, ide, jds, jde, kds, kde, &
                            ims, ime, jms, jme, kms, kme, &
                            its, ite, jts, jte, kts, kte, &
                            lnox_total_tend &
                          )
 USE module_state_description
 USE module_model_constants
 USE module_wrf_error
 IMPLICIT NONE
 REAL, INTENT(IN ) :: dx, dy
 REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: xlat, xland, ht
 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: rho, z
 REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: ic_flashrate , cg_flashrate
 REAL, INTENT(IN ) :: N_IC, N_CG
 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
 INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
 INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( OUT) :: lnox_total_tend
 REAL, PARAMETER :: subtrop_midlat = 35.
 REAL, PARAMETER :: trop_subtrop = 20.
  INTEGER, PARAMETER :: vds = 0
  INTEGER, PARAMETER :: vde = 16
  REAL, DIMENSION(vds:vde), PARAMETER :: &
       ott_subtrop(vde+1) = (/ .010,.020,.039,.058,.077,.093,.105,.110,.110,.104,.092,.075,.055,.034,.015,.002,.000 /)
  REAL, DIMENSION(vds:vde), PARAMETER :: &
       ott_midlat(vde+1) = (/ .024,.050,.074,.093,.106,.114,.115,.110,.099,.083,.063,.042,.022,.005,.000,.000,.000 /)
  REAL, DIMENSION(vds:vde), PARAMETER :: &
       ott_trpcon(vde+1) = (/ .002,.005,.006,.014,.027,.040,.050,.062,.086,.103,.116,.124,.127,.124,.076,.030,.008 /)
  REAL, DIMENSION(vds:vde), PARAMETER :: &
       ott_trpmar(vde+1) = (/ .006,.015,.029,.043,.054,.067,.066,.085,.096,.102,.105,.102,.082,.065,.045,.022,.005 /)
 INTEGER :: i,k,j
 INTEGER :: v
 REAL :: total_NO, mass_of_air, dA
 REAL, DIMENSION( kts:kte ):: zkm
 REAL, DIMENSION( vds:vde ):: NOperkm
 lnox_total_tend(its:ite,kts:kte,jts:jte) = 0.
 dA = dx * dy
 DO J=jts,jte
   DO I=its,ite
     total_NO = ic_flashrate(I,J)*N_IC + cg_flashrate(I,J)*N_CG
     IF ( total_NO .eq. 0. ) CONTINUE
     IF ( xlat(I,J) .gt. subtrop_midlat ) THEN
       NOperkm(:) = ott_midlat(:) * total_NO
     ELSE IF ( xlat(I,J) .gt. trop_subtrop ) THEN
       NOperkm(:) = ott_subtrop(:) * total_NO
     ELSE IF ( xland(I,J) .gt. 1.5 ) THEN
       NOperkm(:) = ott_trpcon(:) * total_NO
     ELSE
       NOperkm(:) = ott_trpmar(:) * total_NO
     ENDIF
     k = kts
     zkm(kts:kte) = ( z(i,kts:kte,j) - ht(i,j) ) / 1000.
     v = MAX( vds, int(zkm(k)) )
     DO WHILE ( (v .le. vde) .and. (k .le. kte) )
       mass_of_air = rho(i,k,j) * 1E3 * dA / .02897
       lnox_total_tend(i,k,j) = NOperkm(v)/mass_of_air * 1E6
       k = k + 1
       IF ( int(zkm(k)) .gt. v ) v = int( zkm(k) )
     ENDDO
   ENDDO
 ENDDO
 END SUBROUTINE lightning_nox_ott
 END MODULE module_lightning_nox_ott


PROGRAM mairyb

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:09

!       ============================================================
!       Purpose: This program computes Airy functions and their
!                derivatives using subroutine AIRYB
!       Input:   x  --- Argument of Airy function
!       Output:  AI --- Ai(x)
!                BI --- Bi(x)
!                AD --- Ai'(x)
!                BD --- Bi'(x)
!       Example:

!   x       Ai(x)          Bi(x)          Ai'(x)         Bi'(x)
!  ----------------------------------------------------------------
!   0   .35502805D+00  .61492663D+00 -.25881940D+00  .44828836D+00
!  10   .11047533D-09  .45564115D+09 -.35206337D-09  .14292361D+10
!  20   .16916729D-26  .21037650D+26 -.75863916D-26  .93818393D+26
!  30   .32082176D-48  .90572885D+47 -.17598766D-47  .49533045D+48

!   x       Ai(-x)         Bi(-x)         Ai'(-x)        Bi'(-x)
!  ----------------------------------------------------------------
!   0       .35502805      .61492663     -.25881940      .44828836
!  10       .04024124     -.31467983      .99626504      .11941411
!  20      -.17640613     -.20013931      .89286286     -.79142903
!  30      -.08796819     -.22444694     1.22862060     -.48369473
!       ============================================================

IMPLICIT DOUBLE PRECISION (a-h,o-z)
WRITE(*,*)'Please enter x '
!        READ(*,*)X
x=20
CALL airyb(x,ai,bi,ad,bd)
WRITE(*,30)
WRITE(*,40)
WRITE(*,10)x,ai,bi,ad,bd
WRITE(*,*)
CALL airyb(-x,ai,bi,ad,bd)
WRITE(*,50)
WRITE(*,40)
WRITE(*,20)x,ai,bi,ad,bd
10      FORMAT(1X,f5.1,4D16.8)
20      FORMAT(1X,f5.1,4D16.8)
30      FORMAT(4X,'x',8X,'Ai(x)',11X,'Bi(x)',11X,'Ai''(X)', 10X,'Bi''(X)')
40      FORMAT(2X,'----------------------------------',  &
    '-----------------------------------')
50      FORMAT(4X,'x',8X,'Ai(-x)',10X,'Bi(-x)',10X, 'Ai''(-X)',9X,'BI''(-X)')
END PROGRAM mairyb

SUBROUTINE airyb(x,ai,bi,ad,bd)

!       =======================================================
!       Purpose: Compute Airy functions and their derivatives
!       Input:   x  --- Argument of Airy function
!       Output:  AI --- Ai(x)
!                BI --- Bi(x)
!                AD --- Ai'(x)
!                BD --- Bi'(x)
!       =======================================================

DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(OUT)            :: ai
DOUBLE PRECISION, INTENT(OUT)            :: bi
DOUBLE PRECISION, INTENT(OUT)            :: ad
DOUBLE PRECISION, INTENT(OUT)            :: bd
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION ck(41),dk(41)

eps=1.0D-15
pi=3.141592653589793D0
c1=0.355028053887817D0
c2=0.258819403792807D0
sr3=1.732050807568877D0
xa=DABS(x)
xq=DSQRT(xa)
IF (x > 0.0D0) xm=5.0
IF (x <= 0.0D0) xm=8.0
IF (x == 0.0D0) THEN
  ai=c1
  bi=sr3*c1
  ad=-c2
  bd=sr3*c2
  RETURN
END IF
IF (xa <= xm) THEN
  fx=1.0D0
  r=1.0D0
  DO  k=1,40
    r=r*x/(3.0D0*k)*x/(3.0D0*k-1.0D0)*x
    fx=fx+r
    IF (DABS(r) < DABS(fx)*eps) EXIT
  END DO
  15         gx=x
  r=x
  DO  k=1,40
    r=r*x/(3.0D0*k)*x/(3.0D0*k+1.0D0)*x
    gx=gx+r
    IF (DABS(r) < DABS(gx)*eps) EXIT
  END DO
  25         ai=c1*fx-c2*gx
  bi=sr3*(c1*fx+c2*gx)
  df=0.5D0*x*x
  r=df
  DO  k=1,40
    r=r*x/(3.0D0*k)*x/(3.0D0*k+2.0D0)*x
    df=df+r
    IF (DABS(r) < DABS(df)*eps) EXIT
  END DO
  35         dg=1.0D0
  r=1.0D0
  DO  k=1,40
    r=r*x/(3.0D0*k)*x/(3.0D0*k-2.0D0)*x
    dg=dg+r
    IF (DABS(r) < DABS(dg)*eps) EXIT
  END DO
  45         ad=c1*df-c2*dg
  bd=sr3*(c1*df+c2*dg)
ELSE
  xe=xa*xq/1.5D0
  xr1=1.0D0/xe
  xar=1.0D0/xq
  xf=DSQRT(xar)
  rp=0.5641895835477563D0
  r=1.0D0
  DO  k=1,40
    r=r*(6.0D0*k-1.0D0)/216.0D0*(6.0D0*k-3.0D0)  &
        /k*(6.0D0*k-5.0D0)/(2.0D0*k-1.0D0)
    ck(k)=r
    dk(k)=-(6.0D0*k+1.0D0)/(6.0D0*k-1.0D0)*ck(k)
  END DO
  km=INT(24.5-xa)
  IF (xa < 6.0) km=14
  IF (xa > 15.0) km=10
  IF (x > 0.0D0) THEN
    sai=1.0D0
    sad=1.0D0
    r=1.0D0
    DO  k=1,km
      r=-r*xr1
      sai=sai+ck(k)*r
      sad=sad+dk(k)*r
    END DO
    sbi=1.0D0
    sbd=1.0D0
    r=1.0D0
    DO  k=1,km
      r=r*xr1
      sbi=sbi+ck(k)*r
      sbd=sbd+dk(k)*r
    END DO
    xp1=DEXP(-xe)
    ai=0.5D0*rp*xf*xp1*sai
    bi=rp*xf/xp1*sbi
    ad=-.5D0*rp/xf*xp1*sad
    bd=rp/xf/xp1*sbd
  ELSE
    xcs=DCOS(xe+pi/4.0D0)
    xss=DSIN(xe+pi/4.0D0)
    ssa=1.0D0
    sda=1.0D0
    r=1.0D0
    xr2=1.0D0/(xe*xe)
    DO  k=1,km
      r=-r*xr2
      ssa=ssa+ck(2*k)*r
      sda=sda+dk(2*k)*r
    END DO
    ssb=ck(1)*xr1
    sdb=dk(1)*xr1
    r=xr1
    DO  k=1,km
      r=-r*xr2
      ssb=ssb+ck(2*k+1)*r
      sdb=sdb+dk(2*k+1)*r
    END DO
    ai=rp*xf*(xss*ssa-xcs*ssb)
    bi=rp*xf*(xcs*ssa+xss*ssb)
    ad=-rp/xf*(xcs*sda+xss*sdb)
    bd=rp/xf*(xss*sda-xcs*sdb)
  END IF
END IF
RETURN
END SUBROUTINE airyb


!< Jiang-Shu (Lagrange) interpolations object for derivative reconstruction.
module wenoof_interpolations_rec_js
!< Jiang-Shu (Lagrange) interpolations object for derivative reconstruction.
!<
!< @note The provided interpolations implement the Lagrange interpolations defined in *Efficient Implementation
!< of Weighted ENO Schemes*, Guang-Shan Jiang, Chi-Wang Shu, JCP, 1996, vol. 126, pp. 202--228, doi:10.1006/jcph.1996.0130 and
!< *Very-high-order weno schemes*, G. A. Gerolymos, D. Senechal, I. Vallet, JCP, 2009, vol. 228, pp. 8481-8524,
!< doi:10.1016/j.jcp.2009.07.039

use penf, only : I_P, R_P, str
use wenoof_base_object, only : base_object, base_object_constructor
use wenoof_interpolations_object, only : interpolations_object, interpolations_object_constructor

implicit none
private
public :: interpolations_rec_js
public :: interpolations_rec_js_constructor

type, extends(interpolations_object_constructor) :: interpolations_rec_js_constructor
  !< Jiang-Shu (Lagrange) interpolations object for derivative reconstruction constructor.
  contains
    ! public deferred methods
    procedure, pass(lhs) :: constr_assign_constr !< `=` operator.
endtype interpolations_rec_js_constructor

type, extends(interpolations_object) :: interpolations_rec_js
  !< Jiang-Shu (Lagrange) interpolations object for derivative reconstruction.
  !<
  !< @note The provided interpolations implement the Lagrange interpolations defined in *Efficient Implementation
  !< of Weighted ENO Schemes*, Guang-Shan Jiang, Chi-Wang Shu, JCP, 1996, vol. 126, pp. 202--228, doi:10.1006/jcph.1996.0130 and
  !< *Very-high-order weno schemes*, G. A. Gerolymos, D. Senechal, I. Vallet, JCP, 2009, vol. 228, pp. 8481-8524,
  !< doi:10.1016/j.jcp.2009.07.039
  private
  real(R_P), allocatable :: coef(:,:,:) !< Polynomial coefficients [1:2,0:S-1,0:S-1].
  contains
    ! public deferred methods
    procedure, pass(self) :: create               !< Create interpolations.
    procedure, pass(self) :: compute_int          !< Compute interpolations (interpolate).
    procedure, pass(self) :: compute_rec          !< Compute interpolations (reconstruct).
    procedure, pass(self) :: description          !< Return object string-description.
    procedure, pass(self) :: destroy              !< Destroy interpolations.
    procedure, pass(lhs)  :: object_assign_object !< `=` operator.
endtype interpolations_rec_js

contains
  ! constructor

  ! deferred public methods
  subroutine constr_assign_constr(lhs, rhs)
  !< `=` operator.
  class(interpolations_rec_js_constructor), intent(inout) :: lhs !< Left hand side.
  class(base_object_constructor),           intent(in)    :: rhs !< Right hand side.

  call lhs%assign_(rhs=rhs)
  endsubroutine constr_assign_constr

  ! public deferred methods
  subroutine create(self, constructor)
  !< Create interpolations.
  class(interpolations_rec_js),   intent(inout) :: self        !< Interpolations.
  class(base_object_constructor), intent(in)    :: constructor !< Interpolations constructor.

  call self%destroy
  call self%create_(constructor=constructor)
  allocate(self%coef(1:2, 0:self%S - 1, 0:self%S - 1))
  associate(c => self%coef)
    select case(self%S)
      case(2) ! 3rd order
        ! 1 => left interface (i-1/2)
        !  cell  0           ;    cell  1
        c(1,0,0) =  0.5_R_P; c(1,1,0) =  0.5_R_P ! stencil 0
        c(1,0,1) = -0.5_R_P; c(1,1,1) =  1.5_R_P ! stencil 1
        ! 2 => right interface (i+1/2)
        !  cell  0           ;    cell  1
        c(2,0,0) =  1.5_R_P; c(2,1,0) = -0.5_R_P ! stencil 0
        c(2,0,1) =  0.5_R_P; c(2,1,1) =  0.5_R_P ! stencil 1
      case(3) ! 5th order
        ! 1 => left interface (i-1/2)
        !  cell  0                 ;    cell  1                 ;    cell  2
        c(1,0,0) =  1._R_P/3._R_P; c(1,1,0) =  5._R_P/6._R_P; c(1,2,0) = -1._R_P/6._R_P ! stencil 0
        c(1,0,1) = -1._R_P/6._R_P; c(1,1,1) =  5._R_P/6._R_P; c(1,2,1) =  1._R_P/3._R_P ! stencil 1
        c(1,0,2) =  1._R_P/3._R_P; c(1,1,2) = -7._R_P/6._R_P; c(1,2,2) = 11._R_P/6._R_P ! stencil 2
        ! 2 => right interface (i+1/2)
        !  cell  0                 ;    cell  1                 ;    cell  2
        c(2,0,0) = 11._R_P/6._R_P; c(2,1,0) = -7._R_P/6._R_P; c(2,2,0) =  1._R_P/3._R_P ! stencil 0
        c(2,0,1) =  1._R_P/3._R_P; c(2,1,1) =  5._R_P/6._R_P; c(2,2,1) = -1._R_P/6._R_P ! stencil 1
        c(2,0,2) = -1._R_P/6._R_P; c(2,1,2) =  5._R_P/6._R_P; c(2,2,2) =  1._R_P/3._R_P ! stencil 2
      case(4) ! 7th order
        ! 1 => left interface (i-1/2)
        !  cell  0               ;    cell  1               ;    cell  2               ;    cell  3
        c(1,0,0)=  1._R_P/4._R_P ; c(1,1,0)= 13._R_P/12._R_P; c(1,2,0)= -5._R_P/12._R_P; c(1,3,0)=  1._R_P/12._R_P ! stencil 0
        c(1,0,1)= -1._R_P/12._R_P; c(1,1,1)=  7._R_P/12._R_P; c(1,2,1)=  7._R_P/12._R_P; c(1,3,1)= -1._R_P/12._R_P ! stencil 1
        c(1,0,2)=  1._R_P/12._R_P; c(1,1,2)= -5._R_P/12._R_P; c(1,2,2)= 13._R_P/12._R_P; c(1,3,2)=  1._R_P/4._R_P  ! stencil 2
        c(1,0,3)= -1._R_P/4._R_P ; c(1,1,3)= 13._R_P/12._R_P; c(1,2,3)=-23._R_P/12._R_P; c(1,3,3)= 25._R_P/12._R_P ! stencil 3
        ! 2 => right interface (i+1/2)
        !  cell  0               ;    cell  1               ;   cell  2                ;    cell  3
        c(2,0,0)= 25._R_P/12._R_P; c(2,1,0)=-23._R_P/12._R_P; c(2,2,0)= 13._R_P/12._R_P; c(2,3,0)= -1._R_P/4._R_P  ! stencil 0
        c(2,0,1)=  1._R_P/4._R_P ; c(2,1,1)= 13._R_P/12._R_P; c(2,2,1)= -5._R_P/12._R_P; c(2,3,1)=  1._R_P/12._R_P ! stencil 1
        c(2,0,2)= -1._R_P/12._R_P; c(2,1,2)=  7._R_P/12._R_P; c(2,2,2)=  7._R_P/12._R_P; c(2,3,2)= -1._R_P/12._R_P ! stencil 2
        c(2,0,3)=  1._R_P/12._R_P; c(2,1,3)= -5._R_P/12._R_P; c(2,2,3)= 13._R_P/12._R_P; c(2,3,3)=  1._R_P/4._R_P  ! stencil 3
      case(5) ! 9th order
        ! 1 => left interface (i-1/2)
        !  cell  0                ;    cell  1                ;    cell  2                ;    cell  3
        c(1,0,0)=   1._R_P/5._R_P ; c(1,1,0)=  77._R_P/60._R_P; c(1,2,0)= -43._R_P/60._R_P; c(1,3,0)=  17._R_P/60._R_P  ! stencil 0
        c(1,0,1)=  -1._R_P/20._R_P; c(1,1,1)=   9._R_P/20._R_P; c(1,2,1)=  47._R_P/60._R_P; c(1,3,1)= -13._R_P/60._R_P  ! stencil 1
        c(1,0,2)=   1._R_P/30._R_P; c(1,1,2)= -13._R_P/60._R_P; c(1,2,2)=  47._R_P/60._R_P; c(1,3,2)=   9._R_P/20._R_P  ! stencil 2
        c(1,0,3)=  -1._R_P/20._R_P; c(1,1,3)=  17._R_P/60._R_P; c(1,2,3)= -43._R_P/60._R_P; c(1,3,3)=  77._R_P/60._R_P  ! stencil 3
        c(1,0,4)=   1._R_P/5._R_P ; c(1,1,4)= -21._R_P/20._R_P; c(1,2,4)= 137._R_P/60._R_P; c(1,3,4)=-163._R_P/60._R_P  ! stencil 4
        !  cell  4
        c(1,4,0)=  -1._R_P/20._R_P  ! stencil 0
        c(1,4,1)=   1._R_P/30._R_P  ! stencil 1
        c(1,4,2)=  -1._R_P/20._R_P  ! stencil 2
        c(1,4,3)=   1._R_P/5._R_P   ! stencil 3
        c(1,4,4)= 137._R_P/60._R_P  ! stencil 4
        ! 2 => right interface (i+1/2)
        !  cell  0               ;    cell  1               ;   cell  2                ;    cell  3
        c(2,0,0)= 137._R_P/60._R_P; c(2,1,0)=-163._R_P/60._R_P; c(2,2,0)= 137._R_P/60._R_P; c(2,3,0)= -21._R_P/20._R_P  ! stencil 0
        c(2,0,1)=   1._R_P/5._R_P ; c(2,1,1)=  77._R_P/60._R_P; c(2,2,1)= -43._R_P/60._R_P; c(2,3,1)=  17._R_P/60._R_P  ! stencil 1
        c(2,0,2)=  -1._R_P/20._R_P; c(2,1,2)=   9._R_P/20._R_P; c(2,2,2)=  47._R_P/60._R_P; c(2,3,2)= -13._R_P/60._R_P  ! stencil 2
        c(2,0,3)=   1._R_P/30._R_P; c(2,1,3)= -13._R_P/60._R_P; c(2,2,3)=  47._R_P/60._R_P; c(2,3,3)=   9._R_P/20._R_P  ! stencil 3
        c(2,0,4)=  -1._R_P/20._R_P; c(2,1,4)=  17._R_P/60._R_P; c(2,2,4)= -43._R_P/60._R_P; c(2,3,4)=  77._R_P/60._R_P  ! stencil 4
        !  cell  4
        c(2,4,0)=   1._R_P/5._R_P  ! stencil 0
        c(2,4,1)=  -1._R_P/20._R_P ! stencil 1
        c(2,4,2)=   1._R_P/30._R_P ! stencil 2
        c(2,4,3)=  -1._R_P/20._R_P ! stencil 3
        c(2,4,4)=   1._R_P/5._R_P  ! stencil 4
      case(6) ! 11th order
        ! 1 => left interface (i-1/2)
        !  cell  0                ;    cell  1                ;    cell  2                ;    cell  3
        c(1,0,0)=   1._R_P/6._R_P ; c(1,1,0)=  29._R_P/20._R_P; c(1,2,0)= -21._R_P/20._R_P; c(1,3,0)=  37._R_P/60._R_P  ! stencil 0
        c(1,0,1)=  -1._R_P/30._R_P; c(1,1,1)=  11._R_P/30._R_P; c(1,2,1)=  19._R_P/20._R_P; c(1,3,1)= -23._R_P/60._R_P  ! stencil 1
        c(1,0,2)=   1._R_P/60._R_P; c(1,1,2)=  -2._R_P/15._R_P; c(1,2,2)=  37._R_P/60._R_P; c(1,3,2)=  37._R_P/60._R_P  ! stencil 2
        c(1,0,3)=  -1._R_P/60._R_P; c(1,1,3)=   7._R_P/60._R_P; c(1,2,3)= -23._R_P/60._R_P; c(1,3,3)=  19._R_P/20._R_P  ! stencil 3
        c(1,0,4)=   1._R_P/30._R_P; c(1,1,4)= -13._R_P/60._R_P; c(1,2,4)=  37._R_P/60._R_P; c(1,3,4)= -21._R_P/20._R_P  ! stencil 4
        c(1,0,5)=  -1._R_P/6._R_P ; c(1,1,5)=  31._R_P/30._R_P; c(1,2,5)=-163._R_P/60._R_P; c(1,3,5)=  79._R_P/20._R_P  ! stencil 5
        !  cell  4                ;    cell  5
        c(1,4,0)= -13._R_P/60._R_P; c(1,5,0)=   1._R_P/30._R_P  ! stencil 0
        c(1,4,1)=   7._R_P/60._R_P; c(1,5,1)=  -1._R_P/60._R_P  ! stencil 1
        c(1,4,2)=  -2._R_P/15._R_P; c(1,5,2)=   1._R_P/60._R_P  ! stencil 2
        c(1,4,3)=  11._R_P/30._R_P; c(1,5,3)=  -1._R_P/30._R_P  ! stencil 3
        c(1,4,4)=  29._R_P/20._R_P; c(1,5,4)=   1._R_P/6._R_P   ! stencil 4
        c(1,4,5)= -71._R_P/20._R_P; c(1,5,5)=  49._R_P/20._R_P  ! stencil 5
        ! 2 => right interface (i+1/2)
        !  cell  0                ;    cell  1                ;   cell  2                 ;    cell  3
        c(2,0,0)=  49._R_P/20._R_P; c(2,1,0)= -71._R_P/20._R_P; c(2,2,0)=  79._R_P/20._R_P; c(2,3,0)=-163._R_P/60._R_P  ! stencil 0
        c(2,0,1)=   1._R_P/6._R_P ; c(2,1,1)=  29._R_P/20._R_P; c(2,2,1)= -21._R_P/20._R_P; c(2,3,1)=  37._R_P/60._R_P  ! stencil 1
        c(2,0,2)=  -1._R_P/30._R_P; c(2,1,2)=  11._R_P/30._R_P; c(2,2,2)=  19._R_P/20._R_P; c(2,3,2)= -23._R_P/60._R_P  ! stencil 2
        c(2,0,3)=   1._R_P/60._R_P; c(2,1,3)=  -2._R_P/15._R_P; c(2,2,3)=  37._R_P/60._R_P; c(2,3,3)=  37._R_P/60._R_P  ! stencil 3
        c(2,0,4)=  -1._R_P/60._R_P; c(2,1,4)=   7._R_P/60._R_P; c(2,2,4)= -23._R_P/60._R_P; c(2,3,4)=  19._R_P/20._R_P  ! stencil 4
        c(2,0,5)=   1._R_P/30._R_P; c(2,1,5)= -13._R_P/60._R_P; c(2,2,5)=  37._R_P/60._R_P; c(2,3,5)= -21._R_P/20._R_P  ! stencil 5
        !  cell  4                ;    cell  5
        c(2,4,0)=  31._R_P/30._R_P; c(2,5,0)=  -1._R_P/6._R_P   ! stencil 0
        c(2,4,1)= -13._R_P/60._R_P; c(2,5,1)=   1._R_P/30._R_P  ! stencil 1
        c(2,4,2)=   7._R_P/60._R_P; c(2,5,2)=  -1._R_P/60._R_P  ! stencil 2
        c(2,4,3)=  -2._R_P/15._R_P; c(2,5,3)=   1._R_P/60._R_P  ! stencil 3
        c(2,4,4)=  11._R_P/30._R_P; c(2,5,4)=  -1._R_P/30._R_P  ! stencil 4
        c(2,4,5)=  29._R_P/20._R_P; c(2,5,5)=   1._R_P/6._R_P   ! stencil 5
      case(7) ! 13th order
        ! 1 => left interface (i-1/2)
        !  stencil  6                ;    stencil  5               ;    stencil  4
        c(1,0,6)=   60._R_P/ 420._R_P; c(1,0,5)= -10._R_P/ 420._R_P; c(1,0,4)=   4._R_P/ 420._R_P  ! cell 0
        c(1,1,6)= -430._R_P/ 420._R_P; c(1,1,5)=  74._R_P/ 420._R_P; c(1,1,4)= -31._R_P/ 420._R_P  ! cell 1
        c(1,2,6)= 1334._R_P/ 420._R_P; c(1,2,5)=-241._R_P/ 420._R_P; c(1,2,4)= 109._R_P/ 420._R_P  ! cell 2
        c(1,3,6)=-2341._R_P/ 420._R_P; c(1,3,5)= 459._R_P/ 420._R_P; c(1,3,4)=-241._R_P/ 420._R_P  ! cell 3
        c(1,4,6)= 2559._R_P/ 420._R_P; c(1,4,5)=-591._R_P/ 420._R_P; c(1,4,4)= 459._R_P/ 420._R_P  ! cell 4
        c(1,5,6)=-1851._R_P/ 420._R_P; c(1,5,5)= 669._R_P/ 420._R_P; c(1,5,4)= 130._R_P/ 420._R_P  ! cell 5
        c(1,6,6)= 1089._R_P/ 420._R_P; c(1,6,5)=  60._R_P/ 420._R_P; c(1,6,4)= -10._R_P/ 420._R_P  ! cell 6
        !  stencil  3                ;    stencil  2               ;    stencil  1
        c(1,0,3)=   -3._R_P/ 420._R_P; c(1,0,2)=   4._R_P/ 420._R_P; c(1,0,1)= -10._R_P/ 420._R_P  ! cell 0
        c(1,1,3)=   25._R_P/ 420._R_P; c(1,1,2)= -38._R_P/ 420._R_P; c(1,1,1)= 130._R_P/ 420._R_P  ! cell 1
        c(1,2,3)= -101._R_P/ 420._R_P; c(1,2,2)= 214._R_P/ 420._R_P; c(1,2,1)= 459._R_P/ 420._R_P  ! cell 2
        c(1,3,3)=  319._R_P/ 420._R_P; c(1,3,2)= 319._R_P/ 420._R_P; c(1,3,1)=-241._R_P/ 420._R_P  ! cell 3
        c(1,4,3)=  214._R_P/ 420._R_P; c(1,4,2)=-101._R_P/ 420._R_P; c(1,4,1)= 109._R_P/ 420._R_P  ! cell 4
        c(1,5,3)=  -38._R_P/ 420._R_P; c(1,5,2)=  25._R_P/ 420._R_P; c(1,5,1)= -31._R_P/ 420._R_P  ! cell 5
        c(1,6,3)=    4._R_P/ 420._R_P; c(1,6,2)=  -3._R_P/ 420._R_P; c(1,6,1)=   4._R_P/ 420._R_P  ! cell 6
        !  stencil  0
        c(1,0,0)=   60._R_P/ 420._R_P  ! cell 0
        c(1,1,0)=  669._R_P/ 420._R_P  ! cell 1
        c(1,2,0)= -591._R_P/ 420._R_P  ! cell 2
        c(1,3,0)=  459._R_P/ 420._R_P  ! cell 3
        c(1,4,0)= -241._R_P/ 420._R_P  ! cell 4
        c(1,5,0)=   74._R_P/ 420._R_P  ! cell 5
        c(1,6,0)=  -10._R_P/ 420._R_P  ! cell 6
        ! 2 => right interface (i+1/2)
        !  stencil  0                ;    stencil  1               ;    stencil  2
        c(2,6,0)=   60._R_P/ 420._R_P; c(2,6,1)= -10._R_P/ 420._R_P; c(2,6,2)=   4._R_P/ 420._R_P  ! cell 6
        c(2,5,0)= -430._R_P/ 420._R_P; c(2,5,1)=  74._R_P/ 420._R_P; c(2,5,2)= -31._R_P/ 420._R_P  ! cell 5
        c(2,4,0)= 1334._R_P/ 420._R_P; c(2,4,1)=-241._R_P/ 420._R_P; c(2,4,2)= 109._R_P/ 420._R_P  ! cell 4
        c(2,3,0)=-2341._R_P/ 420._R_P; c(2,3,1)= 459._R_P/ 420._R_P; c(2,3,2)=-241._R_P/ 420._R_P  ! cell 3
        c(2,2,0)= 2559._R_P/ 420._R_P; c(2,2,1)=-591._R_P/ 420._R_P; c(2,2,2)= 459._R_P/ 420._R_P  ! cell 2
        c(2,1,0)=-1851._R_P/ 420._R_P; c(2,1,1)= 669._R_P/ 420._R_P; c(2,1,2)= 130._R_P/ 420._R_P  ! cell 1
        c(2,0,0)= 1089._R_P/ 420._R_P; c(2,0,1)=  60._R_P/ 420._R_P; c(2,0,2)= -10._R_P/ 420._R_P  ! cell 0
        !  stencil  3                ;    stencil  4               ;    stencil  5
        c(2,6,3)=   -3._R_P/ 420._R_P; c(2,6,4)=   4._R_P/ 420._R_P; c(2,6,5)= -10._R_P/ 420._R_P  ! cell 6
        c(2,5,3)=   25._R_P/ 420._R_P; c(2,5,4)= -38._R_P/ 420._R_P; c(2,5,5)= 130._R_P/ 420._R_P  ! cell 5
        c(2,4,3)= -101._R_P/ 420._R_P; c(2,4,4)= 214._R_P/ 420._R_P; c(2,4,5)= 459._R_P/ 420._R_P  ! cell 4
        c(2,3,3)=  319._R_P/ 420._R_P; c(2,3,4)= 319._R_P/ 420._R_P; c(2,3,5)=-241._R_P/ 420._R_P  ! cell 3
        c(2,2,3)=  214._R_P/ 420._R_P; c(2,2,4)=-101._R_P/ 420._R_P; c(2,2,5)= 109._R_P/ 420._R_P  ! cell 2
        c(2,1,3)=  -38._R_P/ 420._R_P; c(2,1,4)=  25._R_P/ 420._R_P; c(2,1,5)= -31._R_P/ 420._R_P  ! cell 1
        c(2,0,3)=    4._R_P/ 420._R_P; c(2,0,4)=  -3._R_P/ 420._R_P; c(2,0,5)=   4._R_P/ 420._R_P  ! cell 0
        !  stencil  6
        c(2,6,6)=  60._R_P/ 420._R_P  ! cell 6
        c(2,5,6)= 669._R_P/ 420._R_P  ! cell 5
        c(2,4,6)=-591._R_P/ 420._R_P  ! cell 4
        c(2,3,6)= 459._R_P/ 420._R_P  ! cell 3
        c(2,2,6)=-241._R_P/ 420._R_P  ! cell 2
        c(2,1,6)=  74._R_P/ 420._R_P  ! cell 1
        c(2,0,6)=- 10._R_P/ 420._R_P  ! cell 0
      case(8) ! 15th order
        ! 1 => left interface (i-1/2)
        !  stencil  7                ;    stencil  6                ;    stencil  5
        c(1,0,7)= -105._R_P/ 840._R_P; c(1,0,6)=   15._R_P/ 840._R_P; c(1,0,5)=   -5._R_P/ 840._R_P  ! cell 0
        c(1,1,7)=  855._R_P/ 840._R_P; c(1,1,6)= -125._R_P/ 840._R_P; c(1,1,5)=   43._R_P/ 840._R_P  ! cell 1
        c(1,2,7)=-3065._R_P/ 840._R_P; c(1,2,6)=  463._R_P/ 840._R_P; c(1,2,5)= -167._R_P/ 840._R_P  ! cell 2
        c(1,3,7)= 6343._R_P/ 840._R_P; c(1,3,6)=-1007._R_P/ 840._R_P; c(1,3,5)=  393._R_P/ 840._R_P  ! cell 3
        c(1,4,7)=-8357._R_P/ 840._R_P; c(1,4,6)= 1443._R_P/ 840._R_P; c(1,4,5)= -657._R_P/ 840._R_P  ! cell 4
        c(1,5,7)= 7323._R_P/ 840._R_P; c(1,5,6)=-1497._R_P/ 840._R_P; c(1,5,5)= 1023._R_P/ 840._R_P  ! cell 5
        c(1,6,7)=-4437._R_P/ 840._R_P; c(1,6,6)= 1443._R_P/ 840._R_P; c(1,6,5)=  225._R_P/ 840._R_P  ! cell 6
        c(1,7,7)= 2283._R_P/ 840._R_P; c(1,7,6)=  105._R_P/ 840._R_P; c(1,7,5)=  -15._R_P/ 840._R_P  ! cell 7
        !  stencil  4                ;    stencil  3                ;    stencil  2
        c(1,0,4)=    3._R_P/ 840._R_P; c(1,0,3)=   -3._R_P/ 840._R_P; c(1,0,2)=    5._R_P/ 840._R_P  ! cell 0
        c(1,1,4)=  -27._R_P/ 840._R_P; c(1,1,3)=   29._R_P/ 840._R_P; c(1,1,2)=  -55._R_P/ 840._R_P  ! cell 1
        c(1,2,4)=  113._R_P/ 840._R_P; c(1,2,3)= -139._R_P/ 840._R_P; c(1,2,2)=  365._R_P/ 840._R_P  ! cell 2
        c(1,3,4)= -307._R_P/ 840._R_P; c(1,3,3)=  533._R_P/ 840._R_P; c(1,3,2)=  743._R_P/ 840._R_P  ! cell 3
        c(1,4,4)=  743._R_P/ 840._R_P; c(1,4,3)=  533._R_P/ 840._R_P; c(1,4,2)= -307._R_P/ 840._R_P  ! cell 4
        c(1,5,4)=  365._R_P/ 840._R_P; c(1,5,3)= -139._R_P/ 840._R_P; c(1,5,2)=  113._R_P/ 840._R_P  ! cell 5
        c(1,6,4)=  -55._R_P/ 840._R_P; c(1,6,3)=   29._R_P/ 840._R_P; c(1,6,2)=  -27._R_P/ 840._R_P  ! cell 6
        c(1,7,4)=    5._R_P/ 840._R_P; c(1,7,3)=   -3._R_P/ 840._R_P; c(1,7,2)=    3._R_P/ 840._R_P  ! cell 7
        !  stencil  1                ;    stencil  0
        c(1,0,1)=  -15._R_P/ 840._R_P; c(1,0,0)=  105._R_P/ 840._R_P  ! cell 0
        c(1,1,1)=  225._R_P/ 840._R_P; c(1,1,0)= 1443._R_P/ 840._R_P  ! cell 1
        c(1,2,1)= 1023._R_P/ 840._R_P; c(1,2,0)=-1497._R_P/ 840._R_P  ! cell 2
        c(1,3,1)= -657._R_P/ 840._R_P; c(1,3,0)= 1443._R_P/ 840._R_P  ! cell 3
        c(1,4,1)=  393._R_P/ 840._R_P; c(1,4,0)=-1007._R_P/ 840._R_P  ! cell 4
        c(1,5,1)= -167._R_P/ 840._R_P; c(1,5,0)=  463._R_P/ 840._R_P  ! cell 5
        c(1,6,1)=   43._R_P/ 840._R_P; c(1,6,0)= -125._R_P/ 840._R_P  ! cell 6
        c(1,7,1)=   -5._R_P/ 840._R_P; c(1,7,0)=   15._R_P/ 840._R_P  ! cell 7
        ! 2 => right interface (i+1/2)
        !  stencil  0                ;    stencil  1                ;    stencil  2
        c(2,7,0)= -105._R_P/ 840._R_P; c(2,7,1)=   15._R_P/ 840._R_P; c(2,7,2)=   -5._R_P/ 840._R_P  ! cell 7
        c(2,6,0)=  855._R_P/ 840._R_P; c(2,6,1)= -125._R_P/ 840._R_P; c(2,6,2)=   43._R_P/ 840._R_P  ! cell 6
        c(2,5,0)=-3065._R_P/ 840._R_P; c(2,5,1)=  463._R_P/ 840._R_P; c(2,5,2)= -167._R_P/ 840._R_P  ! cell 5
        c(2,4,0)= 6343._R_P/ 840._R_P; c(2,4,1)=-1007._R_P/ 840._R_P; c(2,4,2)=  393._R_P/ 840._R_P  ! cell 4
        c(2,3,0)=-8357._R_P/ 840._R_P; c(2,3,1)= 1443._R_P/ 840._R_P; c(2,3,2)= -657._R_P/ 840._R_P  ! cell 3
        c(2,2,0)= 7323._R_P/ 840._R_P; c(2,2,1)=-1497._R_P/ 840._R_P; c(2,2,2)= 1023._R_P/ 840._R_P  ! cell 2
        c(2,1,0)=-4437._R_P/ 840._R_P; c(2,1,1)= 1443._R_P/ 840._R_P; c(2,1,2)=  225._R_P/ 840._R_P  ! cell 1
        c(2,0,0)= 2283._R_P/ 840._R_P; c(2,0,1)=  105._R_P/ 840._R_P; c(2,0,2)=  -15._R_P/ 840._R_P  ! cell 0
        !  stencil  3                ;    stencil  4                ;    stencil  5
        c(2,7,3)=    3._R_P/ 840._R_P; c(2,7,4)=   -3._R_P/ 840._R_P; c(2,7,5)=    5._R_P/ 840._R_P  ! cell 7
        c(2,6,3)=  -27._R_P/ 840._R_P; c(2,6,4)=   29._R_P/ 840._R_P; c(2,6,5)=  -55._R_P/ 840._R_P  ! cell 6
        c(2,5,3)=  113._R_P/ 840._R_P; c(2,5,4)= -139._R_P/ 840._R_P; c(2,5,5)=  365._R_P/ 840._R_P  ! cell 5
        c(2,4,3)= -307._R_P/ 840._R_P; c(2,4,4)=  533._R_P/ 840._R_P; c(2,4,5)=  743._R_P/ 840._R_P  ! cell 4
        c(2,3,3)=  743._R_P/ 840._R_P; c(2,3,4)=  533._R_P/ 840._R_P; c(2,3,5)= -307._R_P/ 840._R_P  ! cell 3
        c(2,2,3)=  365._R_P/ 840._R_P; c(2,2,4)= -139._R_P/ 840._R_P; c(2,2,5)=  113._R_P/ 840._R_P  ! cell 2
        c(2,1,3)=  -55._R_P/ 840._R_P; c(2,1,4)=   29._R_P/ 840._R_P; c(2,1,5)=  -27._R_P/ 840._R_P  ! cell 1
        c(2,0,3)=    5._R_P/ 840._R_P; c(2,0,4)=   -3._R_P/ 840._R_P; c(2,0,5)=    3._R_P/ 840._R_P  ! cell 0
        !  stencil  6                ;    stencil  7
        c(2,7,6)=  -15._R_P/ 840._R_P; c(2,7,7)=  105._R_P/ 840._R_P  ! cell 7
        c(2,6,6)=  225._R_P/ 840._R_P; c(2,6,7)= 1443._R_P/ 840._R_P  ! cell 6
        c(2,5,6)= 1023._R_P/ 840._R_P; c(2,5,7)=-1497._R_P/ 840._R_P  ! cell 5
        c(2,4,6)= -657._R_P/ 840._R_P; c(2,4,7)= 1443._R_P/ 840._R_P  ! cell 4
        c(2,3,6)=  393._R_P/ 840._R_P; c(2,3,7)=-1007._R_P/ 840._R_P  ! cell 3
        c(2,2,6)= -167._R_P/ 840._R_P; c(2,2,7)=  463._R_P/ 840._R_P  ! cell 2
        c(2,1,6)=   43._R_P/ 840._R_P; c(2,1,7)= -125._R_P/ 840._R_P  ! cell 1
        c(2,0,6)=   -5._R_P/ 840._R_P; c(2,0,7)=   15._R_P/ 840._R_P  ! cell 0
      case(9) ! 17th order
        ! 1 => left interface (i-1/2)
        !  stencil  8                  ;    stencil  7                  ;    stencil  6
        c(1,0,8)=   280._R_P/ 2520._R_P; c(1,0,7)=   -35._R_P/ 2520._R_P; c(1,0,6)=    10._R_P/ 2520._R_P  ! cell 0
        c(1,1,8)= -2555._R_P/ 2520._R_P; c(1,1,7)=   325._R_P/ 2520._R_P; c(1,1,6)=   -95._R_P/ 2520._R_P  ! cell 1
        c(1,2,8)= 10405._R_P/ 2520._R_P; c(1,2,7)= -1355._R_P/ 2520._R_P; c(1,2,6)=   409._R_P/ 2520._R_P  ! cell 2
        c(1,3,8)=-24875._R_P/ 2520._R_P; c(1,3,7)=  3349._R_P/ 2520._R_P; c(1,3,6)= -1061._R_P/ 2520._R_P  ! cell 3
        c(1,4,8)= 38629._R_P/ 2520._R_P; c(1,4,7)= -5471._R_P/ 2520._R_P; c(1,4,6)=  1879._R_P/ 2520._R_P  ! cell 4
        c(1,5,8)=-40751._R_P/ 2520._R_P; c(1,5,7)=  6289._R_P/ 2520._R_P; c(1,5,6)= -2531._R_P/ 2520._R_P  ! cell 5
        c(1,6,8)= 29809._R_P/ 2520._R_P; c(1,6,7)= -5471._R_P/ 2520._R_P; c(1,6,6)=  3349._R_P/ 2520._R_P  ! cell 6
        c(1,7,8)=-15551._R_P/ 2520._R_P; c(1,7,7)=  4609._R_P/ 2520._R_P; c(1,7,6)=   595._R_P/ 2520._R_P  ! cell 7
        c(1,8,8)=  7129._R_P/ 2520._R_P; c(1,8,7)=   280._R_P/ 2520._R_P; c(1,8,6)=-   35._R_P/ 2520._R_P  ! cell 8
        !  stencil  5                  ;    stencil  4                  ;    stencil  3
        c(1,0,5)=    -5._R_P/ 2520._R_P; c(1,0,4)=     4._R_P/ 2520._R_P; c(1,0,3)=    -5._R_P/ 2520._R_P  ! cell 0
        c(1,1,5)=    49._R_P/ 2520._R_P; c(1,1,4)=   -41._R_P/ 2520._R_P; c(1,1,3)=    55._R_P/ 2520._R_P  ! cell 1
        c(1,2,5)=  -221._R_P/ 2520._R_P; c(1,2,4)=   199._R_P/ 2520._R_P; c(1,2,3)=  -305._R_P/ 2520._R_P  ! cell 2
        c(1,3,5)=   619._R_P/ 2520._R_P; c(1,3,4)=  -641._R_P/ 2520._R_P; c(1,3,3)=  1375._R_P/ 2520._R_P  ! cell 3
        c(1,4,5)= -1271._R_P/ 2520._R_P; c(1,4,4)=  1879._R_P/ 2520._R_P; c(1,4,3)=  1879._R_P/ 2520._R_P  ! cell 4
        c(1,5,5)=  2509._R_P/ 2520._R_P; c(1,5,4)=  1375._R_P/ 2520._R_P; c(1,5,3)=  -641._R_P/ 2520._R_P  ! cell 5
        c(1,6,5)=   955._R_P/ 2520._R_P; c(1,6,4)=  -305._R_P/ 2520._R_P; c(1,6,3)=   199._R_P/ 2520._R_P  ! cell 6
        c(1,7,5)=  -125._R_P/ 2520._R_P; c(1,7,4)=    55._R_P/ 2520._R_P; c(1,7,3)=   -41._R_P/ 2520._R_P  ! cell 7
        c(1,8,5)=    10._R_P/ 2520._R_P; c(1,8,4)=    -5._R_P/ 2520._R_P; c(1,8,3)=     4._R_P/ 2520._R_P  ! cell 8
        !  stencil  2                  ;    stencil  1                  ;    stencil  0
        c(1,0,2)=    10._R_P/ 2520._R_P; c(1,0,1)=   -35._R_P/ 2520._R_P; c(1,0,0)=   280._R_P/ 2520._R_P  ! cell 0
        c(1,1,2)=  -125._R_P/ 2520._R_P; c(1,1,1)=   595._R_P/ 2520._R_P; c(1,1,0)=  4609._R_P/ 2520._R_P  ! cell 1
        c(1,2,2)=   955._R_P/ 2520._R_P; c(1,2,1)=  3349._R_P/ 2520._R_P; c(1,2,0)= -5471._R_P/ 2520._R_P  ! cell 2
        c(1,3,2)=  2509._R_P/ 2520._R_P; c(1,3,1)= -2531._R_P/ 2520._R_P; c(1,3,0)=  6289._R_P/ 2520._R_P  ! cell 3
        c(1,4,2)= -1271._R_P/ 2520._R_P; c(1,4,1)=  1879._R_P/ 2520._R_P; c(1,4,0)= -5471._R_P/ 2520._R_P  ! cell 4
        c(1,5,2)=   619._R_P/ 2520._R_P; c(1,5,1)= -1061._R_P/ 2520._R_P; c(1,5,0)=  3349._R_P/ 2520._R_P  ! cell 5
        c(1,6,2)=  -221._R_P/ 2520._R_P; c(1,6,1)=   409._R_P/ 2520._R_P; c(1,6,0)= -1355._R_P/ 2520._R_P  ! cell 6
        c(1,7,2)=    49._R_P/ 2520._R_P; c(1,7,1)=   -95._R_P/ 2520._R_P; c(1,7,0)=   325._R_P/ 2520._R_P  ! cell 7
        c(1,8,2)=    -5._R_P/ 2520._R_P; c(1,8,1)=    10._R_P/ 2520._R_P; c(1,8,0)=   -35._R_P/ 2520._R_P  ! cell 8
        ! 2 => right interface (i+1/2)
        !  stencil  0                  ;    stencil  1                  ;    stencil  2
        c(2,8,0)=   280._R_P/ 2520._R_P; c(2,8,1)=   -35._R_P/ 2520._R_P; c(2,8,2)=    10._R_P/ 2520._R_P  ! cell 8
        c(2,7,0)= -2555._R_P/ 2520._R_P; c(2,7,1)=   325._R_P/ 2520._R_P; c(2,7,2)=   -95._R_P/ 2520._R_P  ! cell 7
        c(2,6,0)= 10405._R_P/ 2520._R_P; c(2,6,1)= -1355._R_P/ 2520._R_P; c(2,6,2)=   409._R_P/ 2520._R_P  ! cell 6
        c(2,5,0)=-24875._R_P/ 2520._R_P; c(2,5,1)=  3349._R_P/ 2520._R_P; c(2,5,2)= -1061._R_P/ 2520._R_P  ! cell 5
        c(2,4,0)= 38629._R_P/ 2520._R_P; c(2,4,1)= -5471._R_P/ 2520._R_P; c(2,4,2)=  1879._R_P/ 2520._R_P  ! cell 4
        c(2,3,0)=-40751._R_P/ 2520._R_P; c(2,3,1)=  6289._R_P/ 2520._R_P; c(2,3,2)= -2531._R_P/ 2520._R_P  ! cell 3
        c(2,2,0)= 29809._R_P/ 2520._R_P; c(2,2,1)= -5471._R_P/ 2520._R_P; c(2,2,2)=  3349._R_P/ 2520._R_P  ! cell 2
        c(2,1,0)=-15551._R_P/ 2520._R_P; c(2,1,1)=  4609._R_P/ 2520._R_P; c(2,1,2)=   595._R_P/ 2520._R_P  ! cell 1
        c(2,0,0)=  7129._R_P/ 2520._R_P; c(2,0,1)=   280._R_P/ 2520._R_P; c(2,0,2)=   -35._R_P/ 2520._R_P  ! cell 0
        !  stencil  3                  ;    stencil  4                  ;    stencil  5
        c(2,8,3)=    -5._R_P/ 2520._R_P; c(2,8,4)=     4._R_P/ 2520._R_P; c(2,8,5)=    -5._R_P/ 2520._R_P  ! cell 8
        c(2,7,3)=    49._R_P/ 2520._R_P; c(2,7,4)=   -41._R_P/ 2520._R_P; c(2,7,5)=    55._R_P/ 2520._R_P  ! cell 7
        c(2,6,3)=  -221._R_P/ 2520._R_P; c(2,6,4)=   199._R_P/ 2520._R_P; c(2,6,5)=  -305._R_P/ 2520._R_P  ! cell 6
        c(2,5,3)=   619._R_P/ 2520._R_P; c(2,5,4)=  -641._R_P/ 2520._R_P; c(2,5,5)=  1375._R_P/ 2520._R_P  ! cell 5
        c(2,4,3)= -1271._R_P/ 2520._R_P; c(2,4,4)=  1879._R_P/ 2520._R_P; c(2,4,5)=  1879._R_P/ 2520._R_P  ! cell 4
        c(2,3,3)=  2509._R_P/ 2520._R_P; c(2,3,4)=  1375._R_P/ 2520._R_P; c(2,3,5)=  -641._R_P/ 2520._R_P  ! cell 3
        c(2,2,3)=   955._R_P/ 2520._R_P; c(2,2,4)=  -305._R_P/ 2520._R_P; c(2,2,5)=   199._R_P/ 2520._R_P  ! cell 2
        c(2,1,3)=  -125._R_P/ 2520._R_P; c(2,1,4)=    55._R_P/ 2520._R_P; c(2,1,5)=   -41._R_P/ 2520._R_P  ! cell 1
        c(2,0,3)=    10._R_P/ 2520._R_P; c(2,0,4)=    -5._R_P/ 2520._R_P; c(2,0,5)=     4._R_P/ 2520._R_P  ! cell 0
        !  stencil  6                  ;    stencil  7                  ;    stencil  8
        c(2,8,6)=    10._R_P/ 2520._R_P; c(2,8,7)=   -35._R_P/ 2520._R_P; c(2,8,8)=   280._R_P/ 2520._R_P  ! cell 8
        c(2,7,6)=  -125._R_P/ 2520._R_P; c(2,7,7)=   595._R_P/ 2520._R_P; c(2,7,8)=  4609._R_P/ 2520._R_P  ! cell 7
        c(2,6,6)=   955._R_P/ 2520._R_P; c(2,6,7)=  3349._R_P/ 2520._R_P; c(2,6,8)= -5471._R_P/ 2520._R_P  ! cell 6
        c(2,5,6)=  2509._R_P/ 2520._R_P; c(2,5,7)= -2531._R_P/ 2520._R_P; c(2,5,8)=  6289._R_P/ 2520._R_P  ! cell 5
        c(2,4,6)= -1271._R_P/ 2520._R_P; c(2,4,7)=  1879._R_P/ 2520._R_P; c(2,4,8)= -5471._R_P/ 2520._R_P  ! cell 4
        c(2,3,6)=   619._R_P/ 2520._R_P; c(2,3,7)= -1061._R_P/ 2520._R_P; c(2,3,8)=  3349._R_P/ 2520._R_P  ! cell 3
        c(2,2,6)=  -221._R_P/ 2520._R_P; c(2,2,7)=   409._R_P/ 2520._R_P; c(2,2,8)= -1355._R_P/ 2520._R_P  ! cell 2
        c(2,1,6)=    49._R_P/ 2520._R_P; c(2,1,7)=   -95._R_P/ 2520._R_P; c(2,1,8)=   325._R_P/ 2520._R_P  ! cell 1
        c(2,0,6)=    -5._R_P/ 2520._R_P; c(2,0,7)=    10._R_P/ 2520._R_P; c(2,0,8)=   -35._R_P/ 2520._R_P  ! cell 0
      endselect
  endassociate
  endsubroutine create

  pure subroutine compute_int(self, stencil, values)
  !< Compute interpolations (interpolate).
  class(interpolations_rec_js), intent(in)  :: self               !< Interpolations.
  real(R_P),                    intent(in)  :: stencil(1-self%S:) !< Stencil used for the interpolation, [1-S:-1+S].
  real(R_P),                    intent(out) :: values(0:)         !< Interpolations values.
  ! empty procedure
  endsubroutine compute_int

  pure subroutine compute_rec(self, stencil, values)
  !< Compute interpolations (reconstruct).
  class(interpolations_rec_js), intent(in)  :: self                  !< Interpolations.
  real(R_P),                    intent(in)  :: stencil(1:,1-self%S:) !< Stencil used for the interpolation, [1:2, 1-S:-1+S].
  real(R_P),                    intent(out) :: values(1:, 0:)        !< Interpolations values.
  integer(I_P)                              :: s1                    !< Counter.
  integer(I_P)                              :: s2                    !< Counter.
  integer(I_P)                              :: f                     !< Counter.

  values = 0._R_P
  do s1=0, self%S - 1 ! stencils loop
    do s2=0, self%S - 1 ! values loop
      do f=1, 2 ! 1 => left interface (i-1/2), 2 => right interface (i+1/2)
        values(f, s1) = values(f, s1) + self%coef(f, s2, s1) * stencil(f, -s2 + s1)
      enddo
    enddo
  enddo
  endsubroutine compute_rec

  pure function description(self, prefix) result(string)
  !< Return object string-descripition.
  class(interpolations_rec_js), intent(in)           :: self             !< Interpolations.
  character(len=*),             intent(in), optional :: prefix           !< Prefixing string.
  character(len=:), allocatable                      :: string           !< String-description.
  character(len=:), allocatable                      :: prefix_          !< Prefixing string, local variable.
  character(len=1), parameter                        :: NL=new_line('a') !< New line char.

  prefix_ = '' ; if (present(prefix)) prefix_ = prefix
  string = prefix_//'Jiang-Shu beta interpolations object for reconstruction:'//NL
  string = string//prefix_//'  - S   = '//trim(str(self%S))
  endfunction description

  elemental subroutine destroy(self)
  !< Destroy interpolations.
  class(interpolations_rec_js), intent(inout) :: self !< Interpolations.

  call self%destroy_
  if (allocated(self%coef)) deallocate(self%coef)
  endsubroutine destroy

  pure subroutine object_assign_object(lhs, rhs)
  !< `=` operator.
  class(interpolations_rec_js), intent(inout) :: lhs !< Left hand side.
  class(base_object),           intent(in)    :: rhs !< Right hand side.

  call lhs%assign_(rhs=rhs)
  select type(rhs)
  type is(interpolations_rec_js)
     if (allocated(rhs%coef)) then
        lhs%coef = rhs%coef
     else
        if (allocated(lhs%coef)) deallocate(lhs%coef)
     endif
  endselect
  endsubroutine object_assign_object
endmodule wenoof_interpolations_rec_js


!##############################################################################
! PROGRAM allinone
!
! ## The all-in-one solution to the cake eating problem
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program allinone

    use toolbox

    implicit none

    ! model parameters
    real*8, parameter :: gamma = 0.5d0
    real*8, parameter :: beta = 0.95d0
    real*8, parameter :: a0 = 100d0

    ! other variables
    integer, parameter :: TT = 200
    real*8 :: c_t(0:TT)
    integer :: it

    ! calculate the time path of consumption
    do it = 0, TT
        c_t(it) = beta**(dble(it)*gamma)*(1d0 - beta**gamma)*a0
    enddo

    call plot((/(dble(it),it=0,TT)/), c_t)
    call execplot(xlabel='Time t', ylabel='Consumption c_t')

end program