c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine x_solve

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c
c     Performs line solves in X direction by first factoring
c     the block-tridiagonal matrix into an upper triangular matrix,
c     and then performing back substitution to solve for the unknow
c     vectors of each line.
c
c     Make sure we treat elements zero to cell_size in the direction
c     of the sweep.
c
c---------------------------------------------------------------------

      include 'header.h'

      integer i,j,k,m,n,isize

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      if (timeron) call timer_start(t_xsolve)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     This function computes the left hand side in the xi-direction
c---------------------------------------------------------------------

      isize = grid_points(1)-1

c---------------------------------------------------------------------
c     determine a (labeled f) and n jacobians
c---------------------------------------------------------------------
!$omp parallel do default(shared) shared(isize)
!$omp& private(i,j,k,m,n)
      do k = 1, grid_points(3)-2
         do j = 1, grid_points(2)-2
            do i = 0, isize

               tmp1 = rho_i(i,j,k)
               tmp2 = tmp1 * tmp1
               tmp3 = tmp1 * tmp2
c---------------------------------------------------------------------
c
c---------------------------------------------------------------------
               fjac(1,1,i) = 0.0d+00
               fjac(1,2,i) = 1.0d+00
               fjac(1,3,i) = 0.0d+00
               fjac(1,4,i) = 0.0d+00
               fjac(1,5,i) = 0.0d+00

               fjac(2,1,i) = -(u(2,i,j,k) * tmp2 *
     >              u(2,i,j,k))
     >              + c2 * qs(i,j,k)
               fjac(2,2,i) = ( 2.0d+00 - c2 )
     >              * ( u(2,i,j,k) / u(1,i,j,k) )
               fjac(2,3,i) = - c2 * ( u(3,i,j,k) * tmp1 )
               fjac(2,4,i) = - c2 * ( u(4,i,j,k) * tmp1 )
               fjac(2,5,i) = c2

               fjac(3,1,i) = - ( u(2,i,j,k)*u(3,i,j,k) ) * tmp2
               fjac(3,2,i) = u(3,i,j,k) * tmp1
               fjac(3,3,i) = u(2,i,j,k) * tmp1
               fjac(3,4,i) = 0.0d+00
               fjac(3,5,i) = 0.0d+00

               fjac(4,1,i) = - ( u(2,i,j,k)*u(4,i,j,k) ) * tmp2
               fjac(4,2,i) = u(4,i,j,k) * tmp1
               fjac(4,3,i) = 0.0d+00
               fjac(4,4,i) = u(2,i,j,k) * tmp1
               fjac(4,5,i) = 0.0d+00

               fjac(5,1,i) = ( c2 * 2.0d0 * square(i,j,k)
     >              - c1 * u(5,i,j,k) )
     >              * ( u(2,i,j,k) * tmp2 )
               fjac(5,2,i) = c1 *  u(5,i,j,k) * tmp1
     >              - c2
     >              * ( u(2,i,j,k)*u(2,i,j,k) * tmp2
     >              + qs(i,j,k) )
               fjac(5,3,i) = - c2 * ( u(3,i,j,k)*u(2,i,j,k) )
     >              * tmp2
               fjac(5,4,i) = - c2 * ( u(4,i,j,k)*u(2,i,j,k) )
     >              * tmp2
               fjac(5,5,i) = c1 * ( u(2,i,j,k) * tmp1 )

               njac(1,1,i) = 0.0d+00
               njac(1,2,i) = 0.0d+00
               njac(1,3,i) = 0.0d+00
               njac(1,4,i) = 0.0d+00
               njac(1,5,i) = 0.0d+00

               njac(2,1,i) = - con43 * c3c4 * tmp2 * u(2,i,j,k)
               njac(2,2,i) =   con43 * c3c4 * tmp1
               njac(2,3,i) =   0.0d+00
               njac(2,4,i) =   0.0d+00
               njac(2,5,i) =   0.0d+00

               njac(3,1,i) = - c3c4 * tmp2 * u(3,i,j,k)
               njac(3,2,i) =   0.0d+00
               njac(3,3,i) =   c3c4 * tmp1
               njac(3,4,i) =   0.0d+00
               njac(3,5,i) =   0.0d+00

               njac(4,1,i) = - c3c4 * tmp2 * u(4,i,j,k)
               njac(4,2,i) =   0.0d+00
               njac(4,3,i) =   0.0d+00
               njac(4,4,i) =   c3c4 * tmp1
               njac(4,5,i) =   0.0d+00

               njac(5,1,i) = - ( con43 * c3c4
     >              - c1345 ) * tmp3 * (u(2,i,j,k)**2)
     >              - ( c3c4 - c1345 ) * tmp3 * (u(3,i,j,k)**2)
     >              - ( c3c4 - c1345 ) * tmp3 * (u(4,i,j,k)**2)
     >              - c1345 * tmp2 * u(5,i,j,k)

               njac(5,2,i) = ( con43 * c3c4
     >              - c1345 ) * tmp2 * u(2,i,j,k)
               njac(5,3,i) = ( c3c4 - c1345 ) * tmp2 * u(3,i,j,k)
               njac(5,4,i) = ( c3c4 - c1345 ) * tmp2 * u(4,i,j,k)
               njac(5,5,i) = ( c1345 ) * tmp1

            enddo
c---------------------------------------------------------------------
c     now jacobians set, so form left hand side in x direction
c---------------------------------------------------------------------
            call lhsinit(lhs, isize)
            do i = 1, isize-1

               tmp1 = dt * tx1
               tmp2 = dt * tx2

               lhs(1,1,aa,i) = - tmp2 * fjac(1,1,i-1)
     >              - tmp1 * njac(1,1,i-1)
     >              - tmp1 * dx1
               lhs(1,2,aa,i) = - tmp2 * fjac(1,2,i-1)
     >              - tmp1 * njac(1,2,i-1)
               lhs(1,3,aa,i) = - tmp2 * fjac(1,3,i-1)
     >              - tmp1 * njac(1,3,i-1)
               lhs(1,4,aa,i) = - tmp2 * fjac(1,4,i-1)
     >              - tmp1 * njac(1,4,i-1)
               lhs(1,5,aa,i) = - tmp2 * fjac(1,5,i-1)
     >              - tmp1 * njac(1,5,i-1)

               lhs(2,1,aa,i) = - tmp2 * fjac(2,1,i-1)
     >              - tmp1 * njac(2,1,i-1)
               lhs(2,2,aa,i) = - tmp2 * fjac(2,2,i-1)
     >              - tmp1 * njac(2,2,i-1)
     >              - tmp1 * dx2
               lhs(2,3,aa,i) = - tmp2 * fjac(2,3,i-1)
     >              - tmp1 * njac(2,3,i-1)
               lhs(2,4,aa,i) = - tmp2 * fjac(2,4,i-1)
     >              - tmp1 * njac(2,4,i-1)
               lhs(2,5,aa,i) = - tmp2 * fjac(2,5,i-1)
     >              - tmp1 * njac(2,5,i-1)

               lhs(3,1,aa,i) = - tmp2 * fjac(3,1,i-1)
     >              - tmp1 * njac(3,1,i-1)
               lhs(3,2,aa,i) = - tmp2 * fjac(3,2,i-1)
     >              - tmp1 * njac(3,2,i-1)
               lhs(3,3,aa,i) = - tmp2 * fjac(3,3,i-1)
     >              - tmp1 * njac(3,3,i-1)
     >              - tmp1 * dx3
               lhs(3,4,aa,i) = - tmp2 * fjac(3,4,i-1)
     >              - tmp1 * njac(3,4,i-1)
               lhs(3,5,aa,i) = - tmp2 * fjac(3,5,i-1)
     >              - tmp1 * njac(3,5,i-1)

               lhs(4,1,aa,i) = - tmp2 * fjac(4,1,i-1)
     >              - tmp1 * njac(4,1,i-1)
               lhs(4,2,aa,i) = - tmp2 * fjac(4,2,i-1)
     >              - tmp1 * njac(4,2,i-1)
               lhs(4,3,aa,i) = - tmp2 * fjac(4,3,i-1)
     >              - tmp1 * njac(4,3,i-1)
               lhs(4,4,aa,i) = - tmp2 * fjac(4,4,i-1)
     >              - tmp1 * njac(4,4,i-1)
     >              - tmp1 * dx4
               lhs(4,5,aa,i) = - tmp2 * fjac(4,5,i-1)
     >              - tmp1 * njac(4,5,i-1)

               lhs(5,1,aa,i) = - tmp2 * fjac(5,1,i-1)
     >              - tmp1 * njac(5,1,i-1)
               lhs(5,2,aa,i) = - tmp2 * fjac(5,2,i-1)
     >              - tmp1 * njac(5,2,i-1)
               lhs(5,3,aa,i) = - tmp2 * fjac(5,3,i-1)
     >              - tmp1 * njac(5,3,i-1)
               lhs(5,4,aa,i) = - tmp2 * fjac(5,4,i-1)
     >              - tmp1 * njac(5,4,i-1)
               lhs(5,5,aa,i) = - tmp2 * fjac(5,5,i-1)
     >              - tmp1 * njac(5,5,i-1)
     >              - tmp1 * dx5

               lhs(1,1,bb,i) = 1.0d+00
     >              + tmp1 * 2.0d+00 * njac(1,1,i)
     >              + tmp1 * 2.0d+00 * dx1
               lhs(1,2,bb,i) = tmp1 * 2.0d+00 * njac(1,2,i)
               lhs(1,3,bb,i) = tmp1 * 2.0d+00 * njac(1,3,i)
               lhs(1,4,bb,i) = tmp1 * 2.0d+00 * njac(1,4,i)
               lhs(1,5,bb,i) = tmp1 * 2.0d+00 * njac(1,5,i)

               lhs(2,1,bb,i) = tmp1 * 2.0d+00 * njac(2,1,i)
               lhs(2,2,bb,i) = 1.0d+00
     >              + tmp1 * 2.0d+00 * njac(2,2,i)
     >              + tmp1 * 2.0d+00 * dx2
               lhs(2,3,bb,i) = tmp1 * 2.0d+00 * njac(2,3,i)
               lhs(2,4,bb,i) = tmp1 * 2.0d+00 * njac(2,4,i)
               lhs(2,5,bb,i) = tmp1 * 2.0d+00 * njac(2,5,i)

               lhs(3,1,bb,i) = tmp1 * 2.0d+00 * njac(3,1,i)
               lhs(3,2,bb,i) = tmp1 * 2.0d+00 * njac(3,2,i)
               lhs(3,3,bb,i) = 1.0d+00
     >              + tmp1 * 2.0d+00 * njac(3,3,i)
     >              + tmp1 * 2.0d+00 * dx3
               lhs(3,4,bb,i) = tmp1 * 2.0d+00 * njac(3,4,i)
               lhs(3,5,bb,i) = tmp1 * 2.0d+00 * njac(3,5,i)

               lhs(4,1,bb,i) = tmp1 * 2.0d+00 * njac(4,1,i)
               lhs(4,2,bb,i) = tmp1 * 2.0d+00 * njac(4,2,i)
               lhs(4,3,bb,i) = tmp1 * 2.0d+00 * njac(4,3,i)
               lhs(4,4,bb,i) = 1.0d+00
     >              + tmp1 * 2.0d+00 * njac(4,4,i)
     >              + tmp1 * 2.0d+00 * dx4
               lhs(4,5,bb,i) = tmp1 * 2.0d+00 * njac(4,5,i)

               lhs(5,1,bb,i) = tmp1 * 2.0d+00 * njac(5,1,i)
               lhs(5,2,bb,i) = tmp1 * 2.0d+00 * njac(5,2,i)
               lhs(5,3,bb,i) = tmp1 * 2.0d+00 * njac(5,3,i)
               lhs(5,4,bb,i) = tmp1 * 2.0d+00 * njac(5,4,i)
               lhs(5,5,bb,i) = 1.0d+00
     >              + tmp1 * 2.0d+00 * njac(5,5,i)
     >              + tmp1 * 2.0d+00 * dx5

               lhs(1,1,cc,i) =  tmp2 * fjac(1,1,i+1)
     >              - tmp1 * njac(1,1,i+1)
     >              - tmp1 * dx1
               lhs(1,2,cc,i) =  tmp2 * fjac(1,2,i+1)
     >              - tmp1 * njac(1,2,i+1)
               lhs(1,3,cc,i) =  tmp2 * fjac(1,3,i+1)
     >              - tmp1 * njac(1,3,i+1)
               lhs(1,4,cc,i) =  tmp2 * fjac(1,4,i+1)
     >              - tmp1 * njac(1,4,i+1)
               lhs(1,5,cc,i) =  tmp2 * fjac(1,5,i+1)
     >              - tmp1 * njac(1,5,i+1)

               lhs(2,1,cc,i) =  tmp2 * fjac(2,1,i+1)
     >              - tmp1 * njac(2,1,i+1)
               lhs(2,2,cc,i) =  tmp2 * fjac(2,2,i+1)
     >              - tmp1 * njac(2,2,i+1)
     >              - tmp1 * dx2
               lhs(2,3,cc,i) =  tmp2 * fjac(2,3,i+1)
     >              - tmp1 * njac(2,3,i+1)
               lhs(2,4,cc,i) =  tmp2 * fjac(2,4,i+1)
     >              - tmp1 * njac(2,4,i+1)
               lhs(2,5,cc,i) =  tmp2 * fjac(2,5,i+1)
     >              - tmp1 * njac(2,5,i+1)

               lhs(3,1,cc,i) =  tmp2 * fjac(3,1,i+1)
     >              - tmp1 * njac(3,1,i+1)
               lhs(3,2,cc,i) =  tmp2 * fjac(3,2,i+1)
     >              - tmp1 * njac(3,2,i+1)
               lhs(3,3,cc,i) =  tmp2 * fjac(3,3,i+1)
     >              - tmp1 * njac(3,3,i+1)
     >              - tmp1 * dx3
               lhs(3,4,cc,i) =  tmp2 * fjac(3,4,i+1)
     >              - tmp1 * njac(3,4,i+1)
               lhs(3,5,cc,i) =  tmp2 * fjac(3,5,i+1)
     >              - tmp1 * njac(3,5,i+1)

               lhs(4,1,cc,i) =  tmp2 * fjac(4,1,i+1)
     >              - tmp1 * njac(4,1,i+1)
               lhs(4,2,cc,i) =  tmp2 * fjac(4,2,i+1)
     >              - tmp1 * njac(4,2,i+1)
               lhs(4,3,cc,i) =  tmp2 * fjac(4,3,i+1)
     >              - tmp1 * njac(4,3,i+1)
               lhs(4,4,cc,i) =  tmp2 * fjac(4,4,i+1)
     >              - tmp1 * njac(4,4,i+1)
     >              - tmp1 * dx4
               lhs(4,5,cc,i) =  tmp2 * fjac(4,5,i+1)
     >              - tmp1 * njac(4,5,i+1)

               lhs(5,1,cc,i) =  tmp2 * fjac(5,1,i+1)
     >              - tmp1 * njac(5,1,i+1)
               lhs(5,2,cc,i) =  tmp2 * fjac(5,2,i+1)
     >              - tmp1 * njac(5,2,i+1)
               lhs(5,3,cc,i) =  tmp2 * fjac(5,3,i+1)
     >              - tmp1 * njac(5,3,i+1)
               lhs(5,4,cc,i) =  tmp2 * fjac(5,4,i+1)
     >              - tmp1 * njac(5,4,i+1)
               lhs(5,5,cc,i) =  tmp2 * fjac(5,5,i+1)
     >              - tmp1 * njac(5,5,i+1)
     >              - tmp1 * dx5

            enddo

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     performs guaussian elimination on this cell.
c
c     assumes that unpacking routines for non-first cells
c     preload C' and rhs' from previous cell.
c
c     assumed send happens outside this routine, but that
c     c'(IMAX) and rhs'(IMAX) will be sent to next cell
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     outer most do loops - sweeping in i direction
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     multiply c(0,j,k) by b_inverse and copy back to c
c     multiply rhs(0) by b_inverse(0) and copy to rhs
c---------------------------------------------------------------------
            call binvcrhs( lhs(1,1,bb,0),
     >                        lhs(1,1,cc,0),
     >                        rhs(1,0,j,k) )

c---------------------------------------------------------------------
c     begin inner most do loop
c     do all the elements of the cell unless last
c---------------------------------------------------------------------
            do i=1,isize-1

c---------------------------------------------------------------------
c     rhs(i) = rhs(i) - A*rhs(i-1)
c---------------------------------------------------------------------
               call matvec_sub(lhs(1,1,aa,i),
     >                         rhs(1,i-1,j,k),rhs(1,i,j,k))

c---------------------------------------------------------------------
c     B(i) = B(i) - C(i-1)*A(i)
c---------------------------------------------------------------------
               call matmul_sub(lhs(1,1,aa,i),
     >                         lhs(1,1,cc,i-1),
     >                         lhs(1,1,bb,i))

c---------------------------------------------------------------------
c     multiply c(i,j,k) by b_inverse and copy back to c
c     multiply rhs(1,j,k) by b_inverse(1,j,k) and copy to rhs
c---------------------------------------------------------------------
               call binvcrhs( lhs(1,1,bb,i),
     >                        lhs(1,1,cc,i),
     >                        rhs(1,i,j,k) )

            enddo

c---------------------------------------------------------------------
c     rhs(isize) = rhs(isize) - A*rhs(isize-1)
c---------------------------------------------------------------------
            call matvec_sub(lhs(1,1,aa,isize),
     >                         rhs(1,isize-1,j,k),rhs(1,isize,j,k))

c---------------------------------------------------------------------
c     B(isize) = B(isize) - C(isize-1)*A(isize)
c---------------------------------------------------------------------
            call matmul_sub(lhs(1,1,aa,isize),
     >                         lhs(1,1,cc,isize-1),
     >                         lhs(1,1,bb,isize))

c---------------------------------------------------------------------
c     multiply rhs() by b_inverse() and copy to rhs
c---------------------------------------------------------------------
            call binvrhs( lhs(1,1,bb,isize),
     >                       rhs(1,isize,j,k) )

c---------------------------------------------------------------------
c     back solve: if last cell, then generate U(isize)=rhs(isize)
c     else assume U(isize) is loaded in un pack backsub_info
c     so just use it
c     after call u(istart) will be sent to next cell
c---------------------------------------------------------------------

            do i=isize-1,0,-1
               do m=1,BLOCK_SIZE
                  do n=1,BLOCK_SIZE
                     rhs(m,i,j,k) = rhs(m,i,j,k)
     >                    - lhs(m,n,cc,i)*rhs(n,i+1,j,k)
                  enddo
               enddo
            enddo

         enddo
      enddo
      if (timeron) call timer_stop(t_xsolve)

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine matvec_sub(ablock,avec,bvec)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     subtracts bvec=bvec - ablock*avec
c---------------------------------------------------------------------

      implicit none

      double precision ablock,avec,bvec
      dimension ablock(5,5),avec(5),bvec(5)
      integer i

      do i=1,5
c---------------------------------------------------------------------
c            rhs(i,ic,jc,kc) = rhs(i,ic,jc,kc)
c     $           - lhs(i,1,ablock,ia)*
c---------------------------------------------------------------------
         bvec(i) = bvec(i) - ablock(i,1)*avec(1)
     >                     - ablock(i,2)*avec(2)
     >                     - ablock(i,3)*avec(3)
     >                     - ablock(i,4)*avec(4)
     >                     - ablock(i,5)*avec(5)
      enddo

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine matmul_sub(ablock, bblock, cblock)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     subtracts a(i,j,k) X b(i,j,k) from c(i,j,k)
c---------------------------------------------------------------------

      implicit none

      double precision ablock, bblock, cblock
      dimension ablock(5,5), bblock(5,5), cblock(5,5)
      integer j

      do j=1,5
         cblock(1,j) = cblock(1,j) - ablock(1,1)*bblock(1,j)
     >                             - ablock(1,2)*bblock(2,j)
     >                             - ablock(1,3)*bblock(3,j)
     >                             - ablock(1,4)*bblock(4,j)
     >                             - ablock(1,5)*bblock(5,j)
         cblock(2,j) = cblock(2,j) - ablock(2,1)*bblock(1,j)
     >                             - ablock(2,2)*bblock(2,j)
     >                             - ablock(2,3)*bblock(3,j)
     >                             - ablock(2,4)*bblock(4,j)
     >                             - ablock(2,5)*bblock(5,j)
         cblock(3,j) = cblock(3,j) - ablock(3,1)*bblock(1,j)
     >                             - ablock(3,2)*bblock(2,j)
     >                             - ablock(3,3)*bblock(3,j)
     >                             - ablock(3,4)*bblock(4,j)
     >                             - ablock(3,5)*bblock(5,j)
         cblock(4,j) = cblock(4,j) - ablock(4,1)*bblock(1,j)
     >                             - ablock(4,2)*bblock(2,j)
     >                             - ablock(4,3)*bblock(3,j)
     >                             - ablock(4,4)*bblock(4,j)
     >                             - ablock(4,5)*bblock(5,j)
         cblock(5,j) = cblock(5,j) - ablock(5,1)*bblock(1,j)
     >                             - ablock(5,2)*bblock(2,j)
     >                             - ablock(5,3)*bblock(3,j)
     >                             - ablock(5,4)*bblock(4,j)
     >                             - ablock(5,5)*bblock(5,j)
      enddo

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine binvcrhs( lhs,c,r )

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c
c---------------------------------------------------------------------

      implicit none

      double precision pivot, coeff, lhs
      dimension lhs(5,5)
      double precision c(5,5), r(5)

c---------------------------------------------------------------------
c
c---------------------------------------------------------------------

      pivot = 1.00d0/lhs(1,1)
      lhs(1,2) = lhs(1,2)*pivot
      lhs(1,3) = lhs(1,3)*pivot
      lhs(1,4) = lhs(1,4)*pivot
      lhs(1,5) = lhs(1,5)*pivot
      c(1,1) = c(1,1)*pivot
      c(1,2) = c(1,2)*pivot
      c(1,3) = c(1,3)*pivot
      c(1,4) = c(1,4)*pivot
      c(1,5) = c(1,5)*pivot
      r(1)   = r(1)  *pivot

      coeff = lhs(2,1)
      lhs(2,2)= lhs(2,2) - coeff*lhs(1,2)
      lhs(2,3)= lhs(2,3) - coeff*lhs(1,3)
      lhs(2,4)= lhs(2,4) - coeff*lhs(1,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(1,5)
      c(2,1) = c(2,1) - coeff*c(1,1)
      c(2,2) = c(2,2) - coeff*c(1,2)
      c(2,3) = c(2,3) - coeff*c(1,3)
      c(2,4) = c(2,4) - coeff*c(1,4)
      c(2,5) = c(2,5) - coeff*c(1,5)
      r(2)   = r(2)   - coeff*r(1)

      coeff = lhs(3,1)
      lhs(3,2)= lhs(3,2) - coeff*lhs(1,2)
      lhs(3,3)= lhs(3,3) - coeff*lhs(1,3)
      lhs(3,4)= lhs(3,4) - coeff*lhs(1,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(1,5)
      c(3,1) = c(3,1) - coeff*c(1,1)
      c(3,2) = c(3,2) - coeff*c(1,2)
      c(3,3) = c(3,3) - coeff*c(1,3)
      c(3,4) = c(3,4) - coeff*c(1,4)
      c(3,5) = c(3,5) - coeff*c(1,5)
      r(3)   = r(3)   - coeff*r(1)

      coeff = lhs(4,1)
      lhs(4,2)= lhs(4,2) - coeff*lhs(1,2)
      lhs(4,3)= lhs(4,3) - coeff*lhs(1,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(1,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(1,5)
      c(4,1) = c(4,1) - coeff*c(1,1)
      c(4,2) = c(4,2) - coeff*c(1,2)
      c(4,3) = c(4,3) - coeff*c(1,3)
      c(4,4) = c(4,4) - coeff*c(1,4)
      c(4,5) = c(4,5) - coeff*c(1,5)
      r(4)   = r(4)   - coeff*r(1)

      coeff = lhs(5,1)
      lhs(5,2)= lhs(5,2) - coeff*lhs(1,2)
      lhs(5,3)= lhs(5,3) - coeff*lhs(1,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(1,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(1,5)
      c(5,1) = c(5,1) - coeff*c(1,1)
      c(5,2) = c(5,2) - coeff*c(1,2)
      c(5,3) = c(5,3) - coeff*c(1,3)
      c(5,4) = c(5,4) - coeff*c(1,4)
      c(5,5) = c(5,5) - coeff*c(1,5)
      r(5)   = r(5)   - coeff*r(1)

      pivot = 1.00d0/lhs(2,2)
      lhs(2,3) = lhs(2,3)*pivot
      lhs(2,4) = lhs(2,4)*pivot
      lhs(2,5) = lhs(2,5)*pivot
      c(2,1) = c(2,1)*pivot
      c(2,2) = c(2,2)*pivot
      c(2,3) = c(2,3)*pivot
      c(2,4) = c(2,4)*pivot
      c(2,5) = c(2,5)*pivot
      r(2)   = r(2)  *pivot

      coeff = lhs(1,2)
      lhs(1,3)= lhs(1,3) - coeff*lhs(2,3)
      lhs(1,4)= lhs(1,4) - coeff*lhs(2,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(2,5)
      c(1,1) = c(1,1) - coeff*c(2,1)
      c(1,2) = c(1,2) - coeff*c(2,2)
      c(1,3) = c(1,3) - coeff*c(2,3)
      c(1,4) = c(1,4) - coeff*c(2,4)
      c(1,5) = c(1,5) - coeff*c(2,5)
      r(1)   = r(1)   - coeff*r(2)

      coeff = lhs(3,2)
      lhs(3,3)= lhs(3,3) - coeff*lhs(2,3)
      lhs(3,4)= lhs(3,4) - coeff*lhs(2,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(2,5)
      c(3,1) = c(3,1) - coeff*c(2,1)
      c(3,2) = c(3,2) - coeff*c(2,2)
      c(3,3) = c(3,3) - coeff*c(2,3)
      c(3,4) = c(3,4) - coeff*c(2,4)
      c(3,5) = c(3,5) - coeff*c(2,5)
      r(3)   = r(3)   - coeff*r(2)

      coeff = lhs(4,2)
      lhs(4,3)= lhs(4,3) - coeff*lhs(2,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(2,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(2,5)
      c(4,1) = c(4,1) - coeff*c(2,1)
      c(4,2) = c(4,2) - coeff*c(2,2)
      c(4,3) = c(4,3) - coeff*c(2,3)
      c(4,4) = c(4,4) - coeff*c(2,4)
      c(4,5) = c(4,5) - coeff*c(2,5)
      r(4)   = r(4)   - coeff*r(2)

      coeff = lhs(5,2)
      lhs(5,3)= lhs(5,3) - coeff*lhs(2,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(2,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(2,5)
      c(5,1) = c(5,1) - coeff*c(2,1)
      c(5,2) = c(5,2) - coeff*c(2,2)
      c(5,3) = c(5,3) - coeff*c(2,3)
      c(5,4) = c(5,4) - coeff*c(2,4)
      c(5,5) = c(5,5) - coeff*c(2,5)
      r(5)   = r(5)   - coeff*r(2)

      pivot = 1.00d0/lhs(3,3)
      lhs(3,4) = lhs(3,4)*pivot
      lhs(3,5) = lhs(3,5)*pivot
      c(3,1) = c(3,1)*pivot
      c(3,2) = c(3,2)*pivot
      c(3,3) = c(3,3)*pivot
      c(3,4) = c(3,4)*pivot
      c(3,5) = c(3,5)*pivot
      r(3)   = r(3)  *pivot

      coeff = lhs(1,3)
      lhs(1,4)= lhs(1,4) - coeff*lhs(3,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(3,5)
      c(1,1) = c(1,1) - coeff*c(3,1)
      c(1,2) = c(1,2) - coeff*c(3,2)
      c(1,3) = c(1,3) - coeff*c(3,3)
      c(1,4) = c(1,4) - coeff*c(3,4)
      c(1,5) = c(1,5) - coeff*c(3,5)
      r(1)   = r(1)   - coeff*r(3)

      coeff = lhs(2,3)
      lhs(2,4)= lhs(2,4) - coeff*lhs(3,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(3,5)
      c(2,1) = c(2,1) - coeff*c(3,1)
      c(2,2) = c(2,2) - coeff*c(3,2)
      c(2,3) = c(2,3) - coeff*c(3,3)
      c(2,4) = c(2,4) - coeff*c(3,4)
      c(2,5) = c(2,5) - coeff*c(3,5)
      r(2)   = r(2)   - coeff*r(3)

      coeff = lhs(4,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(3,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(3,5)
      c(4,1) = c(4,1) - coeff*c(3,1)
      c(4,2) = c(4,2) - coeff*c(3,2)
      c(4,3) = c(4,3) - coeff*c(3,3)
      c(4,4) = c(4,4) - coeff*c(3,4)
      c(4,5) = c(4,5) - coeff*c(3,5)
      r(4)   = r(4)   - coeff*r(3)

      coeff = lhs(5,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(3,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(3,5)
      c(5,1) = c(5,1) - coeff*c(3,1)
      c(5,2) = c(5,2) - coeff*c(3,2)
      c(5,3) = c(5,3) - coeff*c(3,3)
      c(5,4) = c(5,4) - coeff*c(3,4)
      c(5,5) = c(5,5) - coeff*c(3,5)
      r(5)   = r(5)   - coeff*r(3)

      pivot = 1.00d0/lhs(4,4)
      lhs(4,5) = lhs(4,5)*pivot
      c(4,1) = c(4,1)*pivot
      c(4,2) = c(4,2)*pivot
      c(4,3) = c(4,3)*pivot
      c(4,4) = c(4,4)*pivot
      c(4,5) = c(4,5)*pivot
      r(4)   = r(4)  *pivot

      coeff = lhs(1,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(4,5)
      c(1,1) = c(1,1) - coeff*c(4,1)
      c(1,2) = c(1,2) - coeff*c(4,2)
      c(1,3) = c(1,3) - coeff*c(4,3)
      c(1,4) = c(1,4) - coeff*c(4,4)
      c(1,5) = c(1,5) - coeff*c(4,5)
      r(1)   = r(1)   - coeff*r(4)

      coeff = lhs(2,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(4,5)
      c(2,1) = c(2,1) - coeff*c(4,1)
      c(2,2) = c(2,2) - coeff*c(4,2)
      c(2,3) = c(2,3) - coeff*c(4,3)
      c(2,4) = c(2,4) - coeff*c(4,4)
      c(2,5) = c(2,5) - coeff*c(4,5)
      r(2)   = r(2)   - coeff*r(4)

      coeff = lhs(3,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(4,5)
      c(3,1) = c(3,1) - coeff*c(4,1)
      c(3,2) = c(3,2) - coeff*c(4,2)
      c(3,3) = c(3,3) - coeff*c(4,3)
      c(3,4) = c(3,4) - coeff*c(4,4)
      c(3,5) = c(3,5) - coeff*c(4,5)
      r(3)   = r(3)   - coeff*r(4)

      coeff = lhs(5,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(4,5)
      c(5,1) = c(5,1) - coeff*c(4,1)
      c(5,2) = c(5,2) - coeff*c(4,2)
      c(5,3) = c(5,3) - coeff*c(4,3)
      c(5,4) = c(5,4) - coeff*c(4,4)
      c(5,5) = c(5,5) - coeff*c(4,5)
      r(5)   = r(5)   - coeff*r(4)

      pivot = 1.00d0/lhs(5,5)
      c(5,1) = c(5,1)*pivot
      c(5,2) = c(5,2)*pivot
      c(5,3) = c(5,3)*pivot
      c(5,4) = c(5,4)*pivot
      c(5,5) = c(5,5)*pivot
      r(5)   = r(5)  *pivot

      coeff = lhs(1,5)
      c(1,1) = c(1,1) - coeff*c(5,1)
      c(1,2) = c(1,2) - coeff*c(5,2)
      c(1,3) = c(1,3) - coeff*c(5,3)
      c(1,4) = c(1,4) - coeff*c(5,4)
      c(1,5) = c(1,5) - coeff*c(5,5)
      r(1)   = r(1)   - coeff*r(5)

      coeff = lhs(2,5)
      c(2,1) = c(2,1) - coeff*c(5,1)
      c(2,2) = c(2,2) - coeff*c(5,2)
      c(2,3) = c(2,3) - coeff*c(5,3)
      c(2,4) = c(2,4) - coeff*c(5,4)
      c(2,5) = c(2,5) - coeff*c(5,5)
      r(2)   = r(2)   - coeff*r(5)

      coeff = lhs(3,5)
      c(3,1) = c(3,1) - coeff*c(5,1)
      c(3,2) = c(3,2) - coeff*c(5,2)
      c(3,3) = c(3,3) - coeff*c(5,3)
      c(3,4) = c(3,4) - coeff*c(5,4)
      c(3,5) = c(3,5) - coeff*c(5,5)
      r(3)   = r(3)   - coeff*r(5)

      coeff = lhs(4,5)
      c(4,1) = c(4,1) - coeff*c(5,1)
      c(4,2) = c(4,2) - coeff*c(5,2)
      c(4,3) = c(4,3) - coeff*c(5,3)
      c(4,4) = c(4,4) - coeff*c(5,4)
      c(4,5) = c(4,5) - coeff*c(5,5)
      r(4)   = r(4)   - coeff*r(5)

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine binvrhs( lhs,r )

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c
c---------------------------------------------------------------------

      implicit none

      double precision pivot, coeff, lhs
      dimension lhs(5,5)
      double precision r(5)

c---------------------------------------------------------------------
c
c---------------------------------------------------------------------

      pivot = 1.00d0/lhs(1,1)
      lhs(1,2) = lhs(1,2)*pivot
      lhs(1,3) = lhs(1,3)*pivot
      lhs(1,4) = lhs(1,4)*pivot
      lhs(1,5) = lhs(1,5)*pivot
      r(1)   = r(1)  *pivot

      coeff = lhs(2,1)
      lhs(2,2)= lhs(2,2) - coeff*lhs(1,2)
      lhs(2,3)= lhs(2,3) - coeff*lhs(1,3)
      lhs(2,4)= lhs(2,4) - coeff*lhs(1,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(1,5)
      r(2)   = r(2)   - coeff*r(1)

      coeff = lhs(3,1)
      lhs(3,2)= lhs(3,2) - coeff*lhs(1,2)
      lhs(3,3)= lhs(3,3) - coeff*lhs(1,3)
      lhs(3,4)= lhs(3,4) - coeff*lhs(1,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(1,5)
      r(3)   = r(3)   - coeff*r(1)

      coeff = lhs(4,1)
      lhs(4,2)= lhs(4,2) - coeff*lhs(1,2)
      lhs(4,3)= lhs(4,3) - coeff*lhs(1,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(1,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(1,5)
      r(4)   = r(4)   - coeff*r(1)

      coeff = lhs(5,1)
      lhs(5,2)= lhs(5,2) - coeff*lhs(1,2)
      lhs(5,3)= lhs(5,3) - coeff*lhs(1,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(1,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(1,5)
      r(5)   = r(5)   - coeff*r(1)

      pivot = 1.00d0/lhs(2,2)
      lhs(2,3) = lhs(2,3)*pivot
      lhs(2,4) = lhs(2,4)*pivot
      lhs(2,5) = lhs(2,5)*pivot
      r(2)   = r(2)  *pivot

      coeff = lhs(1,2)
      lhs(1,3)= lhs(1,3) - coeff*lhs(2,3)
      lhs(1,4)= lhs(1,4) - coeff*lhs(2,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(2,5)
      r(1)   = r(1)   - coeff*r(2)

      coeff = lhs(3,2)
      lhs(3,3)= lhs(3,3) - coeff*lhs(2,3)
      lhs(3,4)= lhs(3,4) - coeff*lhs(2,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(2,5)
      r(3)   = r(3)   - coeff*r(2)

      coeff = lhs(4,2)
      lhs(4,3)= lhs(4,3) - coeff*lhs(2,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(2,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(2,5)
      r(4)   = r(4)   - coeff*r(2)

      coeff = lhs(5,2)
      lhs(5,3)= lhs(5,3) - coeff*lhs(2,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(2,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(2,5)
      r(5)   = r(5)   - coeff*r(2)

      pivot = 1.00d0/lhs(3,3)
      lhs(3,4) = lhs(3,4)*pivot
      lhs(3,5) = lhs(3,5)*pivot
      r(3)   = r(3)  *pivot

      coeff = lhs(1,3)
      lhs(1,4)= lhs(1,4) - coeff*lhs(3,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(3,5)
      r(1)   = r(1)   - coeff*r(3)

      coeff = lhs(2,3)
      lhs(2,4)= lhs(2,4) - coeff*lhs(3,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(3,5)
      r(2)   = r(2)   - coeff*r(3)

      coeff = lhs(4,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(3,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(3,5)
      r(4)   = r(4)   - coeff*r(3)

      coeff = lhs(5,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(3,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(3,5)
      r(5)   = r(5)   - coeff*r(3)

      pivot = 1.00d0/lhs(4,4)
      lhs(4,5) = lhs(4,5)*pivot
      r(4)   = r(4)  *pivot

      coeff = lhs(1,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(4,5)
      r(1)   = r(1)   - coeff*r(4)

      coeff = lhs(2,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(4,5)
      r(2)   = r(2)   - coeff*r(4)

      coeff = lhs(3,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(4,5)
      r(3)   = r(3)   - coeff*r(4)

      coeff = lhs(5,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(4,5)
      r(5)   = r(5)   - coeff*r(4)

      pivot = 1.00d0/lhs(5,5)
      r(5)   = r(5)  *pivot

      coeff = lhs(1,5)
      r(1)   = r(1)   - coeff*r(5)

      coeff = lhs(2,5)
      r(2)   = r(2)   - coeff*r(5)

      coeff = lhs(3,5)
      r(3)   = r(3)   - coeff*r(5)

      coeff = lhs(4,5)
      r(4)   = r(4)   - coeff*r(5)

      return
      end


subroutine topol(s, q)

  implicit none

  real(8), parameter   :: pi2 = 2.0 * 3.141592653589793

  integer, parameter   :: np = 400
  integer, parameter   :: nnmax = 7
  integer, parameter   :: ndr = 2 * np

  real(8), intent(in)  :: s(-nnmax+1:np,3)
  real(8), intent(out) :: q
  real(8)              :: s1(np,3), s2(np,3), s3(np,3)
  integer              :: ldr(ndr,3)

  real(8)              :: siga
  real(8)              :: cc, cc1, cc2, cc3
  real(8)              :: ss, ss1, ss2, ss3
  integer              :: idr, n, is

  common /lattice/ ldr
  common /skratch/ s1,s2,s3

  siga = 0.0
  do idr = 0, ndr/2, ndr/2

     do n = 1,ndr/2
        s1(n,1) = s(ldr(idr+n,1),1)
        s1(n,2) = s(ldr(idr+n,1),2)
        s1(n,3) = s(ldr(idr+n,1),3)
     enddo

     do n = 1,ndr/2
        s2(n,1) = s(ldr(idr+n,2),1)
        s2(n,2) = s(ldr(idr+n,2),2)
        s2(n,3) = s(ldr(idr+n,2),3)
     enddo

     do n = 1,ndr/2
        s3(n,1) = s(ldr(idr+n,3),1)
        s3(n,2) = s(ldr(idr+n,3),2)
        s3(n,3) = s(ldr(idr+n,3),3)
     enddo

!     *****   cc = 1 + s1*s2 + s2*s3 + s3*s1   *****
!     *****   ss = s1 * ( s2 x s3 )            *****

     do is = 1, ndr/2
        cc1 = s1(is,1) * s2(is,1) + s1(is,2) * s2(is,2) + s1(is,3) * s2(is,3)
        cc2 = s2(is,1) * s3(is,1) + s2(is,2) * s3(is,2) + s2(is,3) * s3(is,3)
        cc3 = s3(is,1) * s1(is,1) + s3(is,2) * s1(is,2) + s3(is,3) * s1(is,3)
        cc  = 1.0 + cc1 + cc2 + cc3
        ss1 = s2(is,2) * s3(is,3) - s2(is,3) * s3(is,2)
        ss2 = s2(is,3) * s3(is,1) - s2(is,1) * s3(is,3)
        ss3 = s2(is,1) * s3(is,2) - s2(is,2) * s3(is,1)
        ss  = s1(is,1) * ss1 + s1(is,2) * ss2 + s1(is,3) * ss3
        siga = siga + atan2(ss,cc)
     enddo

  enddo

  q = siga / pi2

end


Real Function xnp(srt)
  Real xarray(11), earray(11)
  Save
  Data earray/20., 30., 40., 60., 90., 135.0, 200., 300., 400., 600., 800./
  Data xarray/410., 270., 214.5, 130., 78., 53.5, 41.6, 35.9, 34.2, 34.3, 34.9/
  pmass = 0.9383
  ekin = 2000.*pmass*((srt/(2.*pmass))**2-1.)
  If (ekin<earray(1)) Then
    xnp = xarray(1)
    If (xnp>55) xnp = 55
    Return
  End If
  If (ekin>earray(11)) Then
    xnp = xarray(11)
    Return
  End If
  Do ie = 1, 11
    If (earray(ie)==ekin) Then
      xnp = xarray(ie)
      If (xnp>55) xnp = 55.
      Return
    End If
    If (earray(ie)>ekin) Then
      ymin = alog(xarray(ie-1))
      ymax = alog(xarray(ie))
      xmin = alog(earray(ie-1))
      xmax = alog(earray(ie))
      xnp = exp(ymin+(alog(ekin)-xmin)*(ymax-ymin)/(xmax-xmin))
      If (xnp>55) xnp = 55
      Goto 50
    End If
  End Do
  50 Continue
  Return
End Function xnp


C 8 MAY 1995 ...CRI... MSTP S/W CONVERSION (VICAR PORTING)
      INCLUDE 'VICMAIN_FOR'
       SUBROUTINE MAIN44
       IMPLICIT INTEGER(A-Z)
      COMMON/C1/ IN,OUT,FPAR
      REAL*4 R(2,2),O(2),IN(2,1500),OUT(2,1500),FPAR(50)
C********************
C     PARAMETER PROCESSOR HERE
C********************
      CALL IFMESSAGE('XLOCUS VERSION 8-MAY-95')
      CALL XVP('T',FPAR,CNT)
      I = 1
      R(1,1)=FPAR(I)
      R(2,1)=FPAR(I+1)
      R(1,2)=FPAR(I+2)
      R(2,2)=FPAR(I+3)
      O(1)=FPAR(I+4)
      O(2)=FPAR(I+5)
      CALL PRNT(7,1,R(1,1),'0 R(1,1)= .')
      CALL PRNT(7,1,R(2,1),'0 R(2,1)= .')
      CALL PRNT(7,1,R(1,2),'0 R(1,2)= .')
      CALL PRNT(7,1,R(2,2),'0 R(2,2)= .')
      CALL PRNT(7,1,O(1),'0 O(1)= .')
      CALL PRNT(7,1,O(2),'0 O(2)= .')
      CALL XVUNIT(IUNI,'INP',1,STAT,' ')
      CALL XVOPEN(IUNI,STAT,'OPEN_ACT','SA','IO_ACT','SA',' ')
      CALL XVSIZE(SL,SS,NL,NS,NLI,NSI)
      NP=NS/2
      CALL XVREAD(IUNI,IN,STAT,'NSAMPS',NS,' ')
      CALL PRNT(7,NP,IN,' DUMP IN.')
C********************
C     NOW APPLY MATRIX TRANSFORMATION TO IN
C********************
      NPTS=NS/2
      DO 11 I=1,NPTS
      OUT(1,I)=R(1,1)*IN(1,I)+R(1,2)*IN(2,I)+O(1)
      OUT(2,I)=R(2,1)*IN(1,I)+R(2,2)*IN(2,I)+O(2)
11    CONTINUE
      CALL PRNT(7,NP,OUT,' DUMP OUT.')
C*********************
C     OK WRITE IT OUT
C*********************
      CALL XVUNIT(OUNI,'OUT',1,STAT,' ')
      IF(STAT.NE.1)GO TO 12
      NLO=1
      NSO=NS
      CALL XVOPEN(OUNI,STAT,'U_NL',NLO,'U_NS',NSO,
     *'OPEN_ACT','SA','IO_ACT','SA','OP','WRITE',' ')
      CALL XVWRIT(OUNI,OUT,STAT,' ')
      CALL XVCLOSE(OUNI,STAT,' ')
12    CONTINUE
      CALL XVCLOSE(IUNI,STAT,' ')
      RETURN
      END


program no_benefits
  use iso_fortran_env, only : real64
  implicit none

  integer, parameter :: n = 1048576, m=65536
  integer :: i,j
  real(real64),allocatable:: a(:), b(:), c(:)
  real(real64) :: rec

  allocate(a(n),b(m),c(n))

  rec = 1.0/n

  do i = 1, n
     a(i) = rec
     c(i) = i
  end do

  do i =1,m
     b(i) = i*2.0
  end do

  do i = 1, n
     do j = 1, m
        c(i) = c(i) + a(i) * b(j) * 2*rec
     end do
  end do

  write(*,*) c(100),c(1000)

end program no_benefits


! efefer 1 January 2016
! modified 20 October 2016

SUBROUTINE init_Laplacian3d( NNZ, NN, Npoints, lin2xyz, x_D2jl, y_D2jl, z_D2jl, row, column, values )
  IMPLICIT NONE
  !
  INTEGER :: NNZ
  INTEGER(8) :: NN(3)
  INTEGER(8) :: Npoints
  INTEGER(8) :: lin2xyz(3,Npoints)
  REAL(8) :: x_D2jl( NN(1), NN(1) )
  REAL(8) :: y_D2jl( NN(2), NN(2) )
  REAL(8) :: z_D2jl( NN(3), NN(3) )
  INTEGER(8) :: row(NNZ), column(NNZ)
  REAL(8) :: values(NNZ)
  !
  INTEGER(8) :: ip1, ip2, i1,i2, j1,j2, k1,k2
  REAL(8) :: nabla2
  LOGICAL :: Tnz(3)
  INTEGER :: inz

  !WRITE(*,*) 'Calling init_Laplacian'
  !WRITE(*,*) 'NN = ', NN(1:3)
  !WRITE(*,*) 'Npoints = ', Npoints

  !WRITE(*,*) 'Pass here 46'
  inz = 0
  !WRITE(*,*) 'Pass here 48'
  DO ip2 = 1, Npoints
    DO ip1 = ip2, Npoints
      Tnz(:) = .FALSE.
      i1 = lin2xyz(1,ip1)
      i2 = lin2xyz(1,ip2)
      !
      j1 = lin2xyz(2,ip1)
      j2 = lin2xyz(2,ip2)
      !
      k1 = lin2xyz(3,ip1)
      k2 = lin2xyz(3,ip2)
      !
      nabla2 = 0.d0
      !
      IF( j1 == j2 .AND. k1 == k2 ) THEN
        nabla2 = nabla2 + x_D2jl(i1,i2)
        Tnz(1) = .TRUE.
      ENDIF
      !
      IF( i1 == i2 .AND. k1 == k2 ) THEN
        nabla2 = nabla2 + y_D2jl(j1,j2)
        Tnz(2) = .TRUE.
      ENDIF
      !
      IF( i1 == i2 .AND. j1 == j2 ) THEN
        nabla2 = nabla2 + z_D2jl(k1,k2)
        Tnz(3) = .TRUE.
      ENDIF
      !WRITE(*,*) ip1,ip2, any(Tnz)
      IF( ANY(Tnz) ) THEN
        inz = inz + 1
        values(inz) = nabla2
        column(inz) = ip1
        row(inz)    = ip2
        !WRITE(*,*) 'Nonzero:', ip1, ip2, nabla2
        IF( ip1 /= ip2 ) THEN
          inz = inz + 1
          values(inz) = nabla2
          column(inz) = ip2
          row(inz)    = ip1
        ENDIF
      ENDIF ! Tnz
      !
    ENDDO !
  ENDDO

  !WRITE(*,*) 'NNZ, Npoints = ', NNZ, Npoints
  !WRITE(*,*) 'Percentage   = ', ( NNZ ) / dble(Npoints**2) * 100d0
END SUBROUTINE

FUNCTION get_NNZ_Laplacian3d( NN, Npoints, lin2xyz, x_D2jl, y_D2jl, z_D2jl ) RESULT(NNZ)
  IMPLICIT NONE
  !
  INTEGER(8) :: NN(3)
  INTEGER(8) :: Npoints
  INTEGER(8) :: lin2xyz(3,Npoints)
  REAL(8) :: x_D2jl( NN(1), NN(1) )
  REAL(8) :: y_D2jl( NN(2), NN(2) )
  REAL(8) :: z_D2jl( NN(3), NN(3) )
  INTEGER(8) :: NNZ
  !
  INTEGER(8) :: istep, ip1, ip2, i1,i2, j1,j2, k1,k2
  REAL(8) :: nabla2
  LOGICAL :: Tnz(3)

  !WRITE(*,*) 'Calling init_Laplacian'
  !WRITE(*,*) 'NN = ', NN(1:3)
  !WRITE(*,*) 'Npoints = ', Npoints

  !WRITE(*,*) 'Pass here 46'
  NNZ = 0
  !WRITE(*,*) 'Pass here 48'
  DO ip2 = 1, Npoints
    DO ip1 = ip2, Npoints
      !WRITE(*,*) ip1, ip2
      Tnz(:) = .FALSE.
      i1 = lin2xyz(1,ip1)
      i2 = lin2xyz(1,ip2)
      !
      j1 = lin2xyz(2,ip1)
      j2 = lin2xyz(2,ip2)
      !
      k1 = lin2xyz(3,ip1)
      k2 = lin2xyz(3,ip2)
      !
      nabla2 = 0.d0
      !
      IF( j1 == j2 .AND. k1 == k2 ) Tnz(1) = .TRUE.
      IF( i1 == i2 .AND. k1 == k2 ) Tnz(2) = .TRUE.
      IF( i1 == i2 .AND. j1 == j2 ) Tnz(3) = .TRUE.
      !WRITE(*,*) ip1,ip2, any(Tnz)
      IF( ANY(Tnz) ) THEN
        NNZ = NNZ + 1
        IF( ip1 /= ip2 ) NNZ = NNZ + 1
      ENDIF
        !
    ENDDO
  ENDDO

  !WRITE(*,*) 'NNZ, Npoints = ', NNZ, Npoints
  !WRITE(*,*) 'Percentage   = ', ( NNZ ) / dble(Npoints**2) * 100d0
END FUNCTION


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(grid_transfer_routines) grid_transfer_scalar_shift

contains

    !     subroutine sshifte(ioff, nlon, nlat, goff, greg, wsav, lsav, work, lwork, ier)
    !
    ! *** purpose
    !
    !     subroutine sshifte does a highly accurate 1/2 grid increment shift
    !     in both longitude and latitude of equally spaced data on the sphere.
    !     data is transferred between the nlon by nlat "offset grid" in goff
    !     (which excludes poles) and the nlon by nlat+1 "regular grid" in greg
    !     (which includes poles).  the transfer can go from goff to greg or from
    !     greg to goff (see ioff).  the grids which underly goff and greg are
    !     described below.  the north and south poles are at latitude HALF*pi and
    !     -HALF*pi radians respectively.
    !
    ! *** grid descriptions
    !
    !     let dlon = (pi+pi)/nlon and dlat = pi/nlat be the uniform grid
    !     increments in longitude and latitude
    !
    !     offset grid
    !
    !     the "1/2 increment offset" grid (long(j), lat(i)) on which goff(j, i)
    !     is given (ioff=0) or generated (ioff=1) is
    !
    !          long(j) =HALF*dlon + (j-1)*dlon  (j=1, ..., nlon)
    !
    !     and
    !
    !          lat(i) = -HALF*pi + HALF*dlat + (i-1)*dlat (i=1, ..., nlat)
    !
    !     the data in goff is "shifted" one half a grid increment in longitude
    !     and latitude and excludes the poles.  each goff(j, 1) is given at
    !     latitude -HALF*pi+HALF*dlat and goff(j, nlat) is given at HALF*pi-HALF*dlat
    !     (1/2 a grid increment away from the poles).  each goff(1, i), goff(nlon, i)
    !     is given at longitude HALF*dlon and 2.*pi-HALF*dlon.
    !
    !     regular grid
    !
    !     let dlat, dlon be as above.  then the nlon by nlat+1 grid on which
    !     greg(j, i) is generated (ioff=0) or given (ioff=1) is given by
    !
    !          lone(j) = (j-1)*dlon (j=1, ..., nlon)
    !
    !      and
    !
    !          late(i) = -HALF*pi + (i-1)*dlat (i=1, ..., nlat+1)
    !
    !     values in greg include the poles and start at zero degrees longitude.
    !
    ! *** remark
    !
    !     subroutine sshifte can be used in conjunction with subroutine trssph
    !     when transferring data from an equally spaced "1/2 increment offset"
    !     grid to a gaussian or equally spaced grid (which includes poles) of
    !     any resolution.  this problem (personal communication with dennis
    !     shea) is encountered in geophysical modeling and data analysis.
    !
    ! *** method
    !
    !     fast fourier transform software from spherepack2 and trigonometric
    !     identities are used to accurately "shift" periodic vectors half a
    !     grid increment in latitude and longitude.  latitudinal shifts are
    !     accomplished by setting periodic 2*nlat vectors over the pole for each
    !     longitude.  when nlon is odd, this requires an additional longitude
    !     shift.  longitudinal shifts are then executed for each shifted latitude.
    !     when necessary (ioff=0) poles are obtained by averaging the nlon
    !     shifted polar values.
    !
    ! *** required spherepack files
    !
    !     type_RealPeriodicFastFourierTransform.f
    !
    ! *** argument description
    !
    ! ... ioff
    !
    !     ioff = 0 if values on the offset grid in goff are given and values
    !              on the regular grid in greg are to be generated.
    !
    !     ioff = 1 if values on the regular grid in greg are given and values
    !              on the offset grid in goff are to be generated.
    !
    ! ... nlon
    !
    !     the number of longitude points on both the "offset" and "regular"
    !     uniform grid in longitude (see "grid description" above).  nlon
    !     is also the first dimension of array goff and greg.  nlon determines
    !     the grid increment in longitude as dlon = 2.*pi/nlon.  for example,
    !     nlon = 144 for a 2.5 degree grid.  nlon can be even or odd and must
    !     be greater than or equal to 4.  the efficiency of the computation
    !     is improved when nlon is a product of small primes.
    !
    ! ... nlat
    !
    !     the number of latitude points on the "offset" uniform grid.  nlat+1
    !     is the number of latitude points on the "regular" uniform grid (see
    !     "grid description" above).  nlat is the second dimension of array goff.
    !     nlat+1 must be the second dimension of the array greg in the program
    !     calling sshifte.  nlat determines the grid in latitude as pi/nlat.
    !     for example, nlat = 36 for a five degree grid.  nlat must be at least 3.
    !
    ! ... goff
    !
    !     a nlon by nlat array that contains data on the offset grid
    !     described above.  goff is a given input argument if ioff=0.
    !     goff is a generated output argument if ioff=1.
    !
    ! ... greg
    !
    !     a nlon by nlat+1 array that contains data on the regular grid
    !     described above.  greg is a given input argument if ioff=1.
    !     greg is a generated output argument if ioff=0.
    !
    ! ... wsav
    !
    !     a real saved workspace array that must be initialized by calling
    !     subroutine sshifti(ioff, nlon, nlat, wsav, ier) before calling sshifte.
    !     wsav can then be used repeatedly by sshifte as long as ioff, nlon,
    !     and nlat do not change.  this bypasses redundant computations and
    !     saves time.  undetectable errors will result if sshifte is called
    !     without initializing wsav whenever ioff, nlon, or nlat change.
    !
    ! ... lsav
    !
    !     the length of the saved workspace wsav in the routine calling sshifte
    !     and sshifti.  lsave must be greater than or equal to 2*(2*nlat+nlon+16).
    !
    ! ... work
    !
    !     a real unsaved workspace
    !
    ! ... lwork
    !
    !     the length of the unsaved workspace in the routine calling sshifte
    !     lwork must be greater than or equal to 2*nlon*(nlat + 1) if nlon is even.
    !     lwork must be greater than or equal to nlon*(5*nlat+1) if nlon is odd.
    !
    ! ... ier
    !
    !     indicates errors in input parameters
    !
    !     = 0 if no errors are detected
    !
    !     = 1 if ioff is not equal to 0 or 1
    !
    !     = 1 if nlon < 4
    !
    !     = 2 if nlat < 3
    !
    !     = 3 if lsave < 2*(nlon+2*nlat+16)
    !
    !     = 4 if lwork < 2*nlon*(nlat + 1) for nlon even or
    !            lwork < nlon*(5*nlat+1) for nlon odd
    !
    module subroutine sshifte(ioff, nlon, nlat, goff, greg, wsav, ier)

        ! Dummy arguments
        integer(ip), intent(in)    :: ioff
        integer(ip), intent(in)    :: nlon
        integer(ip), intent(in)    :: nlat
        real(wp),    intent(inout) :: goff(:,:)
        real(wp),    intent(inout) :: greg(:,:)
        real(wp),    intent(in)    :: wsav(:)
        integer(ip), intent(out)   :: ier

        ! Local variables
        integer(ip) :: ioff, nlon, nlat, n2, nr, two_nlat, nlatp1
        integer(ip) :: lwork, iw1, iw2

        ! Check calling arguments
        call check_calling_arguments(ioff, nlon, nlat, wsav, ier)

        ! Check error flag
        if (ier /= 0) return

        n2 = (nlon + 1)/2
        if ((2 * n2) == nlon) then
            lwork = 2 * nlon * (nlat + 1)
            iw1 = 1
            nr = n2
        else
            lwork = nlon * ((5 * nlat) + 1)
            iw1 = 1 + (2 * nlat * nlon)
            nr = nlon
        end if

        two_nlat = 2 * nlat
        nlatp1 = nlat + 1
        iw2 = iw1 + (nlat + 1) * nlon

        block
            real(wp) :: work(lwork)

            if (ioff == 0) then
                call shftoff(nlon, nlat, goff, greg, wsav, nr, two_nlat, &
                    work, work(iw1:), work(iw2:))
            else
                nlatp1 = nlat+1
                call shftreg(nlon, nlat, goff, greg, wsav, nr, two_nlat, nlatp1, &
                    work, work(iw1:), work(iw2:))
            end if
        end block

    end subroutine sshifte

    !     subroutine sshifti(ioff, nlon, nlat, wsav, ier)
    !
    !     subroutine sshifti initializes the saved workspace wsav
    !     for ioff and nlon and nlat (see documentation for sshifte).
    !     sshifti must be called before sshifte whenever ioff or nlon
    !     or nlat change.
    !
    ! ... ier
    !
    !     = 0 if no errors with input arguments
    !
    !     = 1 if ioff is not 0 or 1
    !
    !     = 2 if nlon < 4
    !
    !     = 3 if nlat < 3
    !
    !     = 4 if lsav < 2*(2*nlat+nlon+16)
    !
    module subroutine sshifti(ioff, nlon, nlat, wsav, ier)

        ! Dummy arguments
        integer(ip), intent(in)  :: ioff
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: nlat
        real(wp),    intent(out) :: wsav(:)
        integer(ip), intent(out) :: ier

        ! Local variables
        integer(ip) :: two_nlat, iw
        real(wp)    :: dlat, dlon, dp

        ! Check calling arguments
        call check_calling_arguments(ioff, nlon, nlat, wsav, ier)

        ! Check error flag
        if (ier /= 0) return

        ! Set lat, lon increments
        dlat = PI/nlat
        dlon = TWO_PI/nlon

        ! Initialize wsav for left or right latitude shifts
        if (ioff == 0) then
            dp = -HALF * dlat
        else
            dp = HALF * dlat
        end if

        two_nlat = 2 * nlat

        call shifthi(two_nlat, dp, wsav)

        ! Initialize wsav for left or right longitude shifts
        if (ioff == 0) then
            dp = -HALF * dlon
        else
            dp = HALF * dlon
        end if

        iw = (4 * nlat) + 17

        call shifthi(nlon, dp, wsav(iw:))

    end subroutine sshifti

    subroutine shftoff(nlon, nlat, goff, greg, wsav, nr, nlat2, &
        rlat, rlon, wrk)
        !
        !     shift offset grid to regular grid, i.e.,
        !     goff is given, greg is to be generated
        !

        integer(ip) :: nlon, nlat, nlat2, n2, nr, j, i, js, isav
        real(wp) :: goff(nlon, nlat), greg(nlon, nlat+1)
        real(wp) :: rlat(nr, nlat2), rlon(nlat, nlon)
        real(wp) :: wsav(*), wrk(*)
        real(wp) :: gnorth, gsouth
        isav = 4*nlat+17
        n2 = (nlon + 1)/2
        !
        !     execute full circle latitude shifts for nlon odd or even
        !
        if (2*n2 > nlon) then
            !
            !     odd number of longitudes
            !
            do i=1, nlat
                do j=1, nlon
                    rlon(i, j) = goff(j, i)
                end do
            end do
            !
            !       half shift in longitude
            !
            call shifth(nlat, nlon, rlon, wsav(isav), wrk)
                !
                !       set full 2*nlat circles in rlat using shifted values in rlon
                !
            do j=1, n2-1
                js = j+n2
                do i=1, nlat
                    rlat(j, i)      = goff(j, i)
                    rlat(j, nlat+i) = rlon(nlat+1-i, js)
                end do
            end do
            do j=n2, nlon
                js = j-n2+1
                do i=1, nlat
                    rlat(j, i)      = goff(j, i)
                    rlat(j, nlat+i) = rlon(nlat+1-i, js)
                end do
            end do
            !
            !       shift the nlon rlat vectors one half latitude grid
            !
            call shifth(nlon, nlat2, rlat, wsav, wrk)
                !
                !       set nonpole values in greg and average for poles
                !
            gnorth = ZERO
            gsouth = ZERO
            do j=1, nlon
                gnorth = gnorth + rlat(j, 1)
                gsouth = gsouth + rlat(j, nlat+1)
                do i=2, nlat
                    greg(j, i) =  rlat(j, i)
                end do
            end do
            gnorth = gnorth/nlon
            gsouth = gsouth/nlon

        else
                !
                !     even number of longitudes (no initial longitude shift necessary)
                !     set full 2*nlat circles (over poles) for each longitude pair (j, js)
                !
            do j=1, n2
                js = n2+j
                do i=1, nlat
                    rlat(j, i)      = goff(j, i)
                    rlat(j, nlat+i) = goff(js, nlat+1-i)
                end do
            end do
            !
            !       shift the n2=(nlon + 1)/2 rlat vectors one half latitude grid
            !
            call shifth(n2, nlat2, rlat, wsav, wrk)
            !
            !       set nonpole values in greg and average poles
            !
            gnorth = ZERO
            gsouth = ZERO
            do j=1, n2
                js = n2+j
                gnorth = gnorth + rlat(j, 1)
                gsouth = gsouth + rlat(j, nlat+1)
                do i=2, nlat
                    greg(j, i) =  rlat(j, i)
                    greg(js, i) = rlat(j, nlat2-i+2)
                end do
            end do
            gnorth = gnorth/n2
            gsouth = gsouth/n2
        end if

        !
        !     set poles
        !
        do j=1, nlon
            greg(j, 1)      = gnorth
            greg(j, nlat+1) = gsouth
        end do
        !
        !     execute full circle longitude shift
        !
        do j=1, nlon
            do i=1, nlat
                rlon(i, j) = greg(j, i)
            end do
        end do

        call shifth(nlat, nlon, rlon, wsav(isav), wrk)

        do j=1, nlon
            do i=2, nlat
                greg(j, i) = rlon(i, j)
            end do
        end do

    end subroutine shftoff

    subroutine shftreg(nlon, nlat, goff, greg, wsav, nr, nlat2, nlatp1, &
        rlat, rlon, wrk)
        !
        !     shift regular grid to offset grid, i.e.,
        !     greg is given, goff is to be generated
        !

        integer(ip) :: nlon, nlat, nlat2, nlatp1, n2, nr, j, i, js, isav
        real(wp) :: goff(nlon, nlat), greg(nlon, nlatp1)
        real(wp) :: rlat(nr, nlat2), rlon(nlatp1, nlon)
        real(wp) :: wsav(*), wrk(*)
        isav = 4*nlat+17
        n2 = (nlon + 1)/2
        !
        !     execute full circle latitude shifts for nlon odd or even
        !
        if (2*n2 > nlon) then
                !
                !     odd number of longitudes
                !
            do i=1, nlat+1
                do j=1, nlon
                    rlon(i, j) = greg(j, i)
                end do
            end do
            !
            !       half shift in longitude in rlon
            !
            call shifth(nlat+1, nlon, rlon, wsav(isav), wrk)
                !
                !       set full 2*nlat circles in rlat using shifted values in rlon
                !
            do j=1, n2
                js = j+n2-1
                rlat(j, 1) = greg(j, 1)
                do i=2, nlat
                    rlat(j, i) = greg(j, i)
                    rlat(j, nlat+i) = rlon(nlat+2-i, js)
                end do
                rlat(j, nlat+1) = greg(j, nlat+1)
            end do
            do j=n2+1, nlon
                js = j-n2
                rlat(j, 1) = greg(j, 1)
                do i=2, nlat
                    rlat(j, i) = greg(j, i)
                    rlat(j, nlat+i) = rlon(nlat+2-i, js)
                end do
                rlat(j, nlat+1) = greg(j, nlat+1)
            end do
            !
            !       shift the nlon rlat vectors one halflatitude grid
            !
            call shifth(nlon, nlat2, rlat, wsav, wrk)
                !
                !       set values in goff
                !
            do j=1, nlon
                do i=1, nlat
                    goff(j, i) =  rlat(j, i)
                end do
            end do

        else
            !
            !     even number of longitudes (no initial longitude shift necessary)
            !     set full 2*nlat circles (over poles) for each longitude pair (j, js)
            !
            do j=1, n2
                js = n2+j
                rlat(j, 1) = greg(j, 1)
                do i=2, nlat
                    rlat(j, i) = greg(j, i)
                    rlat(j, nlat+i) = greg(js, nlat+2-i)
                end do
                rlat(j, nlat+1) = greg(j, nlat+1)
            end do
            !
            !       shift the n2=(nlon + 1)/2 rlat vectors one half latitude grid
            !
            call shifth(n2, nlat2, rlat, wsav, wrk)
            !
            !       set values in goff
            !
            do j=1, n2
                js = n2+j
                do i=1, nlat
                    goff(j, i) =  rlat(j, i)
                    goff(js, i) = rlat(j, nlat2+1-i)
                end do
            end do
        end if

        !
        !     execute full circle longitude shift for all latitude circles
        !
        do j=1, nlon
            do i=1, nlat
                rlon(i, j) = goff(j, i)
            end do
        end do

        call shifth(nlat+1, nlon, rlon, wsav(isav), wrk)

        do j=1, nlon
            do i=1, nlat
                goff(j, i) = rlon(i, j)
            end do
        end do

    end subroutine shftreg

    subroutine shifth(m, n, r, wsav, work)

        ! Dummy arguments
        integer(ip), intent(in)    :: m, n
        real(wp),    intent(inout) :: r(:,:)
        real(wp),    intent(in)    :: wsav(*)
        real(wp),    intent(out)   :: work(*)

        ! Local variables
        type(RealPeriodicFastFourierTransform) :: hfft
        integer(ip)  :: m, n, n2, k, l, iw1
        real(wp)     :: r2km2, r2km1

        n2 = (n+1)/2

        ! Set wavetable index pointer
        iw1 = n+2

        !     compute fourier coefficients for r on shifted grid
        call hfft%forward(m, n, r, m, wsav(iw1))
        do l=1, m
            do k=2, n2
                r2km2 = r(l, k+k-2)
                r2km1 = r(l, k+k-1)
                r(l, k+k-2) = r2km2*wsav(n2+k) - r2km1*wsav(k)
                r(l, k+k-1) = r2km2*wsav(k) + r2km1*wsav(n2+k)
            end do
        end do

        !     shift r with fourier synthesis and normalization
        call hfft%backward(m, n, r, m, wsav(iw1))

        do l=1, m
            do k=1, n
                r(l, k) = r(l, k)/n
            end do
        end do

    end subroutine shifth

    ! Purpose:
    !
    ! Initialize wsav for subroutine shifth
    !
    pure subroutine shifthi(n, dp, wavetable)

        ! Dummy arguments
        integer(ip), intent(in)  :: n
        real(wp),    intent(in)  :: dp
        real(wp),    intent(out) :: wavetable(*)

        ! Local variables
        type(RealPeriodicFastFourierTransform) :: hfft
        integer(ip) :: k, n2, iw
        real(wp)    :: arg

        n2 = (n+1)/2
        do k=2, n2
            arg = real(k - 1, kind=wp) * dp
            wavetable(k) = sin(arg)
            wavetable(k+n2) = cos(arg)
        end do

        ! Set wavetable index pointer
        iw = n + 2
        call hfft%initialize(n, wavetable(iw))

    end subroutine shifthi

end submodule grid_transfer_scalar_shift


c----------------------------------------------------------------
c The chemical model example of daspk but with the
c production rate a forcing function rather than
c a parameter...
c----------------------------------------------------------------

c -------- ChemicalDAE.f -> ChemicalDAE.dll ------
c compile in R with: system("g77 -shared -o ChemicalDAE.dll ChemicalDAE.f")
c or with system("R CMD SHLIB ChemicalDAE.f")

c----------------------------------------------------------------
c Initialiser for parameter common block
c----------------------------------------------------------------
      subroutine initparms(daspkparms)

      external daspkparms
      double precision parms(3)
      common /myparms/parms

      call daspkparms(3, parms)
      return
      end

c----------------------------------------------------------------
c Initialiser for forcing common block
c----------------------------------------------------------------
      subroutine initforcs(daspkforcs)

      external daspkforcs

      double precision forcs(1)
      common /myforcs/forcs

      call daspkforcs(1, forcs)
      return
      end

c----------------------------------------------------------------
c residual of rate of change and 1 output variable
c----------------------------------------------------------------
      subroutine chemres (t, y, ydot, cj, delta, ires, out, ipar)
      integer            :: ires, ipar(*)
      integer, parameter :: neq = 3
      double precision   :: t, y(neq), ydot(neq), delta(neq), out(*)
      double precision   :: K, ka, r, prod, ra, rb

      common / myparms / K, ka, r
      common / myforcs / prod

      if(IPar(1) < 2) call rexit("nout should be at least 2")

      ra  = ka* y(3)            ! forward rate
      rb  = ka/K *y(1) * y(2)   ! backward rate

      ! residuals of rates of changes
      delta(3) = -ydot(3)  -  ra + rb + prod
      delta(1) = -ydot(1)  +  ra - rb
      delta(2) = -ydot(2)  +  ra - rb - r*y(2)
      out(1)   = y(1) + y(2) + y(3)
      out(2)   = prod

      return
      end


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
! Two band model (3D)
module global_variables
  use mpi_module
! mathematical parameters
  real(8),parameter :: pi = 4d0*atan(1d0)
  complex(8),parameter :: zI = (0d0,1d0)
  real(8),parameter :: a_B=0.529177d0,Ry=13.6058d0,ev=Ry*2d0

!! Control parameters
! Band structure parameters
  integer,parameter :: N_PARABOLIC_BAND = 0
  integer,parameter :: N_NONPARABOLIC_BAND = 1
  integer,parameter :: N_COS_BAND = 2
  integer,parameter :: N_COS4_BAND = 3
  integer,parameter :: N_HBN_BAND = 4
! Pump-probe parameters
  integer,parameter :: N_COMBINED_PUMP_PROBE = 0
  integer,parameter :: N_DECOMPOSED_PUMP_PROBE = 1

! Material parameters
  integer :: NKr,NKz, NKx, NKy
  real(8) :: kr_max,kz_max,dkr,dkz, kx_max, ky_max, dkx,dky
  real(8),allocatable :: kr(:),kz0(:),kz(:),kx0(:),ky0(:),kx(:),ky(:)
  real(8),parameter :: eps_g = 1.75d0/(2d0*Ry)  !1.52d0/(2d0*Ry)
  real(8),parameter :: mass_r = 1d0/(1d0/0.13d0+1d0/0.45d0)
  real(8),parameter :: piz_vc = 0.5d0*sqrt(eps_g/mass_r)
  real(8),parameter :: pix_vc = 0d0
  real(8),parameter :: piy_vc = 0d0
  real(8),parameter :: fact_intra = 1d0
  integer,parameter :: nband_type = N_PARABOLIC_BAND !N_NONPARABOLIC_BAND
  real(8),parameter :: band_width = 2d0/ev !1d0/(1d0/0.57d0+1d0/0.067d0)

! Time-propagation
  integer,parameter :: npump_probe_type = N_COMBINED_PUMP_PROBE
  integer :: Nt
  real(8) :: dt
  real(8),allocatable :: deps_int(:,:),deps(:,:),ddeps_dkz(:,:)
  complex(8),allocatable :: zCt(:,:,:)
  real(8),allocatable :: Act(:),Act_dt2(:),jtz(:),jtz_intra(:),jtz_inter(:)
  real(8),allocatable :: Act_pump(:),Act_probe(:)
  real(8),allocatable :: Act_xyz(:,:),Act_pump_xyz(:,:),Act_probe_xyz(:,:),jt_xyz(:,:)
  character(20) :: envelope_1,envelope_2

! Laser parameters
  real(8) :: E0_1,E0_1_V_m,omega_1,tpulse_1,omega_ev_1,tpulse_fs_1,Iwcm2_1,CEP_2pi_1
  real(8) :: E0_2,E0_2_V_m,omega_2,tpulse_2,omega_ev_2,tpulse_fs_2,Iwcm2_2,CEP_2pi_2
  real(8) :: Tdelay_fs,Tdelay

! impulsive
  real(8),parameter :: kick_impulsive = 1d-4
  logical,parameter :: if_add_impulsive = .false.

!! pure intraband field
  logical,parameter :: if_pure_intraband_fields_exist = .true.
  real(8),allocatable :: Act_intra(:)
  real(8) :: E0_static, T_duration_static
  real(8) :: E0_static_V_AA

end module global_variables


C==================================================================
C Sous routine EVALG :
C    . Evaluation du second membre (C/dt-(1-theta)*K)*un + forces
C
C Modifié le 06.04.97
C==================================================================
C
      SUBROUTINE EVALG(a1,a2,u,A,Tf,theta,NN,g,h,N,dt,IT,ITMAX,
     #                 IDIAG,S)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION u(NN),g(NN),S(3,NN)
C
      IF(IDIAG.EQ.0)THEN
         t1 = a2/dt + a1 * (1.0-theta)
         t2 = 4.0 * a2/dt - 2.0 * a1 * (1.0-theta)
         DO i=2,N
            g(i)=(u(i-1)+u(i+1))*t1 + u(i)*t2
         ENDDO
         g(N+1) = u(N)*t1 + u(N+1)* t2/2.0
         g(1)   = u(2)*t1 + u(1)  * t2/2.0
         g(1)   = g(1) - u(1) * h*A*(1.0-theta) + h*A*Tf
C
         IF (IT.EQ.ITMAX) THEN
            g(1) = g(1) - theta * h*A*Tf
         ENDIF
      ELSE
         t1 = a1
         t2 = - 2.0 * a1
         DO i=1,N+1
            g(i)=u(i)*S(2,i)
         ENDDO
         DO i=2,N
            g(i)=g(i) + (u(i-1)+u(i+1))*t1 + u(i)*t2
         ENDDO
         g(N+1) = g(N+1) + u(N)*t1 + u(N+1)* t2/2.0
         g(1)   = g(1) + u(2)*t1 + u(1)  * t2/2.0
         g(1)   = g(1) - u(1) * h*A + h*A*Tf
      ENDIF
C
      RETURN
      END


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_pt_shrink( n, c, gg, p, k_ell, info )

!  Given the ellipse E = { x | (x-c)^T * G * G^T * (x-c) <= 1 },
!  where G is lower triangular, and the point p which is covered by E, we define:
! 1/ Ev: the maximum volume ellipse covered by E with p on its boundary
! 2/ En: the ellipse of maximal near content covered by E with p on its
! boundary
! 3/ Ec: the minimum volume ellipse covering Ev and En.
! For k=|k_ell|=1,2 or 3,  G is modified to correspond to Ev, En or Ec, respectively.
!  G (in packed format) is contained in gg.
!
! info = 0 - p is in the interior of E (intended case): G is returned corresponding to Ev, En or Ec.
! info = 1 - p is on the boundary of E (within tol): G is returned unchanged
! info = 2 - p is not covered by E: G is returned unchanged

!  S.B. Pope  12/26/05

implicit none

integer,    parameter     :: k_dp = kind(1.d0)
integer,    intent(in)    :: n, k_ell
real(k_dp), intent(in)    :: c(n), p(n)
real(k_dp), intent(inout) :: gg( (n*(n+1))/2 )
integer,    intent(out)   :: info

real(k_dp), parameter     :: tol = 1.d-10

integer    :: j, k, lwork
real(k_dp) :: U(n,n), sig(n), ph(n), phsqi, wt(n), pt(n), R(n,2), tau(n), work(n+10), &
              Lb(2,2), Lch(n,n), B(n,n), pch(n), dpsq
logical    :: in

lwork = n+10
info  = 0

!  check input
k = iabs( k_ell )
if( k < 1  .or.  k > 3 ) then
   write(0,*) 'ell_pt_shrink: invalid k_ell = ', k_ell
   stop
endif

if( k_ell == 1 ) then  !  efficient determination of Ev (avoids SVD)
   call ell_pt_in( n, c, gg, p, in )
   if( .not.in ) then
      info = 2
	  return
   endif

   call ell_pt_modify( n, c, gg, p )
   return
endif

call ell_chol2eig( n, gg, U, sig )  !  SVD  G = U * diag(sig)

ph  = matmul( p-c , U )  ! ph   = U'*(p-c)
pt  = sig*ph
dpsq     = sum( pt*pt )

if( dpsq > 1.d0 + tol ) then
   info = 2  !  p is not covered by E
   return
elseif( dpsq >= 1.d0 - tol ) then
   info = 1  !  p is on the boundary of E
   return
elseif( dpsq == 0.d0 ) then
   write(0,*) 'ell_pt_shrink_cons: p = c'
   stop
endif

if( n==1 ) then !  special case, n=1
   gg(1) = 1.d0 / abs(p(1)-c(1))
   return
endif

phsqi= 1.d0/sum(ph*ph)
do j=1,n
   wt(j)=max(0.d0, phsqi-sig(j)**2)
end do

wt  = wt*ph/sig

R(:,1) = wt
R(:,2) = pt

call dgeqrf( n, 2, R, n, tau, work, lwork, info )  ! [Q,R] = qr([wt pt])

if( info /= 0 ) then
   write(0,*) 'ell_shrink: dgeqrf failed, info = ', info
   stop
endif

pch = R(:,2)  !  pch   = Q'*pt

call ell_cov_2d( pch(1:2), k, Lb )

Lch = 0.d0
do j = 1, n
   Lch(j,j) = 1.d0
end do

Lch(1:2,1:2) = Lb(1:2,1:2)

call dormqr( 'L', 'N', n, n, 2, R, n, tau, Lch, n, work, lwork, info )  ! Q*Lch

if( info /= 0 ) then
   write(0,*) 'ell_shrink_cons: dormqr failed, info = ', info
   stop
endif

do j = 1, n
  Lch(j,:) = sig(j) * Lch(j,:)  ! Sig*Q*Lch
end do

B = matmul( U, Lch )  !  B = U*Sig*Q*Lch

call dgelqf( n, n, B, n, tau, work, lwork, info )  !  L * Q = B

if( info /= 0 ) then
   write(0,*) 'ell_shrink_cons: dgelqf failed, info = ', info
   stop
endif

call ell_full2low( n, B, gg )

end subroutine ell_pt_shrink