! :::
! ::: ------------------------------------------------------------------
! :::

      subroutine advect(time,lo,hi,domlo,domhi, &
                        uin,uin_l1,uin_l2,uin_h1,uin_h2, &
                        uout,uout_l1,uout_l2,uout_h1,uout_h2, &
                        ugdx,ugdx_l1,ugdx_l2,ugdx_h1,ugdx_h2, &
                        ugdy,ugdy_l1,ugdy_l2,ugdy_h1,ugdy_h2, &
                        src,src_l1,src_l2,src_h1,src_h2, &
                        flux1,flux1_l1,flux1_l2,flux1_h1,flux1_h2, &
                        flux2,flux2_l1,flux2_l2,flux2_h1,flux2_h2, &
                        delta,dt,verbose)

      use meth_params_module, only : URHO, QVAR, NVAR, NHYP, normalize_species

      implicit none

      integer lo(2),hi(2),verbose
      integer domlo(2),domhi(2)
      integer uin_l1,uin_l2,uin_h1,uin_h2
      integer uout_l1,uout_l2,uout_h1,uout_h2
      integer ugdx_l1,ugdx_l2,ugdx_h1,ugdx_h2
      integer ugdy_l1,ugdy_l2,ugdy_h1,ugdy_h2
      integer flux1_l1,flux1_l2,flux1_h1,flux1_h2
      integer flux2_l1,flux2_l2,flux2_h1,flux2_h2
      integer src_l1,src_l2,src_h1,src_h2

      double precision uin(uin_l1:uin_h1,uin_l2:uin_h2,NVAR)
      double precision uout(uout_l1:uout_h1,uout_l2:uout_h2,NVAR)
      double precision ugdx(ugdx_l1:ugdx_h1,ugdx_l2:ugdx_h2)
      double precision ugdy(ugdy_l1:ugdy_h1,ugdy_l2:ugdy_h2)
      double precision src(src_l1:src_h1,src_l2:src_h2,NVAR)
      double precision flux1(flux1_l1:flux1_h1,flux1_l2:flux1_h2,NVAR)
      double precision flux2(flux2_l1:flux2_h1,flux2_l2:flux2_h2,NVAR)
      double precision delta(2),dt,time

!     Automatic arrays for workspace
      double precision, allocatable:: q(:,:,:)
      double precision, allocatable:: div(:,:)
      double precision, allocatable:: srcQ(:,:,:)

      integer ngq,ngf
!     integer i_c,j_c

      double precision dx,dy

      allocate(     q(uin_l1:uin_h1,uin_l2:uin_h2,QVAR))
      allocate(  srcQ(src_l1:src_h1,src_l2:src_h2,QVAR))
      allocate(   div(lo(1)  :hi(1)+1,lo(2)  :hi(2)+1))

      dx = delta(1)
      dy = delta(2)

      ngq = NHYP
      ngf = 1

!     Translate to primitive variables, compute sound speeds
      call ctoprim(lo,hi,uin,uin_l1,uin_l2,uin_h1,uin_h2, &
                   q,uin_l1,uin_l2,uin_h1,uin_h2, &
                   src,srcQ,src_l1,src_l2,src_h1,src_h2, &
                   dx,dy,dt,ngq,ngf)

!     Compute hyperbolic fluxes using unsplit Godunov
      call umeth2d(q,uin_l1,uin_l2,uin_h1,uin_h2, &
                   srcQ, src_l1, src_l2, src_h1, src_h2,  &
                   lo(1),lo(2),hi(1),hi(2),dx,dy,dt, &
                   flux1,flux1_l1,flux1_l2,flux1_h1,flux1_h2, &
                   flux2,flux2_l1,flux2_l2,flux2_h1,flux2_h2, &
                   ugdx,ugdx_l1,ugdx_l2,ugdx_h1,ugdx_h2, &
                   ugdy,ugdy_l1,ugdy_l2,ugdy_h1,ugdy_h2)

!     Compute divergence of velocity field (on surroundingNodes(lo,hi))
      call divu(lo,hi,q,uin_l1,uin_l2,uin_h1,uin_h2, &
                delta,div,lo(1),lo(2),hi(1)+1,hi(2)+1)

!     Conservative update
      call consup(uin,    uin_l1,  uin_l2,  uin_h1,  uin_h2, &
                  uout,  uout_l1, uout_l2, uout_h1, uout_h2, &
                  src,    src_l1,  src_l2,  src_h1,  src_h2, &
                  flux1,flux1_l1,flux1_l2,flux1_h1,flux1_h2, &
                  flux2,flux2_l1,flux2_l2,flux2_h1,flux2_h2, &
                  div,lo,hi,delta,dt)

      ! Enforce the species >= 0
      call enforce_nonnegative_species(uout,uout_l1,uout_l2,uout_h1,uout_h2,lo,hi)

      ! Normalize the species
      if (normalize_species .eq. 1) &
         call normalize_new_species(uout,uout_l1,uout_l2,uout_h1,uout_h2,lo,hi)

      deallocate(q,div)

      end subroutine advect

! ::: ---------------------------------------------------------------
! ::: :: UMETH2D     Compute hyperbolic fluxes using unsplit second
! ::: ::               order Godunov integrator.
! ::: ::
! ::: :: inputs/outputs
! ::: :: q           => (const)  input state, primitives
! ::: :: src         => (const)  source
! ::: :: nx          => (const)  number of cells in X direction
! ::: :: ny          => (const)  number of cells in Y direction
! ::: :: dx          => (const)  grid spacing in X direction
! ::: :: dy          => (const)  grid spacing in Y direction
! ::: :: dt          => (const)  time stepsize
! ::: :: flux1      <=  (modify) flux in X direction on X edges
! ::: :: flux2      <=  (modify) flux in Y direction on Y edges
! ::: ----------------------------------------------------------------

      subroutine umeth2d(q, qd_l1, qd_l2, qd_h1, qd_h2,&
                         srcQ, src_l1, src_l2, src_h1, src_h2, &
                         ilo1, ilo2, ihi1, ihi2, dx, dy, dt, &
                         flux1, fd1_l1, fd1_l2, fd1_h1, fd1_h2, &
                         flux2, fd2_l1, fd2_l2, fd2_h1, fd2_h2, &
                         ugdx,ugdx_l1,ugdx_l2,ugdx_h1,ugdx_h2, &
                         ugdy,ugdy_l1,ugdy_l2,ugdy_h1,ugdy_h2)

      use network, only : nspec
      use meth_params_module, only : QU, QV, QVAR, NVAR

      implicit none

      integer qd_l1, qd_l2, qd_h1, qd_h2
      integer src_l1, src_l2, src_h1, src_h2
      integer fd1_l1, fd1_l2, fd1_h1, fd1_h2
      integer fd2_l1, fd2_l2, fd2_h1, fd2_h2
      integer ugdx_l1,ugdx_l2,ugdx_h1,ugdx_h2
      integer ugdy_l1,ugdy_l2,ugdy_h1,ugdy_h2
      integer ilo1, ilo2, ihi1, ihi2

      double precision dx, dy, dt
      double precision     q(qd_l1:qd_h1,qd_l2:qd_h2,QVAR)
      double precision  srcQ(src_l1:src_h1,src_l2:src_h2)
      double precision ugdx(ugdx_l1:ugdx_h1,ugdx_l2:ugdx_h2)
      double precision ugdy(ugdy_l1:ugdy_h1,ugdy_l2:ugdy_h2)
      double precision flux1(fd1_l1:fd1_h1,fd1_l2:fd1_h2,NVAR)
      double precision flux2(fd2_l1:fd2_h1,fd2_l2:fd2_h2,NVAR)

!     Left and right state arrays (edge centered, cell centered)
      double precision, allocatable:: dq(:,:,:),  qm(:,:,:),   qp(:,:,:)
      double precision, allocatable::qxm(:,:,:),qym(:,:,:)
      double precision, allocatable::qxp(:,:,:),qyp(:,:,:)

!     Work arrays to hold 3 planes of riemann state and conservative fluxes
      double precision, allocatable::   fx(:,:,:),  fy(:,:,:)

!     Local scalar variables
      double precision :: dtdx
      double precision :: hdtdx, hdt, hdtdy
      integer          :: i,j

      allocate ( dq(ilo1-1:ihi1+2,ilo2-1:ihi2+2,QVAR) )
      allocate ( qm(ilo1-1:ihi1+2,ilo2-1:ihi2+2,QVAR) )
      allocate ( qp(ilo1-1:ihi1+2,ilo2-1:ihi2+2,QVAR) )
      allocate ( qxm(ilo1-1:ihi1+2,ilo2-1:ihi2+2,QVAR) )
      allocate ( qxp(ilo1-1:ihi1+2,ilo2-1:ihi2+2,QVAR) )
      allocate ( qym(ilo1-1:ihi1+2,ilo2-1:ihi2+2,QVAR) )
      allocate ( qyp(ilo1-1:ihi1+2,ilo2-1:ihi2+2,QVAR) )
      allocate ( fx(ilo1:ihi1+1,ilo2-1:ihi2+1,NVAR))
      allocate ( fy(ilo1-1:ihi1+1,ilo2:ihi2+1,NVAR))

!     Local constants
      dtdx = dt/dx
      hdtdx = 0.5d0*dtdx
      hdtdy = 0.5d0*dt/dy
      hdt = 0.5d0*dt

      do j = ugdx_l2,ugdx_h2
      do i = ugdx_l1,ugdx_h1
         ugdx(i,j) = 0.5d0 * (q(i,j,QU) + q(i-1,j,QU))
      end do
      end do

      do j = ugdy_l2,ugdy_h2
      do i = ugdy_l1,ugdy_h1
         ugdy(i,j) = 0.5d0 * (q(i,j,QV) + q(i,j-1,QV))
      end do
      end do

!     Trace to edges w/o transverse flux correction terms
      call trace(q,qd_l1,qd_l2,qd_h1,qd_h2, &
                 dq,qxm,qxp,qym,qyp,ilo1-1,ilo2-1,ihi1+2,ihi2+2, &
                 ilo1,ilo2,ihi1,ihi2,dx,dy,dt)

!     Upwind on x-edges
      call upwind(qxm, qxp, ilo1-1, ilo2-1, ihi1+2, ihi2+2, &
                  fx, ilo1, ilo2-1, ihi1+1, ihi2+1, &
                  ugdx, ugdx_l1, ugdx_l2, ugdx_h1, ugdx_h2, &
                  1, ilo1, ihi1, ilo2-1, ihi2+1)

!     Upwind on y-edges
      call upwind(qym, qyp, ilo1-1, ilo2-1, ihi1+2, ihi2+2, &
                  fy, ilo1-1, ilo2, ihi1+1, ihi2+1, &
                  ugdy, ugdy_l1, ugdy_l2, ugdy_h1, ugdy_h2, &
                  2, ilo1-1, ihi1+1, ilo2, ihi2)

!     Use edge states to create transverse derivative in y-direction
      call transy(qxm, qm, qxp, qp, ilo1-1, ilo2-1, ihi1+2, ihi2+2, &
                  fy, ilo1-1, ilo2, ihi1+1, ihi2+1, &
                  srcQ, src_l1, src_l2, src_h1, src_h2, &
                  hdt, hdtdy, ilo1-1, ihi1+1, ilo2, ihi2)

!     Upwind on x-edges to create final fluxes
      call upwind(qm, qp, ilo1-1, ilo2-1, ihi1+2, ihi2+2, &
                  flux1, fd1_l1, fd1_l2, fd1_h1, fd1_h2, &
                  ugdx, ugdx_l1, ugdx_l2, ugdx_h1, ugdx_h2, &
                  1, ilo1, ihi1, ilo2, ihi2)

!     Use edge states to create transverse derivative in x-direction
      call transx(qym, qm,qyp,qp, ilo1-1, ilo2-1, ihi1+2, ihi2+2, &
                  fx, ilo1, ilo2-1, ihi1+1, ihi2+1, &
                  srcQ,  src_l1,  src_l2,  src_h1,  src_h2, &
                  hdt, hdtdx, ilo1, ihi1, ilo2-1, ihi2+1)

!     Upwind on y-edges to create final fluxes
      call upwind(qm, qp, ilo1-1, ilo2-1, ihi1+2, ihi2+2, &
                  flux2, fd2_l1, fd2_l2, fd2_h1, fd2_h2, &
                  ugdy, ugdy_l1, ugdy_l2, ugdy_h1, ugdy_h2, &
                  2, ilo1, ihi1, ilo2, ihi2)

      deallocate(dq,qm,qp,qxm,qxp,qym,qyp)
      deallocate(fx,fy)

      end subroutine umeth2d

! :::
! ::: ------------------------------------------------------------------
! :::

      subroutine ctoprim(lo,hi, &
                         uin,uin_l1,uin_l2,uin_h1,uin_h2, &
                         q,q_l1,q_l2,q_h1,q_h2, &
                         src,srcQ,src_l1,src_l2,src_h1,src_h2, &
                         dx,dy,dt,ngp,ngf)

      use network, only : nspec
      use meth_params_module, only : NVAR, URHO, UX, UY, UFA, UFS, &
                                     QVAR, QRHO, QU, QV, QFA, QFS, &
                                     nadv

      implicit none

      double precision, parameter:: small = 1.d-8

      integer lo(2), hi(2)
      integer uin_l1,uin_l2,uin_h1,uin_h2
      integer q_l1,q_l2,q_h1,q_h2
      integer src_l1,src_l2,src_h1,src_h2

      double precision :: uin(uin_l1:uin_h1,uin_l2:uin_h2,NVAR)
      double precision :: q(q_l1:q_h1,q_l2:q_h2,QVAR)
      double precision :: src (src_l1:src_h1,src_l2:src_h2,NVAR)
      double precision :: srcQ(src_l1:src_h1,src_l2:src_h2,QVAR)
      double precision :: dx, dy, dt

      integer          :: i, j
      integer          :: ngp, ngf, loq(2), hiq(2)
      integer          :: iadv, ispec, n, nq
      double precision :: courx, coury, courmx, courmy

      do i=1,2
         loq(i) = lo(i)-ngp
         hiq(i) = hi(i)+ngp
      enddo

      do j = loq(2),hiq(2)
         do i = loq(1),hiq(1)
            q(i,j,QRHO) = uin(i,j,URHO)
            q(i,j,QU  ) = uin(i,j,UX  )
            q(i,j,QV  ) = uin(i,j,UY  )
         enddo
      enddo

!    Load advected quatities, c, into q, assuming they arrived in uin as rho.c
     do iadv = 1, nadv
         n  = UFA + iadv - 1
         nq = QFA + iadv - 1
         do j = loq(2),hiq(2)
            do i = loq(1),hiq(1)
               q(i,j,nq) = uin(i,j,n)/q(i,j,QRHO)
            enddo
         enddo
      enddo

!     Load chemical species, c, into q, assuming they arrived in uin as rho.c
      do ispec = 1, nspec
         n  = UFS + ispec - 1
         nq = QFS + ispec - 1
         do j = loq(2),hiq(2)
            do i = loq(1),hiq(1)
               q(i,j,nq) = uin(i,j,n)/q(i,j,QRHO)
            enddo
         enddo
      enddo

!     Compute sources in terms of Q
      do j = lo(2)-1, hi(2)+1
        do i = lo(1)-1, hi(1)+1

           do ispec = 1,nspec
              srcQ(i,j,QFS+ispec-1) = src(i,j,UFS+ispec-1)/q(i,j,QRHO)
           enddo

           do iadv = 1,nadv
              srcQ(i,j,QFA+iadv-1) = src(i,j,UFA+iadv-1)/q(i,j,QRHO)
           enddo

        end do
      end do

      end subroutine ctoprim

! :::
! ::: ------------------------------------------------------------------
! :::

      subroutine trace(q,qd_l1,qd_l2,qd_h1,qd_h2, &
                       dq,qxm,qxp,qym,qyp,qpd_l1,qpd_l2,qpd_h1,qpd_h2, &
                       ilo1,ilo2,ihi1,ihi2,dx,dy,dt)

      use network           , only : nspec
      use meth_params_module, only : iorder, QVAR, QRHO, QFA, QFS, nadv

      implicit none

      integer ilo1,ilo2,ihi1,ihi2
      integer qd_l1,qd_l2,qd_h1,qd_h2
      integer qpd_l1,qpd_l2,qpd_h1,qpd_h2

      double precision dx, dy, dt
      double precision     q(qd_l1:qd_h1,qd_l2:qd_h2,QVAR)
      double precision  dq(qpd_l1:qpd_h1,qpd_l2:qpd_h2,QVAR)
      double precision qxm(qpd_l1:qpd_h1,qpd_l2:qpd_h2,QVAR)
      double precision qxp(qpd_l1:qpd_h1,qpd_l2:qpd_h2,QVAR)
      double precision qym(qpd_l1:qpd_h1,qpd_l2:qpd_h2,QVAR)
      double precision qyp(qpd_l1:qpd_h1,qpd_l2:qpd_h2,QVAR)

      ! Local variables
      integer i, j
      integer n, iadv, ispec

      ! Default dq=0.
      dq(ilo1-1:ihi1+1,ilo2-1:ihi2+1,1:QVAR) = 0.d0

      ! Compute slopes in x-direction
      if (iorder .ne. 1) then

         call uslope( q, qd_l1, qd_l2, qd_h1, qd_h2, &
                     dq, qpd_l1,qpd_l2,qpd_h1,qpd_h2, &
                     ilo1,ilo2,ihi1,ihi2,QVAR,1)

      endif

      n = QRHO
      call trace_x(n,q,qd_l1,qd_l2,qd_h1,qd_h2, &
                   dq,qxm,qxp,ilo1-1,ilo2-1,ihi1+2,ihi2+2, &
                   ilo1,ilo2,ihi1,ihi2,dx,dt)

      do ispec = 1, nspec
         n = QFS + ispec - 1
         call trace_x(n,q,qd_l1,qd_l2,qd_h1,qd_h2, &
                      dq,qxm,qxp,ilo1-1,ilo2-1,ihi1+2,ihi2+2, &
                      ilo1,ilo2,ihi1,ihi2,dx,dt)
      end do

      do iadv = 1, nadv
         n = QFA + iadv - 1
         call trace_x(n,q,qd_l1,qd_l2,qd_h1,qd_h2, &
                      dq,qxm,qxp,ilo1-1,ilo2-1,ihi1+2,ihi2+2, &
                      ilo1,ilo2,ihi1,ihi2,dx,dt)
      end do

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

      ! Compute slopes in y-direction
      if (iorder .ne. 1) then

         call uslope(q,qd_l1,qd_l2,qd_h1,qd_h2, &
                     dq,qpd_l1,qpd_l2,qpd_h1,qpd_h2, &
                     ilo1,ilo2,ihi1,ihi2,QVAR,2)

      endif

      n = QRHO
      call trace_y(n,q,qd_l1,qd_l2,qd_h1,qd_h2, &
                   dq,qym,qyp,ilo1-1,ilo2-1,ihi1+2,ihi2+2, &
                   ilo1,ilo2,ihi1,ihi2,dy,dt)

      do ispec = 1, nspec
         n = QFS + ispec - 1
         call trace_y(n,q,qd_l1,qd_l2,qd_h1,qd_h2, &
                        dq,qym,qyp,ilo1-1,ilo2-1,ihi1+2,ihi2+2, &
                        ilo1,ilo2,ihi1,ihi2,dy,dt)
      end do

      do iadv = 1, nadv
         n = QFA + iadv - 1
         call trace_y(n,q,qd_l1,qd_l2,qd_h1,qd_h2, &
                      dq,qym,qyp,ilo1-1,ilo2-1,ihi1+2,ihi2+2, &
                      ilo1,ilo2,ihi1,ihi2,dy,dt)
      end do

      end subroutine trace

! :::
! ::: ------------------------------------------------------------------
! :::

      subroutine trace_x(n,q,qd_l1,qd_l2,qd_h1,qd_h2, &
                         dq,qxm,qxp,qpd_l1,qpd_l2,qpd_h1,qpd_h2, &
                         ilo1,ilo2,ihi1,ihi2,dx,dt)

      use network           , only : nspec
      use meth_params_module, only : iorder, QVAR, QRHO, QU, QFA, QFS, nadv

      implicit none

      integer n
      integer ilo1,ilo2,ihi1,ihi2
      integer qd_l1,qd_l2,qd_h1,qd_h2
      integer qpd_l1,qpd_l2,qpd_h1,qpd_h2

      double precision :: dx, dt
      double precision ::   q(qd_l1:qd_h1,qd_l2:qd_h2,QVAR)
      double precision ::  dq(qpd_l1:qpd_h1,qpd_l2:qpd_h2,QVAR)
      double precision :: qxm(qpd_l1:qpd_h1,qpd_l2:qpd_h2,QVAR)
      double precision :: qxp(qpd_l1:qpd_h1,qpd_l2:qpd_h2,QVAR)

      ! Local variables
      integer          :: i, j
      double precision :: dtdx
      double precision :: u, spzero, acmprght, acmpleft

      dtdx = dt/dx

      do j = ilo2-1, ihi2+1

         ! Right state
         do i = ilo1, ihi1+1
            u = q(i,j,QU)
            if (u .gt. 0.d0) then
               spzero = -1.d0
            else
               spzero = u*dtdx
            endif
            acmprght = 0.5d0*(-1.d0 - spzero )*dq(i,j,n)
            qxp(i,j,n) = q(i,j,n) + acmprght
         enddo

         ! Left state
         do i = ilo1-1, ihi1
            u = q(i,j,QU)
            if (u .ge. 0.d0) then
               spzero = u*dtdx
            else
               spzero = 1.d0
            endif
            acmpleft = 0.5d0*(1.d0 - spzero )*dq(i,j,n)
            qxm(i+1,j,n) = q(i,j,n) + acmpleft
         enddo

      enddo

      end subroutine trace_x

! :::
! ::: ------------------------------------------------------------------
! :::

      subroutine trace_y(n,q,qd_l1,qd_l2,qd_h1,qd_h2, &
                         dq,qym,qyp,qpd_l1,qpd_l2,qpd_h1,qpd_h2, &
                         ilo1,ilo2,ihi1,ihi2,dy,dt)

      use network, only : nspec
      use meth_params_module, only : iorder, QVAR, QRHO, QV, QFA, QFS, nadv

      implicit none

      integer n
      integer ilo1,ilo2,ihi1,ihi2
      integer qd_l1,qd_l2,qd_h1,qd_h2
      integer qpd_l1,qpd_l2,qpd_h1,qpd_h2

      double precision ::  dy, dt
      double precision ::   q(qd_l1:qd_h1,qd_l2:qd_h2,QVAR)
      double precision ::  dq(qpd_l1:qpd_h1,qpd_l2:qpd_h2,QVAR)
      double precision :: qym(qpd_l1:qpd_h1,qpd_l2:qpd_h2,QVAR)
      double precision :: qyp(qpd_l1:qpd_h1,qpd_l2:qpd_h2,QVAR)

      ! Local variables
      integer          :: i, j
      double precision :: v, spzero, acmptop, acmpbot
      double precision :: dtdy

      dtdy = dt/dy

      do i = ilo1-1, ihi1+1

         ! Top state
         do j = ilo2, ihi2+1
            v = q(i,j,QV)
            if (v .gt. 0.d0) then
               spzero = -1.d0
            else
               spzero = v*dtdy
            endif
            acmptop = 0.5d0*(-1.d0 - spzero )*dq(i,j,n)
            qyp(i,j,n) = q(i,j,n) + acmptop
         enddo

         ! Bottom state
         do j = ilo2-1, ihi2
            v = q(i,j,QV)
            if (v .ge. 0.d0) then
               spzero = v*dtdy
            else
               spzero = 1.d0
            endif
            acmpbot = 0.5d0*(1.d0 - spzero )*dq(i,j,n)
            qym(i,j+1,n) = q(i,j,n) + acmpbot
         enddo

      enddo

      end subroutine trace_y

! :::
! ::: ------------------------------------------------------------------
! :::

      subroutine consup( uin, uin_l1, uin_l2, uin_h1, uin_h2, &
                        uout,uout_l1,uout_l2,uout_h1,uout_h2, &
                        src , src_l1, src_l2, src_h1, src_h2, &
                        flux1,flux1_l1,flux1_l2,flux1_h1,flux1_h2, &
                        flux2,flux2_l1,flux2_l2,flux2_h1,flux2_h2, &
                        div,lo,hi,dx,dt)

      use network, only : nspec
      use meth_params_module, only : NVAR, URHO, UX, UY, UFA, UFS, normalize_species, nadv

      implicit none

      integer lo(2), hi(2)
      integer uin_l1,uin_l2,uin_h1,uin_h2
      integer uout_l1,uout_l2,uout_h1,uout_h2
      integer   src_l1,  src_l2,  src_h1,  src_h2
      integer flux1_l1,flux1_l2,flux1_h1,flux1_h2
      integer flux2_l1,flux2_l2,flux2_h1,flux2_h2

      double precision uin(uin_l1:uin_h1,uin_l2:uin_h2,NVAR)
      double precision uout(uout_l1:uout_h1,uout_l2:uout_h2,NVAR)
      double precision   src(  src_l1:  src_h1,  src_l2:  src_h2,NVAR)
      double precision flux1(flux1_l1:flux1_h1,flux1_l2:flux1_h2,NVAR)
      double precision flux2(flux2_l1:flux2_h1,flux2_l2:flux2_h2,NVAR)
      double precision div(lo(1):hi(1)+1,lo(2):hi(2)+1)
      double precision dx(2), dt

      integer :: i, j, n
      integer :: ispec, iadv

      double precision div1
      double precision SrU, SrV
      double precision rho, Up, Vp, SrE

      ! Normalize the species fluxes
      if (normalize_species .eq. 1) &
         call normalize_species_fluxes( &
                  flux1,flux1_l1,flux1_l2,flux1_h1,flux1_h2, &
                  flux2,flux2_l1,flux2_l2,flux2_h1,flux2_h2, &
                  lo,hi)

      n = URHO
      do j = lo(2),hi(2)
         do i = lo(1),hi(1)
            uout(i,j,n) = uin(i,j,n) + dt * &
                   ( (flux1(i,j,n) - flux1(i+1,j,n)) / dx(1) &
                 +   (flux2(i,j,n) - flux2(i,j+1,n)) / dx(2) ) &
                 +   dt * src(i,j,n)
         enddo
      enddo

      do iadv = 1, nadv
         n = UFA + iadv - 1
         do j = lo(2),hi(2)
            do i = lo(1),hi(1)
               uout(i,j,n) = uin(i,j,n) + dt * &
                      ( (flux1(i,j,n) - flux1(i+1,j,n)) / dx(1) &
                    +   (flux2(i,j,n) - flux2(i,j+1,n)) / dx(2) ) &
                    +   dt * src(i,j,n)
            enddo
         enddo
      enddo

      do ispec = 1, nspec
         n = UFS + ispec -1
         do j = lo(2),hi(2)
            do i = lo(1),hi(1)
               uout(i,j,n) = uin(i,j,n) + dt * &
                      ( (flux1(i,j,n) - flux1(i+1,j,n)) / dx(1) &
                    +   (flux2(i,j,n) - flux2(i,j+1,n)) / dx(2) ) &
                    +   dt * src(i,j,n)
            enddo
         enddo
      enddo

      ! Scale by face area in order to correctly reflux
      do j = lo(2),hi(2)
      do i = lo(1),hi(1)+1
        flux1(i,j,1:NVAR) = dt * flux1(i,j,1:NVAR) * dx(2)
        flux1(i,j,UX:UY)  = 0.d0
      enddo
      enddo

      ! Scale by face area in order to correctly reflux
      do j = lo(2),hi(2)+1
      do i = lo(1),hi(1)
        flux2(i,j,1:NVAR) = dt * flux2(i,j,1:NVAR) * dx(1)
        flux2(i,j,UX:UY)  = 0.d0
      enddo
      enddo

      end subroutine consup

! :::
! ::: ------------------------------------------------------------------
! :::

      subroutine upwind(ql, qr, qpd_l1, qpd_l2, qpd_h1, qpd_h2, &
                        flx, flx_l1, flx_l2, flx_h1, flx_h2, &
                        ugd, ugd_l1, ugd_l2, ugd_h1, ugd_h2, &
                        idir, ilo1, ihi1, ilo2, ihi2)

      use network, only : nspec
      use prob_params_module, only : physbc_lo,physbc_hi,Symmetry
      use meth_params_module, only : QVAR, NVAR, QRHO, QFA, QFS, &
                                     URHO, UFA, UFS, nadv

      implicit none

      double precision, parameter:: small = 1.d-8

      integer qpd_l1, qpd_l2, qpd_h1, qpd_h2
      integer gd_l1, gd_l2, gd_h1, gd_h2
      integer flx_l1, flx_l2, flx_h1, flx_h2
      integer ugd_l1, ugd_l2, ugd_h1, ugd_h2
      integer idir, ilo1, ihi1, ilo2, ihi2
      integer ilo,ihi,jlo,jhi

      double precision ql(qpd_l1:qpd_h1,qpd_l2:qpd_h2,QVAR)
      double precision qr(qpd_l1:qpd_h1,qpd_l2:qpd_h2,QVAR)
      double precision flx(flx_l1:flx_h1,flx_l2:flx_h2,NVAR)
      double precision ugd(ugd_l1:ugd_h1,ugd_l2:ugd_h2)
      double precision ustar, qavg

      integer iadv, ispec, n, nq
      integer i, j

!************************************************************
!  set min/max based on normal direction
      if(idir.eq.1) then
         ilo = ilo1
         ihi = ihi1 + 1
         jlo = ilo2
         jhi = ihi2
      else
         ilo = ilo1
         ihi = ihi1
         jlo = ilo2
         jhi = ihi2+1
      endif

      do j = jlo, jhi
         do i = ilo, ihi

            ustar = ugd(i,j)

            ! Density
            if (ustar .gt. 0.d0) then
               flx(i,j,URHO) = ql(i,j,QRHO) * ugd(i,j)
            else if (ustar .lt. 0.d0) then
               flx(i,j,URHO) = qr(i,j,QRHO) * ugd(i,j)
            else
               qavg = 0.5d0 * (ql(i,j,QRHO) + qr(i,j,QRHO))
               flx(i,j,URHO) = qavg * ugd(i,j)
            endif

            do iadv = 1, nadv
               n = UFA + iadv - 1
               nq = QFA + iadv - 1
               if (ustar .gt. 0.d0) then
                  flx(i,j,n) = ql(i,j,nq)
               else if (ustar .lt. 0.d0) then
                  flx(i,j,n) = qr(i,j,nq)
               else
                  qavg = 0.5d0 * (ql(i,j,nq) + qr(i,j,nq))
                  flx(i,j,n) = qavg
               endif
               flx(i,j,n) = flx(i,j,URHO)*flx(i,j,n)
            enddo

            do ispec = 1, nspec
               n  = UFS + ispec - 1
               nq = QFS + ispec - 1
               if (ustar .gt. 0.d0) then
                  flx(i,j,n) = ql(i,j,nq)
               else if (ustar .lt. 0.d0) then
                  flx(i,j,n) = qr(i,j,nq)
               else
                  qavg = 0.5d0 * (ql(i,j,nq) + qr(i,j,nq))
                  flx(i,j,n) = qavg
               endif
               flx(i,j,n) = flx(i,j,URHO)*flx(i,j,n)
            enddo

         enddo
      enddo

      end subroutine upwind

! :::
! ::: ------------------------------------------------------------------
! :::

      subroutine transx(qm, qmo, qp, qpo, qd_l1, qd_l2, qd_h1, qd_h2, &
                        fx, fx_l1, fx_l2, fx_h1, fx_h2, &
                        srcQ, src_l1, src_l2, src_h1, src_h2, &
                        hdt, cdtdx,  &
                        ilo, ihi, jlo, jhi)

      use network, only : nspec
      use meth_params_module, only : QVAR, NVAR, QRHO, QU, QV, QFA, QFS, &
                                     URHO, UX, UY, UFA, UFS, nadv
      implicit none

      integer qd_l1, qd_l2, qd_h1, qd_h2
      integer gc_l1, gc_l2, gc_h1, gc_h2
      integer fx_l1, fx_l2, fx_h1, fx_h2
      integer src_l1, src_l2, src_h1, src_h2
      integer ilo, ihi, jlo, jhi

      double precision qm(qd_l1:qd_h1,qd_l2:qd_h2,QVAR)
      double precision qmo(qd_l1:qd_h1,qd_l2:qd_h2,QVAR)
      double precision qp(qd_l1:qd_h1,qd_l2:qd_h2,QVAR)
      double precision qpo(qd_l1:qd_h1,qd_l2:qd_h2,QVAR)
      double precision fx(fx_l1:fx_h1,fx_l2:fx_h2,NVAR)
      double precision srcQ(src_l1:src_h1,src_l2:src_h2,QVAR)
      double precision hdt, cdtdx

      integer i, j
      integer n, nq, iadv
      integer ispec
      double precision rr, rrnew, compo, compn

      ! Update density
      do j = jlo, jhi
          do i = ilo, ihi

              qpo(i,j  ,QRHO) = qp(i,j  ,QRHO) - hdt*(fx(i+1,j,URHO)-fx(i  ,j,URHO))
              qmo(i,j+1,QRHO) = qm(i,j+1,QRHO) - hdt*(fx(i+1,j,URHO)-fx(i  ,j,URHO))

          enddo
      enddo

      do iadv = 1, nadv
          n  = UFA + iadv - 1
          nq = QFA + iadv - 1
          do j = jlo, jhi
              do i = ilo, ihi

                  rr = qp(i,j,  QRHO)
                  rrnew = rr - hdt*(fx(i+1,j,URHO)-fx(i  ,j,URHO))

                  compo = rr*qp(i,j  ,nq)
                  compn = compo - hdt*(fx(i+1,j,n)-fx(i  ,j,n))

                  qpo(i,j  ,nq) = compn/rrnew + hdt*srcQ(i,j,nq)

                  rr = qm(i,j+1,QRHO)
                  rrnew = rr - hdt*(fx(i+1,j,URHO)-fx(i  ,j,URHO))

                  compo = rr*qm(i,j+1,nq)
                  compn = compo - hdt*(fx(i+1,j,n)-fx(i  ,j,n))

                  qmo(i,j+1,nq) = compn/rrnew + hdt*srcQ(i,j,nq)

              enddo
          enddo
      enddo

      do ispec = 1, nspec
          n  = UFS + ispec - 1
          nq = QFS + ispec - 1
          do j = jlo, jhi
              do i = ilo, ihi

                  rr = qp(i  ,j,QRHO)
                  rrnew = rr - hdt*(fx(i+1,j,URHO)-fx(i  ,j,URHO))

                  compo = rr*qp(i,j  ,nq)
                  compn = compo - hdt*(fx(i+1,j,n)-fx(i  ,j,n))

                  qpo(i,j  ,nq) = compn/rrnew + hdt*srcQ(i,j,nq)

                  rr = qm(i,j+1,QRHO)
                  rrnew = rr - hdt*(fx(i+1,j,URHO)-fx(i  ,j,URHO))

                  compo  = rr*qm(i,j+1,nq)
                  compn = compo - hdt*(fx(i+1,j,n)-fx(i  ,j,n))

                  qmo(i,j+1,nq) = compn/rrnew + hdt*srcQ(i,j,nq)

              enddo
          enddo
      enddo

      end subroutine transx

! :::
! ::: ------------------------------------------------------------------
! :::

      subroutine transy(qm, qmo, qp, qpo, qd_l1, qd_l2, qd_h1, qd_h2, &
                        fy,fy_l1,fy_l2,fy_h1,fy_h2, &
                        srcQ, src_l1, src_l2, src_h1, src_h2, &
                        hdt, cdtdy, ilo, ihi, jlo, jhi)

      use network, only : nspec
      use meth_params_module, only : QVAR, NVAR, QRHO, QU, QV, QFA, QFS, &
                                     URHO, UX, UY, UFA, UFS, nadv
      implicit none

      integer qd_l1, qd_l2, qd_h1, qd_h2
      integer gc_l1, gc_l2, gc_h1, gc_h2
      integer fy_l1, fy_l2, fy_h1, fy_h2
      integer src_l1, src_l2, src_h1, src_h2
      integer ilo, ihi, jlo, jhi

      double precision qm(qd_l1:qd_h1,qd_l2:qd_h2,QVAR)
      double precision qmo(qd_l1:qd_h1,qd_l2:qd_h2,QVAR)
      double precision qp(qd_l1:qd_h1,qd_l2:qd_h2,QVAR)
      double precision qpo(qd_l1:qd_h1,qd_l2:qd_h2,QVAR)
      double precision fy(fy_l1:fy_h1,fy_l2:fy_h2,NVAR)
      double precision srcQ(src_l1:src_h1,src_l2:src_h2,QVAR)
      double precision hdt, cdtdy

      integer i, j
      integer n, nq, iadv, ispec

      double precision rr,rrnew,compo,compn

      ! Update density -- this assumes no sources for density
      do j = jlo, jhi
          do i = ilo, ihi

              qpo(i  ,j,QRHO) = qp(i  ,j,QRHO) - hdt*(fy(i,j+1,URHO)-fy(i,j  ,URHO))
              qmo(i+1,j,QRHO) = qm(i+1,j,QRHO) - hdt*(fy(i,j+1,URHO)-fy(i,j  ,URHO))

          enddo
      enddo

      do iadv = 1, nadv
          n  = UFA + iadv - 1
          nq = QFA + iadv - 1
          do j = jlo, jhi
              do i = ilo, ihi

                  rr = qp(i,j,QRHO)
                  rrnew = rr - cdtdy*(fy(i,j+1,URHO)-fy(i,j,URHO))

                  compo = rr*qp(i,j,nq)
                  compn = compo - cdtdy*(fy(i,j+1,n)-fy(i,j,n))

                  qpo(i,j,nq) = compn/rrnew + hdt*srcQ(i,j,nq)

                  rr = qm(i+1,j,QRHO)
                  rrnew = rr - cdtdy*(fy(i,j+1,URHO)-fy(i,j,URHO))

                  compo = rr*qm(i+1,j,nq)
                  compn = compo - cdtdy*(fy(i,j+1,n)-fy(i,j,n))

                  qmo(i+1,j,nq) = compn/rrnew + hdt*srcQ(i,j,nq)

              enddo
          enddo
      enddo

      do ispec = 1, nspec
          n  = UFS + ispec - 1
          nq = QFS + ispec - 1
          do j = jlo, jhi
              do i = ilo, ihi

                  rr = qp(i,j,QRHO)
                  rrnew = rr - cdtdy*(fy(i,j+1,URHO)-fy(i,j,URHO))

                  compo = rr*qp(i,j,nq)
                  compn = compo - cdtdy*(fy(i,j+1,n)-fy(i,j,n))

                  qpo(i,j,nq) = compn/rrnew + hdt*srcQ(i,j,nq)

                  rr = qm(i+1,j,QRHO)
                  rrnew = rr - cdtdy*(fy(i,j+1,URHO)-fy(i,j,URHO))

                  compo = rr*qm(i+1,j,nq)
                  compn = compo - cdtdy*(fy(i,j+1,n)-fy(i,j,n))

                  qmo(i+1,j,nq) = compn/rrnew + hdt*srcQ(i,j,nq)

              enddo
          enddo
      enddo

      end subroutine transy

! :::
! ::: ------------------------------------------------------------------
! :::

      subroutine uslope(q,qd_l1,qd_l2,qd_h1,qd_h2, &
                        dq,qpd_l1,qpd_l2,qpd_h1,qpd_h2, &
                        ilo1,ilo2,ihi1,ihi2,nv,idir)

      implicit none

      integer ilo,ihi
      integer qd_l1,qd_l2,qd_h1,qd_h2
      integer qpd_l1,qpd_l2,qpd_h1,qpd_h2
      integer ilo1,ilo2,ihi1,ihi2,nv,idir

      double precision     q( qd_l1: qd_h1, qd_l2: qd_h2,nv)
      double precision    dq(qpd_l1:qpd_h1,qpd_l2:qpd_h2,nv)

!     Local arrays
      double precision, allocatable::dsgn(:),dlim(:),df(:),dcen(:)

      integer i, j, n
      double precision dlft, drgt, slop, dq1
      double precision four3rd, sixth

      four3rd = 4.d0/3.d0
      sixth = 1.d0/6.d0

      ilo = MIN(ilo1,ilo2)
      ihi = MAX(ihi1,ihi2)

      allocate (dsgn(ilo-2:ihi+2))
      allocate (dlim(ilo-2:ihi+2))
      allocate (  df(ilo-2:ihi+2))
      allocate (dcen(ilo-2:ihi+2))

      do n = 1, nv
          if (idir .eq. 1) then

             ! slopes in first coordinate direction
             do j = ilo2-1, ihi2+1

                ! first compute Fromm slopes
                do i = ilo1-2, ihi1+2
                      dlft = 2.d0*(q(i  ,j,n) - q(i-1,j,n))
                      drgt = 2.d0*(q(i+1,j,n) - q(i  ,j,n))
                      dcen(i) = .25d0 * (dlft+drgt)
                      dsgn(i) = sign(1.d0, dcen(i))
                      slop = min( abs(dlft), abs(drgt) )
!                      dlim(i) = cvmgp( slop, 0.d0, dlft*drgt )
                      if (dlft*drgt .ge. 0.d0) then
                         dlim(i) = slop
                      else
                         dlim(i) = 0.d0
                      endif
                      df(i) = dsgn(i)*min( dlim(i), abs(dcen(i)) )
                  enddo

!                 Now limited fourth order slopes
                  do i = ilo1-1, ihi1+1
                      dq1 = four3rd*dcen(i) - sixth*(df(i+1) + df(i-1))
                      dq(i,j,n) = dsgn(i)*min(dlim(i),abs(dq1))
                  enddo
              enddo

          else

!            Compute slopes in second coordinate direction
             do i = ilo1-1, ihi1+1

!               First compute Fromm slopes for this column
                do j = ilo2-2, ihi2+2
                      dlft = 2.d0*(q(i,j  ,n) - q(i,j-1,n))
                      drgt = 2.d0*(q(i,j+1,n) - q(i,j  ,n))
                      dcen(j) = .25d0 * (dlft+drgt)
                      dsgn(j) = sign( 1.d0, dcen(j) )
                      slop = min( abs(dlft), abs(drgt) )
                      if (dlft*drgt .ge. 0.d0) then
                         dlim(j) = slop
                      else
                         dlim(j) = 0.d0
                      endif
                      df(j) = dsgn(j)*min( dlim(j),abs(dcen(j)) )
                  enddo

!                 Now compute limited fourth order slopes
                  do j = ilo2-1, ihi2+1
                      dq1 = four3rd*dcen(j) - &
                           sixth*( df(j+1) + df(j-1) )
                      dq(i,j,n) = dsgn(j)*min(dlim(j),abs(dq1))
                  enddo
              enddo

          endif
      enddo

      deallocate(dsgn,dlim,df,dcen)

      end subroutine uslope

! :::
! ::: ------------------------------------------------------------------
! :::

      subroutine divu(lo,hi,q,q_l1,q_l2,q_h1,q_h2,dx, &
                      div,div_l1,div_l2,div_h1,div_h2)

      use prob_params_module, only : coord_type
      use meth_params_module, only : QU, QV

      implicit none

      integer          :: lo(2),hi(2)
      integer          :: q_l1,q_l2,q_h1,q_h2
      integer          :: div_l1,div_l2,div_h1,div_h2
      double precision :: q(q_l1:q_h1,q_l2:q_h2,*)
      double precision :: div(div_l1:div_h1,div_l2:div_h2)
      double precision :: dx(2)

      integer          :: i, j
      double precision :: rl, rr, rc, ul, ur
      double precision :: vb, vt
      double precision :: ux,vy

      do j=lo(2),hi(2)+1
      do i=lo(1),hi(1)+1
         ux = 0.5d0*(q(i,j,QU)-q(i-1,j,QU)+q(i,j-1,QU)-q(i-1,j-1,QU))/dx(1)
         vy = 0.5d0*(q(i,j,QV)-q(i,j-1,QV)+q(i-1,j,QV)-q(i-1,j-1,QV))/dx(2)
         div(i,j) = ux + vy
      enddo
      enddo

      end subroutine divu


module meshgrid_mod
    implicit none

    public :: meshgrid

contains

    subroutine meshgrid(x_vals, y_vals, X, Y)
        use, intrinsic :: iso_fortran_env, only : error_unit, DP => REAL64
        implicit none
        real(kind=DP), dimension(:), intent(in) :: x_vals, y_vals
        real(kind=DP), dimension(:, :), allocatable, intent(out) :: X, Y
        integer :: status, i

        ! allocate new arrays
        allocate (X(size(y_vals), size(x_vals)), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(A)') 'error: can not allocate array'
            stop 1
        end if
        allocate (Y(size(y_vals), size(x_vals)), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(A)') 'error: can not allocate array'
            stop 1
        end if

        do i = 1, size(y_vals)
            X(i, :) = x_vals
        end do
        do i = 1, size(x_vals)
            Y(:, i) = y_vals
        end do
    end subroutine meshgrid

end module meshgrid_mod


      subroutine phiprod (n, m, eps, tn, u, w, r, x, y, a, ioff, ndiag)
      real*8 eps, tn
      real*8 a(n,ndiag), u(n,m+1), w(n), r(n), x(n), y(n)
      integer n, m, ndiag, ioff(ndiag)

c-----------------------------------------------------------------------
c this subroutine computes an approximation to the vector
c
c   	w(tn) = w(t0) + tn *  phi( - A * tn ) * (r - A w(t0))
c
c where phi(z) = (1-exp(z)) / z
c
c i.e. solves   dw/dt = - A w + r in [t0,t0+ tn] (returns only w(t0+tn))
c
c for matrices stored in diagonal (DIA) format.
c
c this routine constitutes an interface for the routine phipro for
c matrices stored in diagonal (DIA) format. The phipro routine uses
c reverse communication and as a result does not depend on any
c data structure of the matrix.

c-----------------------------------------------------------------------
c ARGUMENTS
c----------
c see phipro for meaning of parameters n, m, eps, tn, u, w, x, y.
c
c a, ioff, and ndiag are the arguments of the matrix:
c
c a(n,ndiag) = a rectangular array with a(*,k) containing the diagonal
c              offset by ioff(k) (negative or positive or zero), i.e.,
c              a(i,jdiag) contains the element A(i,i+ioff(jdiag)) in
c              the usual dense storage scheme.
c
c ioff	     = integer array containing the offsets  of the ndiag diagonals
c ndiag      = integer. the number of diagonals.
c
c-----------------------------------------------------------------------
c local variables
c
      integer indic, ierr

      indic = 0
 101  continue
      call phipro (n, m, eps, tn, w, r, u, x, y, indic, ierr)
      if (indic .eq. 1) goto 102
c
c     matrix vector-product for diagonal storage --
c
      call oped(n, x, y, a, ioff, ndiag)
      goto 101
 102  continue
      return
      end
c----------end-of-phiprod-----------------------------------------------
c-----------------------------------------------------------------------
      subroutine phipro (n, m, eps, tn, w, r, u, x, y, indic, ierr)
c     implicit  real*8 (a-h,o-z)
      integer n, m, indic, ierr
      real*8 eps, tn, w(n), r(n), u(n,m+1), x(n), y(n)
c-----------------------------------------------------------------------
c
c this subroutine computes an approximation to the vector
c
c     w(tn) = w(t0) + tn *  phi( - A * tn ) * (r - A w(t0))
c     where phi(z) = (1-exp(z)) / z
c
c     i.e. solves dw/dt=-Aw+r in [t0,t0+tn] (returns w(t0+tn))
c     t0 need not be known.
c
c note that for w(t0)=0 the answer is    w=tn *phi(-tn * A) r
c in other words this allows to compute phi(A tn) v.
c This code will work well only for cases where eigenvalues are
c real (or nearly real) and positive. It has also been coded to
c work for cases where tn .lt. 0.0 (and A has real negative spectrum)
c
c-----------------------------------------------------------------------
c
c THIS IS A REVERSE COMMUNICATION IMPLEMENTATION.
c-------------------------------------------------
c USAGE: (see also comments on argument indic below).
c------
c
c      indic = 0
c 1    continue
c      call phipro (n, m, eps, tn, u, w, x, y, indic)
c      if (indic .eq. 1) goto 2 <-- indic .eq. 1 means phipro has finished
c      call matvec(n, x, y)     <--- user's matrix-vec. product
c                                    with x = input vector, and
c                                     y = result = A * x.
c      goto 1
c 2    continue
c      .....
c
c-----------------------------------------------------------------------
c
c en entry:
c----------
c n	= dimension of matrix
c
c m	= dimension of Krylov subspace (= degree of polynomial
c         approximation to the exponential used. )
c
c eps   = scalar indicating the relative error tolerated for the result.
c         the code will try to compute an answer such that
c         norm2(exactanswer-approximation) / norm2(w) .le. eps
c
c tn	= scalar by which to multiply matrix. (may be .lt. 0)
c         the code will compute a solution to dw/dt = -A w + r,
c         and overwrite the result w(tn) onto in w.
c
c w	= real array of length n. Initial condition for the ODE system
c         on input, result w(tn) on output (input and output argument)
c
c r     = real array of length n. the constant term in the system
c         dw/dt = -A w + r to be solved.
c
c u	= work array of size n*(m+1) (used to hold the Arnoldi basis )
c
c x, y  = two real work vectors of length n each. x and y are used to
c         carry the input and output vectors for the matrix-vector
c         products y=Ax in the reverse communication protocole.
c         see argument indic (return) below for details on their usage.
c
c indic = integer used as indicator for the reverse communication.
c         in the first call enter indic = 0.
c
c ierr  = error indicator.
c         ierr = 1 means phipro was called with indic=1 (not allowed)
c         ierr = -1 means that the input is zero the solution has been
c         unchanged.
c
c on return:
c-----------
c
c w     = contains the result w(tn)=w(t0)+tn*phi(-A*tn)*(r-Aw(t0))
c         when phipro has finished (as indicated by indic see below)
c
c indic = indicator for the reverse communication protocole.
c       * INDIC .eq. 1  means that phipro has finished and w contains the
c         result.
c       * INDIC .gt. 1 means that phipro has not finished and that
c         it is requesting another matrix vector product before
c         continuing. The user must compute Ax where A is the matrix
c         and x is the vector provided by phipro and return the
c         result in y. Then phipro must be called again without
c         changing any other argument. typically this is best
c         implemented in a loop with phipro being called as long
c         indic is returned with a value .ne. 1.
c
c NOTES:  m should not exceed 60 in this version  (see mmax below)
c-----------------------------------------------------------------------
c local variables
c
      integer mmax
      parameter (mmax=60)
      real*8 errst, tcur, told, dtl, beta, red, dabs, dble
      real*8 hh(mmax+2,mmax+1), z(mmax+1)
      complex*16   wkc(mmax+1)
      integer ih, k, job
      logical verboz
      data verboz/.true./
      save
c-----------------------------------------------------------------------
c indic = 4  means  getting y=Ax needed in phipro
c indic = 3  means  passing through only with result of y= Ax to phihes
c indic = 2  means phihes has finished its job
c indic = 1  means phipro has finished its job (real end)/
c-----------------------------------------------------------------------
      ierr = 0
      if (indic .eq. 3) goto 101
      if (indic .eq. 4) goto 11
      if (indic .eq. 1) then
         ierr = 1
         return
      endif
c-----
      ih = mmax
      m  = min0(m,mmax)
      tcur = 0.0d0
      dtl = tn - tcur
      job = -1
c-------------------- outer loop -----------------------------
 100  continue
      if(verboz) print *,'In PHIPRO, current time = ', tcur ,'---------'
c-------------------------------------------------------------
c ---- call phionential propagator ---------------------------
c-------------------------------------------------------------
      told = tcur
c
c     if (told + dtl .gt. tn) dtl = tn-told
c      construct initial vector for Arnoldi:  r - A w(old)
c
      do 10 k=1, n
         x(k) = w(k)
 10   continue
      indic = 4
      return
 11   continue
      do 12 k=1, n
         u(k,1) = r(k) - y(k)
 12   continue
c
 101  continue
      call phihes (n,m,dtl,eps,u,job,z,wkc,beta,errst,hh,ih,x, y,indic,
     *            ierr)
c-----------------------------------------------------------------------
      if (ierr .ne. 0) return
      if (indic .eq. 3) return
      tcur = told + dtl
      if(verboz) print *, ' tcur now = ', tcur, ' dtl = ', dtl
c
c     relative error
c      if(verboz) print *, ' beta', beta
      errst = errst / beta
c---------
      if ((errst .le. eps) .and. ( (errst .gt. eps/100.0) .or.
     *     (tcur .eq. tn))) goto 102
c
c     use approximation :  [ new err ] = fact**m  * [cur. error]
c
      red =  (0.5*eps / errst)**(1.0d0 /dble(m) )
      dtl = dtl*red
      if (dabs(told+dtl) .gt. dabs(tn) )  dtl = tn-told
      if(verboz) print *, ' red =',red,' , reducing dt to: ', dtl
c-------
      job = 1
      goto 101
c-------
 102  continue
c
      call project(n, m, w, dtl, u, z)
c never go beyond tcur
      job = 0
      dtl = dmin1(dtl, tn-tcur)
      if (dabs(tcur+dtl) .gt. dabs(tn)) dtl = tn-tcur
      if (dabs(tcur) .lt. dabs(tn)) goto 100
      indic = 1
      return
      end
c----------end-of-phipro------------------------------------------------
c-----------------------------------------------------------------------
      subroutine phihes (n,m,dt,eps,u,job,z,wkc,beta,errst,hh,ih,
     *                   x, y, indic,ierr)
c     implicit  real*8 (a-h,o-z)
      integer n, m, job, ih, indic, ierr
      real*8 hh(ih+2,m+1), u(n,m+1), z(m+1), x(n), y(n)
      complex*16 wkc(m+1)
      real*8 dt, eps, beta, errst
c-----------------------------------------------------------------------
c this subroutine computes the Arnoldi basis Vm and the corresponding
c coeffcient vector ym in the approximation
c
c        	w  ::= beta  Vm  ym
c               where ym = phi(- Hm * dt) * e1
c
c to the vector phi(-A * dt) w where A is an arbitary matrix and
c w is a given input vector. The phi function is defined   by
c               phi(z) = (1 - exp(z) ) / z
c
c In case job .lt.0 the arnoldi basis is recomputed. Otherwise the
c code assumes assumes that  u(*) contains an already computed
c arnoldi basis and computes only the y-vector (which is stored in
c v(*)). Three different options are available through the argument job.
c-----------------------------------------------------------------------
c on entry:
c----------
c n	= dimension of matrix
c
c m	= dimension of Krylov subspace (= degree of polynomial
c         approximation to the phionential used. )
c
c dt	= scalar by which to multiply matrix. Can be viewed
c         as a time step. dt must be positive [to be fixed].
c
c eps   = scalar indicating the relative error tolerated for the result.
c         the code will try to compute an answer such that
c         norm2(exactanswer-approximation) / norm2(w) .le. eps
c
c u	= work array of size n*(m+1) to contain the Arnoldi basis
c
c w	= real array of length n = input vector to  which phi(-A) is
c         to be applied.
c
c job	= integer. job indicator. If job .lt.  0 then the Arnoldi
c         basis is recomputed. If job .gt. 0 then it is assumed
c         that the user wants to use a previously computed Krylov
c         subspace but a different dt. Thus the Arnoldi basis and
c         the Hessenberg matrix Hm are not recomputed.
c	  In that case the user should not modify the values of beta
c         and the matrices hh and u(n,*) when recalling phipro.
c         job = -1 : recompute basis and get an initial estimate for
c                    time step dt to be used.
c         job = 0  : recompute basis and do not alter dt.
c         job = 1  : do not recompute arnoldi basis.
c
c z     = real work array of  size (m+1)
c wkc   = complex*16 work array of size (m+1)
c
c hh    = work array of size size at least (m+2)*(m+1)
c
c ih+2	= first dimension of hh as declared in the calling program.
c         ih must be .ge. m.
c
c-----------------------------------------------------------------------
c on return:
c-----------
c w2	= resulting vector w2 = phi(-A *dt) * w
c beta  = real equal to the 2-norm of w. Needed if phipro will
c         be recalled with the same Krylov subspace and a different dt.
c errst = rough estimates of the 2-norm of the error.
c hh	= work array of dimension at least (m+2) x (m+1)
c
c-----------------------------------------------------------------------
c local variables
c
      integer ndmax
      parameter (ndmax=20)
      real*8 alp0, fnorm, t, rm, ddot, dabs, dsqrt, dsign,dble
      complex*16 alp(ndmax+1), rd(ndmax+1)
      integer i, j, k, ldg, i0, i1, m1
      logical verboz
      data verboz/.true./
      save
c------use degree 14 chebyshev all the time --------------------------
      if (indic .eq. 3) goto 60
c
c------get partial fraction expansion of rational function -----------
c-----------------------------------------------------------------------
c chebyshev (14,14)
c      ldg= 7
c      alp0 =  0.183216998528140087E-11
c      alp(1)=( 0.557503973136501826E+02,-0.204295038779771857E+03)
c      rd(1)=(-0.562314417475317895E+01, 0.119406921611247440E+01)
c      alp(2)=(-0.938666838877006739E+02, 0.912874896775456363E+02)
c      rd(2)=(-0.508934679728216110E+01, 0.358882439228376881E+01)
c      alp(3)=( 0.469965415550370835E+02,-0.116167609985818103E+02)
c      rd(3)=(-0.399337136365302569E+01, 0.600483209099604664E+01)
c      alp(4)=(-0.961424200626061065E+01,-0.264195613880262669E+01)
c      rd(4)=(-0.226978543095856366E+01, 0.846173881758693369E+01)
c      alp(5)=( 0.752722063978321642E+00, 0.670367365566377770E+00)
c      rd(5)=( 0.208756929753827868E+00, 0.109912615662209418E+02)
c      alp(6)=(-0.188781253158648576E-01,-0.343696176445802414E-01)
c      rd(6)=( 0.370327340957595652E+01, 0.136563731924991884E+02)
c      alp(7)=( 0.143086431411801849E-03, 0.287221133228814096E-03)
c      rd(7)=( 0.889777151877331107E+01, 0.166309842834712071E+02)
c-----------------------------------------------------------------------
c Pade of  degree =  (4,4)
c
c        ldg= 2
c        alp(1)=(-0.132639894655051648E+03,-0.346517448171383875E+03)
c        rd(1)=(-0.579242120564063611E+01, 0.173446825786912484E+01)
c        alp(2)=( 0.926398946550511936E+02, 0.337809095284865179E+02)
c        rd(2)=(-0.420757879435933546E+01, 0.531483608371348736E+01)
c
c Pade of degree =  8
c
        ldg= 4
        alp(1)=( 0.293453004361944040E+05, 0.261671093076405813E+05)
        rd(1)=(-0.104096815812822569E+02, 0.523235030527069966E+01)
        alp(2)=(-0.212876889060526154E+05,-0.764943398790569044E+05)
        rd(2)=(-0.111757720865218743E+02, 0.173522889073929320E+01)
        alp(3)=(-0.853199767523084301E+04,-0.439758928252937039E+03)
        rd(3)=(-0.873657843439934822E+01, 0.882888500094418304E+01)
        alp(4)=( 0.330386145089576530E+03,-0.438315990671386316E+03)
        rd(4)=(-0.567796789779646360E+01, 0.127078225972105656E+02)
c
      do 102 k=1, ldg
         alp(k) = - alp(k) / rd(k)
 102  continue
      alp0 = 0.0d0
c
c     if job .gt. 0 skip arnoldi process:
c
      if (job .gt. 0) goto 2
c------normalize vector u and put in first column of u --
      beta = dsqrt(ddot(n,u,1,u,1))
c-----------------------------------------------------------------------
      if(verboz) print *, ' In PHIHES, beta ', beta
      if (beta .eq. 0.0d0) then
         ierr = -1
         indic = 1
         return
      endif
c
      t = 1.0d0/beta
      do 25 j=1, n
         u(j,1) = u(j,1)*t
 25   continue
c------------------Arnoldi loop -----------------------------------------
c      fnorm = 0.0d0
      i1 = 1
 58   i = i1
      i1 = i + 1
      do 59 k=1, n
         x(k) = u(k,i)
 59   continue
      indic = 3
      return
 60   continue
      do 61 k=1, n
         u(k,i1) = y(k)
 61   continue
      i0 =1
c switch  for Lanczos version
c     i0 = max0(1, i-1)
      call mgsr (n, i0, i1, u, hh(1,i))
      fnorm = fnorm + ddot(i1, hh(1,i),1, hh(1,i),1)
      if (hh(i1,i) .eq. 0.0) m = i
      if  (i .lt. m) goto 58
c--------------done with arnoldi loop ---------------------------------
      rm = dble(m)
      fnorm = dsqrt( fnorm / rm )
c------- put beta*e1 into z -------------------------------------------
      m1 = m+1
      do 4 i=1,m1
         hh(i,m1) = 0.0
 4    continue
c
c     compute initial dt when  job .lt. 1
c
      if (job .ge. 0) goto 2
c
      t = 2.0*eps
      do 41 k=1, m
         t = 2.0*t*dble(k+1)/rm
 41   continue
c
      t = rm* (t**(1.0d0/rm) ) / fnorm
      if(verboz) print *, ' t, dt = ', t, dt
      t = dmin1(dabs(dt),t)
      dt = dsign(t, dt)
c---------------------- get the vector phi(Hm)e_1 + estimate -----------
 2    continue
      z(1) = beta
      do 3 k=2, m1
         z(k) = 0.0d0
 3    continue
c-------get  : phi(H) * beta*e1
      call hes(ldg,m1,hh,ih,dt,z,rd,alp,alp0,wkc)
c-------error estimate
      errst = dabs(z(m1))
      if(verboz) print *, ' error estimate =', errst
c-----------------------------------------------------------------------
      indic = 2
      return
      end
c-----------------------------------------------------------------------
      subroutine mgsr (n, i0, i1, ss, r)
c     implicit  real*8 (a-h,o-z)
      integer n, i0, i1
      real*8 ss(n,i1), r(i1)
c-----------------------------------------------------------------------
c modified gram - schmidt  with  partial  reortho. the vector ss(*,i1) is
c orthogonalized against the first i vectors  of ss  (which  are  already
c orthogonal).  the coefficients of the orthogonalization are returned in
c the array r
c------------------------------------------------------------------------
c local variables
c
      integer i, j, k, it
      real*8 hinorm, tet, ddot, t, dsqrt
      data  tet/10.0d0/

      do 53 j=1, i1
         r(j) = 0.0d0
 53   continue
      i = i1-1
      it = 0
 54   hinorm = 0.0d0
      it = it +1
      if (i .eq. 0) goto 56
c
      do 55 j=i0, i
         t = ddot(n, ss(1,j),1,ss(1,i1),1)
         hinorm = hinorm + t**2
         r(j) = r(j) + t
         call daxpy(n,-t,ss(1,j),1,ss(1,i1),1)
 55   continue
      t = ddot(n, ss(1,i1), 1, ss(1,i1), 1)
 56   continue
c
c     test for reorthogonalization see daniel et. al.
c     two reorthogonalization allowed ---
c
      if (t*tet .le. hinorm .and. it .lt. 2) goto 54
      t =dsqrt(t)
      r(i1)= t
      if (t .eq. 0.0d0) return
      t = 1.0d0/t
      do 57  k=1,n
         ss(k,i1) = ss(k,i1)*t
 57   continue
      return
      end
c----------end-of-mgsr--------------------------------------------------
c-----------------------------------------------------------------------
      subroutine project(n, m, w, t, u, v)
      integer n, m
      real*8 u(n,m), v(m), w(n), t, scal
c
c     computes the vector w = w + t * u * v
c
c local variables
c
      integer j, k

      do 100 j=1,m
         scal = t*v(j)
         do 99 k=1,n
            w(k) = w(k) + scal*u(k,j)
 99      continue
 100  continue
      return
      end
c-----------------------------------------------------------------------
      subroutine hes (ndg,m1,hh,ih,dt,y,root,coef,coef0,w2)
c     implicit  real*8 (a-h,o-z)
      integer ndg, m1, ih
      real*8 hh(ih+2,m1), y(m1)
      complex*16   coef(ndg), root(ndg), w2(m1)
      real*8 dt, coef0
c--------------------------------------------------------------------
c computes phi ( H dt) * y    (1)
c where H = Hessenberg matrix (hh)
c y	  = arbitrary vector.
c ----------------------------
c ndg	= number of poles as determined by getrat
c m1    = dimension of hessenberg matrix
c hh	= hessenberg matrix (real)
c ih+2	= first dimension of hh
c dt	= scaling factor used for hh (see (1))
c y	= real vector. on return phi(H dt ) y is computed
c         and overwritten on y.
c root  = poles of the rational approximation to phi as
c         computed by getrat
c coef,
c coef0 = coefficients of partial fraction phiansion
c
c  phi(t) ~ coef0 +  sum     Real [   coef(i) / (t - root(i)  ]
c                  i=1,ndg
c
c valid for real t.
c coef0 is real, coef(*) is a complex array.
c
c--------------------------------------------------------------------
c local variables
c
      integer m1max
      parameter (m1max=70)
      complex*16   hloc(m1max+1,m1max), t, zpiv, dcmplx
      real*8 yloc(m1max), dble
      integer i, j, ii
c
c      if (m1 .gt. m1max) print *, ' *** ERROR : In HES, M+1 TOO LARGE'
c
c     loop associated with the poles.
c
      do 10 j=1,m1
         yloc(j) = y(j)
         y(j)    = y(j)*coef0
 10   continue
c
      do 8 ii = 1, ndg
c
c     copy Hessenberg matrix into temporary
c
         do 2 j=1, m1
            do 1 i=1, j+1
               hloc(i,j) = dcmplx( dt*hh(i,j) )
 1          continue
            hloc(j,j) = hloc(j,j) - root(ii)
            w2(j)     = dcmplx(yloc(j))
 2       continue
c
c forward solve
c
         do 4 i=2,m1
            zpiv  = hloc(i,i-1) / hloc(i-1,i-1)
            do 3 j=i,m1
               hloc(i,j) = hloc(i,j) - zpiv*hloc(i-1,j)
 3          continue
            w2(i)     = w2(i) - zpiv*w2(i-1)
 4       continue
c
c     backward solve
c
         do 6 i=m1,1,-1
            t=w2(i)
            do 5 j=i+1,m1
               t = t-hloc(i,j)*w2(j)
 5          continue
            w2(i) = t/hloc(i,i)
 6       continue
c
c     accumulate result in y.
c
         do 7 i=1,m1
            y(i) = y(i) + dble ( coef(ii) * w2(i) )
 7       continue
 8    continue
      return
      end
c----------end-of-hes---------------------------------------------------
c-----------------------------------------------------------------------
      subroutine daxpy(n,t,x,indx,y,indy)
      integer n, indx, indy
      real*8 x(n), y(n), t
c-------------------------------------------------------------------
c does the following operation
c y <--- y + t * x ,   (replace by the blas routine daxpy )
c indx and indy are supposed to be one here
c-------------------------------------------------------------------
       integer k

       do 1 k=1,n
          y(k) = y(k) + x(k)*t
1      continue
       return
       end
c----------end-of-daxpy-------------------------------------------------
c-----------------------------------------------------------------------
       function ddot(n,x,ix,y,iy)
       integer n, ix, iy
       real*8 ddot, x(n), y(n)
c-------------------------------------------------------------------
c computes the inner product t=(x,y) -- replace by blas routine ddot
c-------------------------------------------------------------------
       integer j
       real*8 t

       t = 0.0d0
       do 10 j=1,n
          t = t + x(j)*y(j)
10     continue
       ddot=t
       return
       end
c----------end-of-ddot--------------------------------------------------
c-----------------------------------------------------------------------


      subroutine n1gc2a(simul,prosca,n,x,f,g,dx,df1,eps,imp,io,
     /                  niter,nsim,info,memh,d,xx,gg,tabaux,h,
     /                  izs,rzs,dzs)
      implicit double precision (a-h,o-z)
c

c
c parametres
      double precision  zero     , un     , deux     , ro
      parameter  (  zero=0.0d+0, un=1.0d+0, deux=2.0d+0, ro=0.20d+0 )
c declaration des tableaux
      double precision    x(n),g(n),d(n),xx(n),gg(n),tabaux(n),h(*),
     /                    dzs(*)
      real rzs(*)
      integer  izs(*)
c declaration des scalaires
      double precision  f, dx, eps, df1
      double precision   dg1, dg, alpha, normg0, aux1, aux2, mu, eta,
     / omega, normg, gcarre, ggcarr, nu, sigma, sscalg, uscalg,
     / sscaek
      integer  n, memh, imp, io, nsim, niter, info
      integer  memuti, nrzuti, memsup, m, retour, iter,
     /   ntotap, nmisaj, i, iu, is, ieta, inu, j, kj, k, kp1
      logical  gc, iterqn, intfor, redfor, redem, termi
c
      external  simul, prosca
c
c  *************************************************************
c  phase i:determination de la methode ( et de m le cas echeant)
c  *************************************************************
c
      memuti=n*(n+1)/2
c
c memsup est aussi la dimension minimale de la matrice h
      memsup=2*n+2
c
      if (memh .ge. memuti) then
      gc=.false.
      nrzuti=memuti+4*n
      if (imp .gt. 1) write(io,1) nrzuti
      else if (memh .lt. memsup) then
      info=3
      return
      else
      gc=.true.
c m est le nombre de mises a jour admissible
      m=memh / memsup
c memuti est ici le nombre de places memoire utilisees pour stocker h
      memuti=m * memsup
      nrzuti=memuti+4*n
      if (imp .gt. 1) write(io,2) m,nrzuti
      endif
1     format(40h     methode de quasi-newton. nrz utile=,i7)
2     format(38h     methode du gradient conjugue avec,i3,
     / 14h mises a jour.,11h nrz utile=,i7)
c
c  ***********************************************
c  phase ii:initialisations propres a l'optimiseur
c  ***********************************************
c
c initialisation des compteurs
      iter=0
      ntotap=1
c
c  ******************************************************************
c  phase iii:demarrage a partir de x(0) avec descente suivant -(grad)
c  ******************************************************************
c
3000  i=0
      nmisaj=0
c
c calcul de la direction de descente
      do 3100 j=1,n
      d(j)=-g(j)
3100  continue
c
      call prosca(n,g,d,dg1,izs,rzs,dzs)
      normg0=sqrt(abs(dg1))
      if (iter .eq. 1) then
      omega=eps * normg0
      endif
c
c ************************************************************
c phase iv:debut de l'iteration x(i-1) donne x(i) le long de d
c ************************************************************
c
4000  if (iter .eq. niter) then
      info=4
      goto 99999
      endif
      iter=iter + 1
      i=i+1
c
c determination du type de pas
      if (gc) then
      iterqn=(i .le. m) .and. (2 .le. i)
      endif
c
c  *******************************
c  phase v:initialisation de alpha
c  *******************************
c
      if (iter .eq. 2) then
      alpha=deux * df1 /(-dg1)
      else if (gc) then
                   if (i.eq.1) then
                   alpha=un / normg0
                   else
                            if (iterqn) then
                            alpha=un
                            else
                            alpha=alpha * dg / dg1
                            endif
                   endif
      else
      alpha=un
      endif
c
c ***************************
c phase vi:recherche lineaire
c ***************************
c
      dg=dg1
      intfor=( gc .and. (.not.iterqn)).or. ((.not.gc) .and.(i.eq.1))
      do 6000 j=1,n
      xx(j)=x(j)
      gg(j)=g(j)
6000  continue
      call n1gc2b(n,simul,prosca,xx,f,dg,alpha,d,x,g,imp,io,retour,
     /           ntotap,nsim,intfor,dx,eps,izs,rzs,dzs)
c
      if (imp .gt. 3) write(io,6003)
      if ((retour .eq. 4).or.((retour .eq. 1).and.(i .eq. 1))) then
      info=6
      return
      else if (retour .eq. 1) then
      if (imp .gt. 1) write(io,6002) iter,ntotap
      goto 3000
      else
c calcul de (g,g)
      if((i .gt. 1) .and. gc) ggcarr=gcarre
      call prosca(n,g,g,gcarre,izs,rzs,dzs)
      normg=sqrt(gcarre)
      if (imp .gt. 2) write(io,6001)iter,ntotap,f
      if (retour .eq. 2) then
      info=0
      goto 99999
      else if (retour .eq. 3)then
      info=5
      goto 99999
      endif
      endif
6001  format(4x,6h n1gc2,3x,i4,6h iters,3x,i4,7h simuls,3x,2hf=,d15.9)
6002  format(4x,6h n1gc2,3x,i4,6h iters,3x,i4,7h simuls,
     / 33h necessite d'un redemarrage total)
6003  format()
c
c  ******************************************************
c  phase vii:test d'arret par obtention de la convergence
c  ******************************************************
c
      termi=normg .lt. omega
      if (termi) then
      info=1
      goto 99999
      else
      continue
      endif
c
c *******************************************
c  phase viii:test x(i) point de redemarrage?
c *******************************************
c
c doit on forcer un redemarrage?
      redfor=gc .and. ((i .eq. 1) .or. (i .eq. m+n))
      if (redfor) then
      redem=.true.
      else if (gc .and. .not. iterqn) then
      call prosca(n,g,gg,aux1,izs,rzs,dzs)
      redem=abs(aux1) .gt. abs(ro * ggcarr)
      else
      redem=.false.
      endif
c
c  ********************
c  phase ix:mise a jour
c  ********************
c
c calcul de s stocke dans d et de y stocke dans xx
      do 9000 j=1,n
      d(j)=alpha * d(j)
      xx(j)=g(j)-gg(j)
9000  continue
      if (redem) then
c cas ou x(i) est un point de redemarrage
      i=1
      nmisaj=1
c sauvegarde de s qui est actuellement dans d
c                u=h*y=y
c                nu=(y,hy)=(y,y)
c                eta=(s,y)
c calcul des indices
      inu=1
      ieta=inu + 1
      iu=ieta
      is=iu + n
c
      do 9100 j=1,n
      h(iu +j)=xx(j)
      h(is +j)=d(j)
9100  continue
      call prosca(n,xx,xx,nu,izs,rzs,dzs)
      h(inu)=nu
      call prosca(n,d,xx,eta,izs,rzs,dzs)
      h(ieta)=eta
c h1 est maintenant definie
c calcul de h1*g que l'on range dans xx
      call fmulb1(n,h,g,xx,tabaux,nmisaj,prosca,izs,rzs,dzs)
c
      else if (gc) then
c cas de gc sans redamarrage
c calcul de h*y range dans gg
       call fmulb1(n,h,xx,gg,tabaux,nmisaj,prosca,izs,rzs,dzs)
c calculs de  nu, eta, sscalg, uscalg
      call prosca(n,xx,gg,nu,izs,rzs,dzs)
      call prosca(n,d,xx,eta,izs,rzs,dzs)
      call prosca(n,d,g,sscalg,izs,rzs,dzs)
      call prosca(n,gg,g,uscalg,izs,rzs,dzs)
c calcul de sigma et de mu
      sigma=(uscalg -(un + nu / eta)* sscalg) / eta
      mu=sscalg /eta
c calcul de h*g que l'on range dans xx
      call fmulb1(n,h,g,xx,tabaux,nmisaj,prosca,izs,rzs,dzs)
c calcul de la nouvelle direction de recherche:
c h*g - mu * u - sigma * s
      do 9200 j=1,n
      xx(j)= xx(j) - mu * gg(j) - sigma * d(j)
9200  continue
c
c cas d'une iteration de type quasi newton
      if (iterqn) then
      nmisaj=nmisaj + 1
c sauvegarde des termes utiles pour stocker la matrice mise a jour
      inu=inu + memsup
      ieta=inu + 1
      iu=ieta
      is=iu + n
      do 9300 j=1,n
      h(iu +j)=gg(j)
      h(is +j)=d(j)
9300  continue
      h(inu)=nu
      h(ieta)=eta
      endif
c cas de la methode quasi newton
      else
c calcul de eta=(s,y)
      call prosca(n,d,xx,eta,izs,rzs,dzs)
      if (i .eq. 1) then
c etape initiale calcul de l'approximation initiale de l'inverse de la
c matrice hessienne
c calcul de nu=(y,h0*y)=(y,y)
      call prosca(n,xx,xx,nu,izs,rzs,dzs)
c stockage de cette matrice h=(eta / nu) * i
      kj=1
      aux1=eta / nu
      do 9500 k=1,n
      h(kj)=aux1
      kj=kj +1
      kp1=k+1
      if (n .ge. kp1) then
      do 9400 j=kp1,n
      h(kj)=zero
      kj=kj +1
9400  continue
      endif
      gg(k)=aux1 * xx(k)
9500  continue
      nu=eta
      else
      call fmuls1(n,h,xx,gg)
      call prosca(n,xx,gg,nu,izs,rzs,dzs)
      endif
c calcul de la matrice mise a jour (utilisation de la formule bfgs )
c nu, eta et h*y (stocke dans gg) sont connus
      aux1=un + nu / eta
      kj=1
      do 9800 k=1,n
c calcul du vecteur contenant la keme colonne de h
      lk=k
      km1=k-1
      if (k .ge. 2) then
      do 9610 l=1,km1
      tabaux(l)=h(lk)
      lk=lk + (n-l)
9610  continue
      endif
      do 9620 l=k,n
      tabaux(l)=h(lk)
      lk=lk+1
9620  continue
c
      call prosca(n,xx,tabaux,aux2,izs,rzs,dzs)
      do 9630 l=1,n
      tabaux(l)=zero
9630  continue
      tabaux(k)=un
      call prosca(n,tabaux,d,sscaek,izs,rzs,dzs)
      kj=k-n
      do 9700 j=1,k
      kj=kj+n-j+1
      h(kj)=h(kj) - ( (aux2 - aux1*sscaek)*d(j) + sscaek*gg(j) )/eta
9700  continue
9800  continue
      endif
c
c  *****************************************************
c  phase x :calcul de la nouvelle direction de recherche
c  *****************************************************
c
      if (gc) then
c xx contient -d
      do 10000 j=1,n
      d(j)=-xx(j)
10000 continue
c
       else
c cas de la methode de quasi newton
c la nouvelle direction d egale -(h * g)
      call fmuls1(n,h,g,d)
      do 10100 j=1,n
      d(j)=-d(j)
10100 continue
      endif
c
c test:la direction de recherche est elle bien de descente
      call prosca(n,d,g,dg1,izs,rzs,dzs)
      if (dg1 .ge. zero) then
      info=7
      if (imp .gt. 1) write(io,10101) dg1
      goto 99999
      else
      goto 4000
      endif
c
c retour au programme appelant
99999 niter=iter
      nsim=ntotap
      if (i .eq. 0) then
      eps=normg0
      else
      eps=normg
      endif
10101 format(40h n1gc2a   erreur dans la hessienne   dg=,d9.2)
      end


      SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK )
*
*  -- LAPACK routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            L, LDA, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix
*  [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R  0 ) * Z, by means
*  of orthogonal transformations.  Z is an (M+L)-by-(M+L) orthogonal
*  matrix and, R and A1 are M-by-M upper triangular matrices.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  L       (input) INTEGER
*          The number of columns of the matrix A containing the
*          meaningful part of the Householder vectors. N-M >= L >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the leading M-by-N upper trapezoidal part of the
*          array A must contain the matrix to be factorized.
*          On exit, the leading M-by-M upper triangular part of A
*          contains the upper triangular matrix R, and elements N-L+1 to
*          N of the first M rows of A, with the array TAU, represent the
*          orthogonal matrix Z as a product of M elementary reflectors.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  TAU     (output) DOUBLE PRECISION array, dimension (M)
*          The scalar factors of the elementary reflectors.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (M)
*
*  Further Details
*  ===============
*
*  Based on contributions by
*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
*  The factorization is obtained by Householder's method.  The kth
*  transformation matrix, Z( k ), which is used to introduce zeros into
*  the ( m - k + 1 )th row of A, is given in the form
*
*     Z( k ) = ( I     0   ),
*              ( 0  T( k ) )
*
*  where
*
*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),
*                                                 (   0    )
*                                                 ( z( k ) )
*
*  tau is a scalar and z( k ) is an l element vector. tau and z( k )
*  are chosen to annihilate the elements of the kth row of A2.
*
*  The scalar tau is returned in the kth element of TAU and the vector
*  u( k ) in the kth row of A2, such that the elements of z( k ) are
*  in  a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in
*  the upper triangular part of A1.
*
*  Z is given by
*
*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLARFP, DLARZ
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
*     Quick return if possible
*
      IF( M.EQ.0 ) THEN
         RETURN
      ELSE IF( M.EQ.N ) THEN
         DO 10 I = 1, N
            TAU( I ) = ZERO
   10    CONTINUE
         RETURN
      END IF
*
      DO 20 I = M, 1, -1
*
*        Generate elementary reflector H(i) to annihilate
*        [ A(i,i) A(i,n-l+1:n) ]
*
         CALL DLARFP( L+1, A( I, I ), A( I, N-L+1 ), LDA, TAU( I ) )
*
*        Apply H(i) to A(1:i-1,i:n) from the right
*
         CALL DLARZ( 'Right', I-1, N-I+1, L, A( I, N-L+1 ), LDA,
     $               TAU( I ), A( 1, I ), LDA, WORK )
*
   20 CONTINUE
*
      RETURN
*
*     End of DLATRZ
*
      END


*DECK DENORM
      DOUBLE PRECISION FUNCTION DENORM (N, X)
C***BEGIN PROLOGUE  DENORM
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DNSQ and DNSQE
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (ENORM-S, DENORM-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     Given an N-vector X, this function calculates the
C     Euclidean norm of X.
C
C     The Euclidean norm is computed by accumulating the sum of
C     squares in three different sums. The sums of squares for the
C     small and large components are scaled so that no overflows
C     occur. Non-destructive underflows are permitted. Underflows
C     and overflows do not occur in the computation of the unscaled
C     sum of squares for the intermediate components.
C     The definitions of small, intermediate and large components
C     depend on two constants, RDWARF and RGIANT. The main
C     restrictions on these constants are that RDWARF**2 not
C     underflow and RGIANT**2 not overflow. The constants
C     given here are suitable for every known computer.
C
C     The function statement is
C
C       DOUBLE PRECISION FUNCTION DENORM(N,X)
C
C     where
C
C       N is a positive integer input variable.
C
C       X is an input array of length N.
C
C***SEE ALSO  DNSQ, DNSQE
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DENORM
      INTEGER I, N
      DOUBLE PRECISION AGIANT, FLOATN, ONE, RDWARF, RGIANT, S1, S2, S3,
     1     X(*), X1MAX, X3MAX, XABS, ZERO
      SAVE ONE, ZERO, RDWARF, RGIANT
      DATA ONE,ZERO,RDWARF,RGIANT /1.0D0,0.0D0,3.834D-20,1.304D19/
C***FIRST EXECUTABLE STATEMENT  DENORM
      S1 = ZERO
      S2 = ZERO
      S3 = ZERO
      X1MAX = ZERO
      X3MAX = ZERO
      FLOATN = N
      AGIANT = RGIANT/FLOATN
      DO 90 I = 1, N
         XABS = ABS(X(I))
         IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70
            IF (XABS .LE. RDWARF) GO TO 30
C
C              SUM FOR LARGE COMPONENTS.
C
               IF (XABS .LE. X1MAX) GO TO 10
                  S1 = ONE + S1*(X1MAX/XABS)**2
                  X1MAX = XABS
                  GO TO 20
   10          CONTINUE
                  S1 = S1 + (XABS/X1MAX)**2
   20          CONTINUE
               GO TO 60
   30       CONTINUE
C
C              SUM FOR SMALL COMPONENTS.
C
               IF (XABS .LE. X3MAX) GO TO 40
                  S3 = ONE + S3*(X3MAX/XABS)**2
                  X3MAX = XABS
                  GO TO 50
   40          CONTINUE
                  IF (XABS .NE. ZERO) S3 = S3 + (XABS/X3MAX)**2
   50          CONTINUE
   60       CONTINUE
            GO TO 80
   70    CONTINUE
C
C           SUM FOR INTERMEDIATE COMPONENTS.
C
            S2 = S2 + XABS**2
   80    CONTINUE
   90    CONTINUE
C
C     CALCULATION OF NORM.
C
      IF (S1 .EQ. ZERO) GO TO 100
         DENORM = X1MAX*SQRT(S1+(S2/X1MAX)/X1MAX)
         GO TO 130
  100 CONTINUE
         IF (S2 .EQ. ZERO) GO TO 110
            IF (S2 .GE. X3MAX)
     1         DENORM = SQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3)))
            IF (S2 .LT. X3MAX)
     1         DENORM = SQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3)))
            GO TO 120
  110    CONTINUE
            DENORM = X3MAX*SQRT(S3)
  120    CONTINUE
  130 CONTINUE
      RETURN
C
C     LAST CARD OF FUNCTION DENORM.
C
      END


!--------------------------------------------------------------------------------------------------
! PROGRAM: overlap_output_mod
!> @author Marin Sapunar, Ruđer Bošković Institute
!> @date March, 2019
!
!> @brief Subroutines for printing overlap program output.
!--------------------------------------------------------------------------------------------------
module overlap_output_mod
    use global_defs
    use write_txt_mod
    implicit none

    private
    public :: output_ao
    public :: output_mo
    public :: output_wf
    public :: output_orth
    public :: output_phase
    public :: output_dyson

    character(len=*), parameter :: out_fmt_s = '(5x,1000f10.6)'

contains

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: output_ao
    !> @brief Print AO overlap matrix to file.
    !----------------------------------------------------------------------------------------------
    subroutine output_ao(outfile, s_ao)
        character(len=*), intent(in) :: outfile
        real(dp), intent(in) :: s_ao(:, :)
        if (outfile == 'None') return
        if (print_level >= 1) then
            write(stdout, '(1x,a)') 'Writing AO overlap matrix to '//outfile//'.'
        end if
        call write_txt(outfile, transpose(s_ao))
    end subroutine output_ao

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: output_mo
    !> @brief Print MO overlap matrix to file.
    !----------------------------------------------------------------------------------------------
    subroutine output_mo(outfile, s_mo_a, s_mo_b)
        character(len=*), intent(in) :: outfile
        real(dp), allocatable, intent(in) :: s_mo_a(:, :)
        real(dp), allocatable, intent(in) :: s_mo_b(:, :)
        if (outfile == 'None') return
        if (.not. allocated(s_mo_b)) then
            if (print_level >= 1) then
                write(stdout, '(1x,a)') 'Writing MO overlap matrix to '//outfile//'.'
            end if
            call write_txt(outfile, transpose(s_mo_a))
        else
            if (print_level >= 1) then
                write(stdout, '(1x,a)') 'Writing alpha MO overlap matrix to '//outfile//'_a.'
                write(stdout, '(1x,a)') 'Writing beta MO overlap matrix to '//outfile//'_b.'
            end if
            call write_txt(outfile//'_a', transpose(s_mo_a))
            call write_txt(outfile//'_b', transpose(s_mo_b))
        end if
    end subroutine output_mo

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: output_wf
    !> @brief Print WF overlap matrix to file.
    !----------------------------------------------------------------------------------------------
    subroutine output_wf(outfile, s_wf)
        character(len=*), intent(in) :: outfile
        real(dp), intent(in) :: s_wf(:, :)
        if (outfile == 'None') return
        if (print_level >= 1) then
            write(stdout, '(1x,a)') 'Writing WF overlap matrix to '//outfile//'.'
        end if
        call write_txt(outfile, transpose(s_wf))
    end subroutine output_wf

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: output_orth
    !> @brief Orthogonalize WF overlap matrix and print to stdout.
    !----------------------------------------------------------------------------------------------
    subroutine output_orth(orth_overlap, s_wf)
        use orthog_mod
        use matrix_mod
        logical, intent(in) :: orth_overlap
        real(dp), intent(inout) :: s_wf(:, :)
        real(dp), allocatable :: s_wf_orig(:, :)
        real(dp) :: angle
        integer :: i

        if (print_level >= 1) then
            write(stdout, *)
            write(stdout, '(1x,a)') 'Raw overlap matrix:'
            do i = lbound(s_wf, 1), ubound(s_wf, 1)
                write(stdout, out_fmt_s) s_wf(i, :)
            end do
        end if

        if (orth_overlap) then
            allocate(s_wf_orig, source=s_wf)
            call orthog_lowdin(s_wf)
            if (print_level >= 1) then
                write(stdout, *)
                write(stdout, '(1x,a)') 'Orthogonalized overlap matrix:'
                do i = lbound(s_wf, 1), ubound(s_wf, 1)
                    write(stdout, out_fmt_s) s_wf(i, :)
                end do
                angle = acos(sum(s_wf*s_wf_orig) / mat_norm(s_wf) / mat_norm(s_wf_orig))
                write(stdout, *)
                write(stdout, '(5x,a,f6.2)') 'Frobenius inner product angle: ', angle * 180 / pi
                write(stdout, '(5x,a)') 'Norms of rows of raw overlap matrix: '
                write(stdout, '(9x,1000f10.4)') sum(s_wf_orig**2, 2)
                write(stdout, '(5x,a)') 'Norms of columns of raw overlap matrix: '
                write(stdout, '(9x,1000f10.4)') sum(s_wf_orig**2, 1)
            end if
        end if
    end subroutine output_orth

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: output_phase
    !> @brief Match phase of el. states in WF overlap matrix and print to stdout.
    !----------------------------------------------------------------------------------------------
    subroutine output_phase(match_phase, s_wf)
        use phase_mod
        use assignment_problem_mod
        logical, intent(in) :: match_phase
        real(dp), intent(inout) :: s_wf(:, :)
        integer, allocatable :: assigned_rows(:)
        integer, allocatable :: assigned_cols(:)
        integer :: i
        if (match_phase) then
            call phasematch_assigned_rotation(s_wf)
            if (print_level >= 1) then
                write(stdout, *)
                write(stdout, '(1x,a)') 'Overlap matrix with phase matching between assigned bra/ket states:'
                do i = lbound(s_wf, 1), ubound(s_wf, 1)
                    write(stdout, out_fmt_s) s_wf(i, :)
                end do
                call assignment_problem(-s_wf**2, assigned_rows, assigned_cols)
                write(stdout, '(5x,a)') 'Assignment:'
                write(stdout, '(9x,a,1000(i0, 1x))') 'Rows: ', assigned_rows
                write(stdout, '(9x,a,1000(i0, 1x))') 'Cols: ', assigned_cols
            end if
        end if
    end subroutine output_phase

    subroutine output_dyson()
        use overlap_variables
        use basis_transform_mod, only : basis_transform
        use molden_write_mod
        integer :: i, j, outunit
        type(basis_transform) :: trans
        character(len=1000) :: temp

        call trans%init(bs2, bs2%source_format, 'molden_cart')
        call trans%transform(dyson_ao, 1)

        open(newunit=outunit, file=prefix_dyson//'.at', action='write')
        call molden_write_atoms(outunit, geom1, atom_symbol, atom_number)
        close(outunit)
        open(newunit=outunit, file=prefix_dyson//'.gto', action='write')
        call molden_write_gto(outunit, bs1)
        close(outunit)
        do i = 0, size(cisa1, 3)
            do j = 0, size(cisa2, 3)
                ! Write MO basis dyson orbital.
                write(temp, '(a,a,i3.3,a,i3.3,a)') prefix_dyson, '.', i, '.', j, '.mo'
                open(newunit=outunit, file=temp, action='write')
                write(outunit, '(1e13.5)') dyson_mo(:, i, j)
                close(outunit)
                ! Write AO basis dyson orbital.
                write(temp, '(a,a,i3.3,a,i3.3,a)') prefix_dyson, '.', i, '.', j, '.ao'
                open(newunit=outunit, file=temp, action='write')
                call molden_write_mo_single(outunit, 1000*i+j, 'a   ', 1, 0.0_dp, dyson_norm(i, j),      &
                &                           dyson_ao(:, i, j))
                close(outunit)
            end do
        end do
    end subroutine output_dyson

end module overlap_output_mod


*
      SUBROUTINE JACOBI( N, B, X, WORK, LDW, ITER, RESID, MATVEC,
     $                   INFO )
*
*  -- Iterative template routine --
*     Univ. of Tennessee and Oak Ridge National Laboratory
*     October 1, 1993
*     Details of this algorithm are described in "Templates for the
*     Solution of Linear Systems: Building Blocks for Iterative
*     Methods", Barrett, Berry, Chan, Demmel, Donato, Dongarra,
*     Eijkhout, Pozo, Romine, and van der Vorst, SIAM Publications,
*     1993. (ftp netlib2.cs.utk.edu; cd linalg; get templates.ps).
*
*     .. Scalar Arguments ..
      INTEGER            N, LDW, ITER, INFO
      DOUBLE PRECISION   RESID
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   B( * ), X( * ), WORK( * )
*     ..
*     .. Function Arguments ..
      EXTERNAL           MATVEC
*
*  Purpose
*  =======
*
*  JACOBI solves the linear system Ax = b using the Jacobi iterative
*  method. The matrix splitting should be accomplished before calling
*  this routine. The diagonal elements of the matrix must be passed into
*  this routine in the first column of matrix WORK.
*
*  Relative error measured: norm( X - X_1 ) / norm( X ).
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          On entry, the dimension of the matrix.
*          Unchanged on exit.
*
*  B       (input) DOUBLE PRECISION array, dimension N
*          On entry, right hand side vector B.
*          Unchanged on exit.
*
*  X       (input/output) DOUBLE PRECISION array, dimension N.
*          On input, the initial guess. This is commonly set to
*          the zero vector.
*          On exit, if INFO = 0, the iterated approximate solution.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDW,3)
*          Workspace for residual, direction vector, etc.
*
*  LDW     (input) INTEGER
*          The leading dimension of the array WORK. LDW >= max(1,N).
*
*  ITER    (input/output) INTEGER
*          On input, the maximum iterations to be performed.
*          On output, actual number of iterations performed.
*
*  RESID   (input/output) DOUBLE PRECISION
*          On input, the allowable convergence measure for
*          norm( x - x_1 ) / norm( x ).
*          On output, the final value of this measure.
*
*  MATVEC  (external subroutine)
*          The user must provide a subroutine to perform the
*          matrix-vector product
*
*               y := alpha*A*x + beta*y,
*
*          where alpha and beta are scalars, x and y are vectors,
*          and A is a matrix. Vector x must remain unchanged.
*          The solution is over-written on vector y.
*
*          The call is:
*
*             CALL MATVEC( ALPHA, X, BETA, Y )
*
*          The matrix is passed into the routine in a common block.
*
*  INFO    (output) INTEGER
*
*          =  0: Successful exit. Iterated approximate solution returned.
*
*          >  0: Convergence to tolerance not achieved. This will be
*                set to the number of iterations performed.
*
*          <  0: Illegal input parameter, or breakdown occurred
*                during iteration.
*
*                Illegal parameter:
*
*                   -1: matrix dimension N < 0
*                   -2: LDW < N
*                   -3: Maximum number of iterations ITER <= 0.
*
*  ==========================================================
*
*     .. Local Scalars ..
*
*This variable used to communicate requests between JACOBI() &
* JACOBIREVCOM()
*JACOBI -> JACOBIREVCOM: 1 = init,
*                        2 = use saved state to resume flow.
*JACOBIREVCOM -> JACOBI: -1 = done, return to main,
*                         1 = matvec using SCLR1/2, NDX1/2
      INTEGER          IJOB
*     Arg/Result indices into WORK[].
      INTEGER NDX1, NDX2
*     Scalars passed from JacobiREVCOM to Jacobi.
      DOUBLE PRECISION SCLR1, SCLR2
*     Vars reqd for STOPTEST2
      DOUBLE PRECISION TOL, XNRM2
*     ..
*     .. External subroutines ..
      EXTERNAL         JACOBIREVCOM, STOPTEST2
*     ..
*     .. Executable Statements ..
*
      INFO = 0
*
*     Test the input parameters.
*
      IF ( N.LT.0 ) THEN
         INFO = -1
      ELSE IF ( LDW.LT.MAX( 1, N ) ) THEN
         INFO = -2
      ELSE IF ( ITER.LE.0 ) THEN
         INFO = -3
      ENDIF
      IF ( INFO.NE.0 ) RETURN
*
*     Stop test may need some indexing info from REVCOM
*     use the init call to send the request across. REVCOM
*     will note these requests, and everytime it asks for
*     stop test to be done, it will provide the indexing info.
*
*     1 == MM; 2 == X1; 3 == TEMP; -1 == ignore; any other == error
      NDX1 = 2
      NDX2 = -1
      TOL = RESID
*
*     First time call always init.
*
      IJOB = 1

 1    CONTINUE

          CALL JACOBIREVCOM(N, B, X, WORK, LDW, ITER, RESID, INFO,
     $                      NDX1, NDX2, SCLR1, SCLR2, IJOB)

*         On a return from REVCOM() we use the table
*         to decode IJOB.
          IF (IJOB .eq. -1) THEN
*           revcom wants to terminate, so do it.
            GOTO 2
          ELSEIF (IJOB .eq. 1) THEN
*           call matvec.
*           note: ndx1 == -1 here, as we're directly using X
            CALL MATVEC(SCLR1, X, SCLR2, WORK(NDX2))
         ELSEIF (IJOB .EQ. 2) THEN
*           do stopping test 2
*           XNRM2 shld be recomputed everytime.
            INFO = -1
            CALL STOPTEST2(N, WORK(NDX1), X, XNRM2, RESID, TOL, INFO)
         ENDIF
*
*         done what revcom asked, set IJOB & go back to it.
          IJOB = 2
      GOTO 1
*
*     come here to terminate
 2    CONTINUE
*
      RETURN
*
*     End of JACOBI
*
      END


program main
    use std
    implicit none
    type(Random_) :: r
    type(IO_) :: f
    integer(int32) :: i

    call f%open("./","data",".txt")
    call r%init()
    do i=1,2000
        write(f%fh,*) r%random()
    enddo
    call f%close()

end program


program problem_5

use aoc_utilities

implicit none

type :: line
    integer :: x1 = 0
    integer :: y1 = 0
    integer :: x2 = 0
    integer :: y2 = 0
end type line

integer :: iunit, n_lines, i, x, y, j, x1, x2, y1, y2
integer,dimension(:,:),allocatable :: map
type(line),dimension(:),allocatable :: lines
character(len=:),allocatable :: line_from_file
logical :: status_ok
type(string),dimension(:),allocatable :: vals
type(string),dimension(:),allocatable :: initial_vals, final_vals
integer :: max_x, max_y
logical :: horizontal, vertical, neither

open(newunit=iunit,file='inputs/day5.txt')

n_lines = number_of_lines_in_file(iunit)

allocate(lines(n_lines))

! first read all the lines:
do i = 1, n_lines
    call read_line_from_file(iunit,line_from_file,status_ok)
    call split(line_from_file,' -> ',vals)
    if (size(vals)/=2) error stop 'invalid line'
    call split(vals(1)%str,',',initial_vals)
    call split(vals(2)%str,',',final_vals)
    if (size(initial_vals)/=2) error stop 'invalid initial_vals'
    if (size(final_vals)/=2) error stop 'invalid final_vals'
    read(initial_vals(1)%str,*) x1
    read(initial_vals(2)%str,*) y1
    read(final_vals(1)%str,*)   x2
    read(final_vals(2)%str,*)   y2
    lines(i)%x1 = min(x1,x2)  ! reorder for min, max to make it easier
    lines(i)%x2 = max(x1,x2)
    lines(i)%y1 = min(y1,y2)
    lines(i)%y2 = max(y1,y2)
end do
! write(*,*) lines

! now, size the map:
max_x = maxval([lines(:)%x1, lines(:)%x2])
max_y = maxval([lines(:)%y1, lines(:)%y2])
! write(*,*) 'max x,y = ', max_x, max_y

allocate(map(0:max_y, 0:max_x))
map = 0

! now, populate the map with the lines:
do i = 1, n_lines
    horizontal = lines(i)%y1 == lines(i)%y2
    vertical   = lines(i)%x1 == lines(i)%x2
    neither = (.not. horizontal) .and. (.not. vertical)

    if (horizontal) then
        do x = lines(i)%x1, lines(i)%x2
            map(lines(i)%y1, x) = map(lines(i)%y1, x) + 1
        end do
    else if (vertical) then
        do y = lines(i)%y1, lines(i)%y2
            map(y, lines(i)%x1) = map(y, lines(i)%x1) + 1
        end do
    else
        !error stop 'not horizontal or vertical'
        cycle ! skip it
    end if

end do

! visualize the board:
do i = 0, ubound(map,1)
    do j = 0, ubound(map,2)
        if (map(i,j)==0) then
            write(999,'(A)',advance='NO') '.'
        else
            write(999,'(I1)',advance='NO') map(i,j)
        end if
    end do
    write(999,*) ''
end do

write(*,*) '5A: number where 2 or more overlap: ', count(map>1)

end program problem_5


module gpfunc
implicit none

contains

subroutine xdiff2_L2(nd, nb, xa, xb, l, xdiff2)
  integer, intent(in)    :: nd, nb             ! Dimension and number of points
  real(8), intent(in)    :: xa(nd), xb(nd, nb) ! Points
  real(8), intent(in)    :: l(nd)              ! Length scales
  real(8), intent(out)   :: xdiff2(nb)         ! Output: squared distance

  integer :: kb

  !$omp simd
  do kb = 1, nb
    xdiff2(kb) = sum(((xa - xb(:, kb))/l)**2)
  end do
end subroutine xdiff2_L2

subroutine build_K(nd, nxa, nxb, xa, xb, K, kern, l, sig2f, sig2n, periodic)
  ! Build a kernel matrix using a function `kern` to construct columns/rows
  integer, intent(in)    :: nd, nxa, nxb  ! Dimension and number of points
  real(8), intent(in)    :: xa(nd, nxa), xb(nd, nxb) ! Points
  real(8), intent(inout) :: K(nxa, nxb)   ! Output: kernel matrix
  real(8), intent(in)    :: l(nd)         ! Length scales
  real(8), intent(in)    :: sig2f         ! Output scale covariance
  real(8), intent(in)    :: sig2n         ! Noise covariance
  logical, optional      :: periodic(nd)  ! `True` for periodic directions
  external :: kern  ! Kernel function `kern(nd, nx, xa, xb, out)`

  integer :: ka !, kb, kd
  real(8) :: xdiff2(nxb) ! xanorm(nd, nxa), xbnorm(nd, nxb)

  ! if (present(periodic)) then
  !   xbnorm = 0d0
  !   !$omp simd
  !   do kd = 1, nd
  !     if (periodic(kd)) then
  !       xanorm(kd, :) = sin(xa(kd, :) - xb(kd, :))/l(kd)
  !     else
  !       xanorm(kd, :) = (xa(kd, :) - xb(kd, :))/l(kd)
  !     endif
  !   end do
  ! else
  !   !$omp simd
  !   do kd = 1, nd
  !     xanorm(kd, :) = xa(kd, :)/l(kd)
  !     xbnorm(kd, :) = xb(kd, :)/l(kd)
  !   end do
  ! endif

  !$omp parallel do private(xdiff2)
  do ka = 1, nxa
    call xdiff2_L2(nd, nxb, xa(:, ka), xb, l, xdiff2)
    call kern(nxb, xdiff2, K(:, ka))
    K(:, ka) = sig2f*K(:, ka)
    K(ka, ka) = K(ka, ka) + sig2n
  end do
  !$omp end parallel do

end subroutine build_K

! TODO: Build dK/dl(kd)
! use dkern/kern as below
!
! TODO: Build K derivative observarion
! for sqexp Kxx = (1 - x)*K or something like this
! could give instead of dkern(x) better f=dkern(x)/kern(x)
! f : dkern = f*kern  (auto-differentiation and pullback similar)
! very cheap for sqexp (and periodic)
!
! build_L
!   loop over dimension and evaluate dkern d2kern
!
! build dL/dl(kd)

subroutine kern_sqexp(nx, xdiff2, out)
  integer, intent(in) :: nx
  real(8), intent(in) :: xdiff2(nx)
  real(8), intent(out) :: out(nx)

  out = exp(-0.5d0*xdiff2)
end subroutine kern_sqexp

end module gpfunc


!=====================================================|
subroutine mhd
!=====================================================|
  use geometry_def, only: nxg,qq,qqm,mtype
  implicit none

  integer :: i,m
!-----------------------------------------------------|

  call cfl
  call sc4rk4
  call artdif

  do i = 1,nxg
  do m = 1,mtype
     qq(i,m) = qqm(i,m)
  enddo
  enddo

  return
end subroutine mhd


      subroutine  csrotf (n,cx,incx,cy,incy,c,s)
c
c     applies a plane rotation, where the cos and sin (c and s) are real
c     and the vectors cx and cy are complex.
c     jack dongarra, linpack, 3/11/78.
c
      complex cx(1),cy(1),ctemp
      real c,s
      integer i,incx,incy,ix,iy,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c       code for unequal increments or equal increments not equal
c         to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        ctemp = c*cx(ix) + s*cy(iy)
        cy(iy) = c*cy(iy) - s*cx(ix)
        cx(ix) = ctemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c       code for both increments equal to 1
c
   20 do 30 i = 1,n
        ctemp = c*cx(i) + s*cy(i)
        cy(i) = c*cy(i) - s*cx(i)
        cx(i) = ctemp
   30 continue
      return
      end