subroutine zbuildmat_vec(ndim,norder, wgeo, fkernel, q1, q2, &
     fgreens, par0, pars1, pars2, ntot, cmat)
  implicit real *8 (a-h,o-z)
  integer, intent(in) :: ndim, norder
  real *8, intent(in) :: wgeo(*)
  complex *16, intent(in) :: par0, pars1(*), pars2(*)
  complex *16, intent(in) :: q1(*), q2(*)
  integer, intent(out) :: ntot
  complex *16, intent(out) :: cmat(*)
  external fkernel, fgreens

  !
  ! build **an arbitrary** layer potential matrix using bremer-style
  ! chunk quadratures. this assumed that each chunk is *locally*
  ! oriented counter-clockwise.
  !
  ! input:
  !   norder - the order of the quadrature routine to use even
  !       though right now it enforces that norder is equal to
  !       the number of points on each chunk
  !   wgeo - the geometry structure created by chunks routines
  !   fkernel - the kernel evaluation routine, must have its
  !       calling sequence of the form:
  !           fkernel(par0, src, targ, src_normal, targ_normal,
  !               q1, q2, fgreens, pars1, pars2, val)
  !   fgreens- subroutine generating the greens function, its
  !       calling sequence must be of the form:
  !           fgreens(par0, src, targ, pars1, pars2, val, grad,
  !               hess)
  !     NOTE: be sure to take note that fgreens is **passed** to
  !         to the subroutine fkernel - that is, we make a
  !         distinction between the greens function and the kernel
  !
  ! output:
  !   ntot - the dimension of the matrix, ntot = k*nch*ndim
  !   cmat - the matrix which applies the kernel fkernel
  !
  !     This is mainly a memory management and unpacking routine
  !

  !
  ! first get some chunk info
  !
  call chunkunpack1(wgeo, k, nch, ichunks, iadjs, iders, &
       iders2, ihs)

  ntot = k*nch*ndim
  if (norder .ne. k) then
     call prinf('norder = *', norder, 1)
     call prinf('k = *', k, 1)
     call prinf('bomb!!!!*', k, 0)
     stop
  endif

  call zbuildmat_vec0(ndim,norder, k, nch, wgeo, fkernel, &
       q1, q2, &
       fgreens, par0, pars1, pars2, ntot, cmat)

  return
end subroutine zbuildmat_vec

subroutine zbuildmat_vec0(ndim,norder, k, nch, wgeo, &
     fkernel, q1, q2, &
     fgreens, par0, pars1, pars2, ntot, zmat)
  implicit real *8 (a-h,o-z)
  integer, intent(in) :: ndim,norder, k, nch, ntot
  real *8, intent(in) :: wgeo(*)
  complex *16, intent(in) :: par0, pars1(*), pars2(*)
  complex *16, intent(in) :: q1(*), q2(*)
  complex *16, intent(out) :: zmat(ntot,ntot)

  external fkernel, fgreens

  real *8, allocatable :: xs(:), whts(:)
  real *8, allocatable :: xs1(:), whts1(:)
  real *8, allocatable :: xs0(:,:), whts0(:,:)
  complex *16, allocatable :: tempmat(:,:)
  complex *16, allocatable :: tempnear(:,:,:)
  complex *16, allocatable :: tempself(:,:,:)
  integer ntmat

  !
  ! actually go ahead and build the matrix, block by block
  !
  done = 1
  ntmat = ndim*k
  allocate(tempmat(ntmat,ntmat))

  itype = 1
  allocate(xs(k), whts(k))
  call legerts(itype, k, xs, whts)

  !
  ! get the bremer near and self quadratures
  !

  do j = 1,ntot
     do i = 1,ntot
        zmat(i,j) = 0
     enddo
  enddo

  call getquadsinfo(k, nquad1, nquad0)
  allocate(xs1(nquad1), whts1(nquad1))
  allocate(xs0(k,k), whts0(k,k))
  call getquads(k, nquad1, xs1, whts1, nquad0, xs0, whts0)

  allocate(tempnear(nquad1,ndim,ndim))
  allocate(tempself(k,ndim,ndim))

  !$omp parallel do default(shared) &
  !$omp     private(itarget, imat, ibefore, iafter) &
  !$omp     private(jsource,jmat,tempmat,tempnear,tempself)

  do itarget = 1,nch
     imat = 1 + (itarget-1)*ntmat

     call chunk_neighbors(itarget, wgeo, ibefore, iafter)

     !
     ! for all target chunks, loop over source chunks
     !

     do jsource = 1,nch
        jmat = 1 + (jsource-1)*ntmat

        ifoff = 1

        if (jsource .eq. ibefore) then
           call znear_buildmat_vec(ndim,itarget, jsource, &
                k, wgeo, &
                fkernel, q1, q2, fgreens, par0, pars1, pars2, &
                nquad1, xs1, whts1, tempmat,tempnear)
           call zinsertmat(ntmat,ntmat, tempmat, imat, jmat, &
                ntot, ntot, zmat)
           ifoff = -1
        endif

        if (jsource .eq. iafter) then
           call znear_buildmat_vec(ndim,itarget, jsource, k, wgeo, &
                fkernel, q1, q2, fgreens, par0, pars1, pars2, &
                nquad1, xs1, whts1, tempmat,tempnear)
           call zinsertmat(ntmat,ntmat, tempmat, imat, jmat, &
                ntot, ntot, zmat)
           ifoff = -1
        endif

        if (jsource .eq. itarget) then
           call zdiagonal_buildmat_vec(ndim,itarget, k, &
                wgeo, fkernel, &
                q1, q2, fgreens, par0, pars1, pars2, xs0, &
                whts0, tempmat, tempself)
           call zinsertmat(ntmat,ntmat, tempmat, imat, jmat, &
                ntot, ntot, zmat)
           ifoff = -1
        endif

        if (ifoff .eq. 1) then
           call zfar_buildmat_vec(ndim,itarget, jsource, &
                k, wgeo, &
                fkernel, q1, q2, fgreens, par0, pars1, pars2, xs, &
                whts, tempmat)
           call zinsertmat(ntmat,ntmat, tempmat, imat, &
                jmat, ntot, &
                ntot, zmat)
        endif

     enddo
  enddo

  !$omp end parallel do

end subroutine zbuildmat_vec0

subroutine zfar_buildmat_vec(ndim,ich_targ, ich_src, k, wgeo, &
     fkernel, q1, q2, fgreens, par0, pars1, pars2, xs, &
     whts, amat)
  implicit real *8 (a-h,o-z)
  integer, intent(in) :: k,ndim
  real *8, intent(in) :: wgeo(*), xs(k), whts(k)
  complex *16, intent(in) :: par0, pars1(*), pars2(*)
  complex *16, intent(in) :: q1(*), q2(*)
  complex *16, intent(out) :: amat(ndim*k,ndim*k)
  external fkernel, fgreens

  real *8 :: chunk_src(2000), chunk_targ(2000)
  real *8 :: der_src(2000), der_targ(2000)

  !
  ! build a kth order smooth quadrature on for the far
  ! field interation between targ and src chunks
  !

  call chunkaddr(ich_src, wgeo, k_src, ichunk_src, &
       iadj_src, ider_src, ider2_src, h_src)

  call chunkaddr(ich_targ, wgeo, k_targ, ichunk_targ, &
       iadj_targ, ider_targ, ider2_targ, h_targ)

  len = 2*k
  call chunks_dcopy(len, wgeo(ichunk_src), chunk_src)
  call chunks_dcopy(len, wgeo(ider_src), der_src)

  call chunks_dcopy(len, wgeo(ichunk_targ), chunk_targ)
  call chunks_dcopy(len, wgeo(ider_targ), der_targ)

  call zfar_buildmat_vec0(ndim,k, chunk_targ, der_targ, &
       h_targ, chunk_src, der_src, h_src, fkernel, q1, q2, &
       fgreens, par0, pars1, pars2, xs, whts, amat)

  return
end subroutine zfar_buildmat_vec

subroutine zfar_buildmat_vec0(ndim,k, chunk_targ, &
     der_targ, h_targ, chunk_src, der_src, h_src, fkernel, &
     q1, q2, fgreens, par0, pars1, pars2, xs, whts, amat)
  implicit real *8 (a-h,o-z)
  integer, intent(in) :: k,ndim
  real *8, intent(in) :: chunk_targ(2,k), der_targ(2,k), h_targ
  real *8, intent(in) :: chunk_src(2,k), der_src(2,k), h_src
  complex *16, intent(in) :: par0, pars1(*), pars2(*)
  complex *16, intent(in) :: q1(*), q2(*)
  real *8, intent(in) :: xs(k), whts(k)
  complex *16, intent(out) :: amat(ndim*k,ndim*k)
  external fgreens, fkernel

  real *8 :: src(10), targ(10)
  real *8 :: target_normal(10), source_normal(10)
  complex *16 :: val(ndim,ndim)

  !
  ! fill up the matrix with the smooth quadrature
  !

  done = 1

  do i = 1,k

     targ(1) = chunk_targ(1,i)
     targ(2) = chunk_targ(2,i)

     xp_targ = der_targ(1,i)
     yp_targ = der_targ(2,i)
     ds_targ = sqrt(xp_targ**2 + yp_targ**2)

     target_normal(1) = yp_targ/ds_targ
     target_normal(2) = -xp_targ/ds_targ

     do j = 1,k

        src(1) = chunk_src(1,j)
        src(2) = chunk_src(2,j)

        xp = der_src(1,j)
        yp = der_src(2,j)

        dd = sqrt(xp**2 + yp**2)
        source_normal(1) = yp/dd
        source_normal(2) = -xp/dd

        call fkernel(par0, src, targ, source_normal, &
             target_normal, q1, q2, fgreens, pars1, pars2, val)

        rnorm = sqrt(xp**2+yp**2)
        dsdt = rnorm*h_src
        do l1 = 1,ndim
           do l2 = 1,ndim
              amat((i-1)*ndim+l1,(j-1)*ndim+l2) = &
                   val(l1,l2)*whts(j)*dsdt
           enddo
        enddo
     enddo
  enddo

  return
end subroutine zfar_buildmat_vec0

subroutine znear_buildmat_vec(ndim,ich_targ, ich_src, k, wgeo, &
     fkernel, q1, q2, fgreens, par0, pars1, pars2, nquad, &
     xs, whts, amat, tempnear)
  implicit real *8 (a-h,o-z)
  integer, intent(in) :: k,ndim, nquad
  real *8, intent(in) :: wgeo(*), xs(nquad), whts(nquad)
  complex *16, intent(in) :: par0, pars1(*), pars2(*)
  complex *16, intent(in) :: q1(*), q2(*)
  complex *16, intent(out) :: amat(ndim*k,ndim*k)
  complex *16, intent(inout) :: tempnear(nquad,ndim,ndim)
  external fkernel, fgreens

  !
  ! build the matrix performing a neighbor interaction using
  ! bremer style quadratures
  !

  real *8 :: chunk_src(1000)
  real *8 :: chunk_targ(1000), der_src(1000), der_targ(1000)

  call chunkaddr(ich_src, wgeo, k_src, ichunk_src, &
       iadj_src, ider_src, ider2_src, h_src)

  call chunkaddr(ich_targ, wgeo, k_targ, ichunk_targ, &
       iadj_targ, ider_targ, ider2_targ, h_targ)

  len = 2*k
  !!call chunks_dcopy(len, wgeo(ichunk_src), chunk_src)
  !!call chunks_dcopy(len, wgeo(ider_src), der_src)

  !!call chunks_dcopy(len, wgeo(ichunk_targ), chunk_targ)
  !!call chunks_dcopy(len, wgeo(ider_targ), der_targ)

  call znear_buildmat_vec0(ndim,k, wgeo(ichunk_targ), wgeo(ider_targ), &
       h_targ, wgeo(ichunk_src), wgeo(ider_src), h_src, &
       fkernel, q1, q2, fgreens, par0, pars1, pars2, nquad, &
       xs, whts, amat, tempnear)

  return
end subroutine znear_buildmat_vec

subroutine znear_buildmat_vec0(ndim,k, chunk_targ, der_targ, &
     h_targ, chunk_src, der_src, h_src, fkernel, q1, q2, &
     fgreens, par0, pars1, pars2, nquad, xs, whts, amat,temp)
  implicit real *8 (a-h,o-z)
  integer, intent(in) :: k,ndim, nquad
  real *8, intent(in) :: chunk_targ(2,k), der_targ(2,k), h_targ
  real *8, intent(in) :: chunk_src(2,k), der_src(2,k), h_src
  complex *16, intent(in) :: par0, pars1(*), pars2(*)
  complex *16, intent(in) :: q1(*), q2(*)
  real *8, intent(in) :: xs(nquad), whts(nquad)
  complex *16, intent(out) :: amat(ndim*k,ndim*k)
  external fgreens, fkernel
  complex *16, intent(inout) :: temp(nquad,ndim,ndim)

  real *8 :: src(10), targ(10), source_normal(10)
  real *8 :: ts(1000), ainterp(1000000), target_normal(10)
  real *8 :: xcoefs_src(1000), ycoefs_src(1000)
  real *8 :: xpcoefs_src(1000), ypcoefs_src(1000)
  complex *16 :: val(ndim,ndim), w(1000000)

  !
  ! build the k by k near interaction matrix.
  !

  done = 1
  call chunksexps(k, chunk_src, xcoefs_src, ycoefs_src)
  call chunksexps(k, der_src, xpcoefs_src, ypcoefs_src)

  call lematrin(k, nquad, xs, ainterp, ts, w)

  do i = 1,k

     targ(1) = chunk_targ(1,i)
     targ(2) = chunk_targ(2,i)

     xp_targ = der_targ(1,i)
     yp_targ = der_targ(2,i)
     ds_targ = sqrt(xp_targ**2 + yp_targ**2)

     target_normal(1) = yp_targ/ds_targ
     target_normal(2) = -xp_targ/ds_targ

     do j = 1,nquad

        t_src = xs(j)
        call legeexev(t_src, src(1), xcoefs_src, k-1)
        call legeexev(t_src, src(2), ycoefs_src, k-1)
        call legeexev(t_src, xp, xpcoefs_src, k-1)
        call legeexev(t_src, yp, ypcoefs_src, k-1)

        dd = sqrt(xp**2 + yp**2)
        source_normal(1) = yp/dd
        source_normal(2) = -xp/dd

        call fkernel(par0, src, targ, source_normal, &
             target_normal, q1, q2, fgreens, pars1, pars2, val)

        dsdt = sqrt(xp**2+yp**2)*h_src
        do l1 = 1,ndim
           do l2 = 1,ndim
              temp(j,l1,l2) = val(l1,l2)*whts(j)*dsdt
           enddo
        enddo
     enddo

!!!!call lematrin(k, nquad, xs, ainterp, ts, w)
     i1 = 1
     do l1 = 1,ndim
        do l2 = 1,ndim
           call zmat_by_dmat(i1, nquad, temp(1,l1,l2), k, &
                ainterp, w)
           do j = 1,k
              amat((i-1)*ndim+l1,(j-1)*ndim+l2) = w(j)
           enddo
        enddo
     enddo
  enddo
  return
end subroutine znear_buildmat_vec0

subroutine zdiagonal_buildmat_vec(ndim,ich, k, wgeo, fkernel, q1, q2, &
     fgreens, par0, pars1, pars2, xs0, whts0, amat,tempself)
  implicit real *8 (a-h,o-z)
  integer, intent(in) :: k,ndim
  real *8, intent(in) :: wgeo(*), xs0(k,k), whts0(k,k)
  complex *16, intent(in) :: par0, pars1(*), pars2(*)
  complex *16, intent(in) :: q1(*), q2(*)
  complex *16, intent(out) :: amat(ndim*k,ndim*k)
  complex *16, intent(inout) :: tempself(k,ndim,ndim)
  external fkernel, fgreens

  !
  ! build the k by k self interaction matrix. this routine (will) builds
  ! matrices which are square-root weights by default, since it's
  ! the morally correct thing to do. this uses Bremer quadratures.
  !
  ! input:
  !   ich - the chunk number
  !   k - dimension of amat, i.e. the number of points on the chunk
  !   wgeo - geometry structure created by chunks.f
  !   fkernel - the arbitrary kernel routine, see above
  !       documention since this routine receives the greens function
  !   fgreens - the single layer greens function routine
  !       it must have the calling sequence
  !           fgreens(par0, src, targ, pars1, pars2, val)
  !       and val is assumed to be real
  !   par0, pars1, pars2 - inputs to fgreens
  !
  ! output:
  !   amat - the self-interaction matrix
  !

  call chunkaddr(ich, wgeo, k, ichunk, iadj, ider, ider2, h)

  call zdiagonal_buildmat_vec0(ndim,k, wgeo(ichunk), &
       wgeo(ider), h, fkernel, q1, q2, fgreens, par0, &
       pars1, pars2, xs0, whts0, amat,tempself)

  return
end subroutine zdiagonal_buildmat_vec

subroutine zdiagonal_buildmat_vec0(ndim,k, xys, dxys, h, &
     fkernel, q1, q2, fgreens, par0, pars1, pars2, &
     xs, whts, amat,temp)
  implicit real *8 (a-h,o-z)
  integer, intent(in) :: k,ndim
  real *8, intent(in) :: xys(2,k), dxys(2,k), h
  complex *16, intent(in) :: par0, pars1(*), pars2(*)
  complex *16, intent(in) :: q1(*), q2(*)
  real *8, intent(in) :: xs(k,k), whts(k,k)
  complex *16, intent(out) :: amat(ndim*k,ndim*k)
  complex *16, intent(inout) :: temp(k,ndim,ndim)
  external fgreens, fkernel

  real *8 :: src(10), targ(10), source_normal(10)
  real *8 :: ts(1000), ainterp(1000000), target_normal(10)
  real *8 :: xcoefs(1000)
  real *8 :: ycoefs(1000), xpcoefs(1000), ypcoefs(1000)
  complex *16 :: val(ndim,ndim), w(1000000)

  !
  ! build the k by k self interaction matrix. no square-root
  ! weighting yet... that is handled in the outer routine,
  ! xxx_xxx_direct.
  ! Note: k should not be larger than 800
  !

  done = 1
  call chunksexps(k, xys, xcoefs, ycoefs)
  call chunksexps(k, dxys, xpcoefs, ypcoefs)

  do i = 1,k

     targ(1) = xys(1,i)
     targ(2) = xys(2,i)

     xp_targ = dxys(1,i)
     yp_targ = dxys(2,i)
     ds_targ = sqrt(xp_targ**2 + yp_targ**2)

     target_normal(1) = yp_targ/ds_targ
     target_normal(2) = -xp_targ/ds_targ

     do j = 1,k

        t_src = xs(j,i)
        call legeexev(t_src, src(1), xcoefs, k-1)
        call legeexev(t_src, src(2), ycoefs, k-1)
        call legeexev(t_src, xp, xpcoefs, k-1)
        call legeexev(t_src, yp, ypcoefs, k-1)

        dd = sqrt(xp**2 + yp**2)
        source_normal(1) = yp/dd
        source_normal(2) = -xp/dd

        call fkernel(par0, src, targ, source_normal, &
             target_normal, q1, q2, fgreens, pars1, pars2, val)

        dsdt = sqrt(xp**2+yp**2)*h
        do l1=1,ndim
           do l2=1,ndim
              temp(j,l1,l2) = val(l1,l2)*whts(j,i)*dsdt
           enddo
        enddo
     enddo

     call lematrin(k, k, xs(1,i), ainterp, ts, w)
     i1 = 1

     do l1 = 1,ndim
        do l2 = 1,ndim
           call zmat_by_dmat(i1, k, temp(1,l1,l2), k, &
                ainterp, w)
           do j = 1,k
              amat((i-1)*ndim+l1,(j-1)*ndim+l2) = w(j)
           enddo
        enddo
     enddo

  enddo

  return
end subroutine zdiagonal_buildmat_vec0


!> Author:   Jabir Ali Ouassou
!> Category: Materials
!>
!> This submodule contains procedures for solving the kinetic equations in a material.

submodule (material_m) kinetic_m
  use :: bvp_m
contains
  module procedure kinetic_update
    !! This subroutine calculates the nonequilibrium propagators of a material from its kinetic equations.

    ! Numerical solver
    type(bvp_sol)                                      :: solver

    ! Propagators
    type(propagator), pointer, dimension(:)            :: Gp
    type(propagator), pointer                          :: Ga, Gb
    type(propagator), target                           :: G0

    ! State vectors
    real(wp), dimension(0:15,size(this%location))      :: vp, up
    real(wp), dimension(0:15)                          :: va, vb

    ! Jacobian matrices
    real(wp), dimension(0:15,0:15,size(this%location)) :: Jp
    real(wp), dimension(0:7,0:15)                      :: Jpa, Jaa
    real(wp), dimension(0:7,0:15)                      :: Jpb, Jbb

    ! Loop variables
    integer                                            :: n, m

    ! Instantiate a vacuum propagator
    G0 = propagator()

    ! Loop over energies
    do n=size(this%energy),1,-1
      ! Status information
      if (this%information >= 0) then
        write(stdout,'(6x,a,1x,i4,1x,a,1x,i4,1x,a,f0.5,a1)',advance='no') &
          '[',n,'/',size(this%energy),']  E = ',this%energy(n), achar(13)
        flush(stdout)
      end if

      ! Update the propagator pointers (bulk)
      Gp => this % propagator(n,:)

      ! Update the propagator pointers (left)
      if (associated(this % material_a)) then
        Ga => this % material_a % propagator(n, ubound(this % material_a % propagator,2))
      else
        Ga => G0
      end if

      ! Update the propagator pointers (right)
      if (associated(this % material_b)) then
        Gb => this % material_b % propagator(n, lbound(this % material_b % propagator,2))
      else
        Gb => G0
      end if

      ! Construct state vectors from the previous distribution (bulk)
      do m=1,size(this % location)
        vp(:7,m) = Gp(m) % h
        vp(8:,m) = Gp(m) % dh
      end do

      ! Construct state vectors from the previous distribution (left)
      va(:7) = Ga % h
      va(8:) = Ga % dh

      ! Construct state vectors from the previous distribution (right)
      vb(:7) = Gb % h
      vb(8:) = Gb % dh

      ! Construct the Jacobian of the differential equation (bulk)
      do m=1,size(this % location)
        call kinetic_jacobian(this, Gp(m), Jp(:,:,m), this % location(m))
      end do

      ! Construct the Jacobian of the differential equation (left)
      call kinetic_jacobian_a(this, Gp(lbound(Gp,1)), Ga, Jpa, Jaa)

      ! Construct the Jacobian of the differential equation (right)
      call kinetic_jacobian_b(this, Gp(ubound(Gp,1)), Gb, Jpb, Jbb)

      ! Initialize the numerical solver
      solver = bvp_init(16, 8, this%location, vp, max_num_subintervals=(size(this%location)*this%scaling))

      ! Solve the differential equation
      solver = bvp_solver(solver, equation, residual, dfdy=jacobian_equation, dbcdy=jacobian_residual, method=this%method, &
                          error_control=this%control, tol=this%tolerance, trace=this%information, stop_on_fail=.false.)

      ! Check if the calculation succeeded
      if (solver % info /= 0) then
        call error('Failed to converge! This is usually because of an ill-posed problem.')
      end if

      ! Extract the numerical solution
      call bvp_eval(solver, this % location, up)

      ! Update the convergence monitor
      this % difference = max(this % difference, maxval(abs(up - vp)))

      ! Update the nonequilibrium state
      do m=1,size(this % location)
        Gp(m) % h  = up(:7,m)
        Gp(m) % dh = up(8:,m)
      end do

      ! Deallocate workspace memory
      call bvp_terminate(solver)
    end do
  contains
    pure subroutine equation(z, u, f)
      !! Definition of the differential equation du/dz=f(z,u).
      real(wp),                  intent(in)  :: z
      real(wp), dimension(0:15), intent(in)  :: u
      real(wp), dimension(0:15), intent(out) :: f
      real(wp), dimension(0:15,0:15)         :: J

      ! Calculate the Jacobian matrix
      call jacobian_equation(z, u, J)

      ! Calculate the state derivative
      f = matmul(J, u)
    end subroutine

    pure subroutine residual(ua, ub, ra, rb)
      !! Definition of the residual equations r(u)=0.
      real(wp), dimension(0:15), intent(in)  :: ua, ub
      real(wp), dimension(0:7),  intent(out) :: ra, rb

      ! Calculate residuals from the boundary conditions (left)
      ra = matmul(Jpa, ua) - matmul(Jaa, va)

      ! Calculate residuals from the boundary conditions (right)
      rb = matmul(Jpb, ub) - matmul(Jbb, vb)
    end subroutine

    pure subroutine jacobian_equation(z, u, J)
      !! Jacobian of the differential equation J=∂f/∂u.
      real(wp),                       intent(in)  :: z
      real(wp), dimension(0:15),      intent(in)  :: u
      real(wp), dimension(0:15,0:15), intent(out) :: J

      ! Interpolate the Jacobian at this position
      J = interpolate(this % location, Jp, z)
    end subroutine

    pure subroutine jacobian_residual(ua, ub, Ja, Jb)
      !! Jacobian of the residual equations J=∂r/∂u.
      real(wp), dimension(0:15),     intent(in)  :: ua, ub
      real(wp), dimension(0:7,0:15), intent(out) :: Ja, Jb

      Ja = Jpa
      Jb = Jpb
    end subroutine
  end procedure

  pure subroutine kinetic_jacobian(this, Gp, Jp, z)
    !! This function calculates the 16×16 Jacobian of the kinetic differential equation.
    class(material),                intent(in)  :: this
    type(propagator),               intent(in)  :: Gp
    real(wp), dimension(0:15,0:15), intent(out) :: Jp
    real(wp),                       intent(in)  :: z
    complex(wp), dimension(0:7,0:7)             :: M, Q, dM, dQ, R

    ! Construct the dissipation matrices
    M  = Gp % dissipation()
    dM = Gp % dissipation_gradient()

    ! Construct the condensate matrices
    Q  = Gp % condensate()
    dQ = Gp % condensate_gradient()

    ! Construct the selfenergy matrices
    call this % kinetic_equation(Gp, R, z)

    ! Construct the Jacobian matrix
    Jp(:7,:7) =  0
    Jp(:7,8:) =  identity(8)
    Jp(8:,:7) = -re(matmul(inverse(M), dQ + R))
    Jp(8:,8:) = -re(matmul(inverse(M), dM + Q))
  end subroutine

  pure subroutine kinetic_jacobian_a(this, Gp, Ga, Jpa, Jaa)
    !! This function calculates the 8×16 Jacobian of the kinetic boundary condition (left).
    class(material),                  intent(in)  :: this
    type(propagator),                 intent(in)  :: Gp,  Ga
    real(wp),    dimension(0:7,0:15), intent(out) :: Jpa, Jaa
    complex(wp), dimension(0:7,0:7)               :: Mp, Qp, Cp, Ca

    if (this % transparent_a) then
      ! Construct a diagonal Jacobian (this side)
      Jpa(:,:7) = identity(8)
      Jpa(:,8:) = 0

      ! Construct a diagonal Jacobian (other side)
      Jaa(:,:7) = identity(8)
      Jaa(:,8:) = 0
    else
      ! Construct the interior matrices
      Mp = Gp % dissipation()
      Qp = Gp % condensate()

      ! Construct the boundary matrices
      call this % kinetic_equation_a(Gp, Ga, Cp, Ca)

      ! Construct the Jacobian (this side)
      Jpa(:,:7) = re(Cp + Qp)
      Jpa(:,8:) = re(   + Mp)

      ! Construct the Jacobian (other side)
      Jaa(:,:7) = re(Ca)
      Jaa(:,8:) = 0
    end if
  end subroutine

  pure subroutine kinetic_jacobian_b(this, Gp, Gb, Jpb, Jbb)
    !! This function calculates the 8×16 Jacobian of the kinetic boundary condition (left).
    class(material),                  intent(in)  :: this
    type(propagator),                 intent(in)  :: Gp,  Gb
    real(wp),    dimension(0:7,0:15), intent(out) :: Jpb, Jbb
    complex(wp), dimension(0:7,0:7)               :: Mp, Qp, Cp, Cb

    if (this % transparent_b) then
      ! Construct a diagonal Jacobian (this side)
      Jpb(:,:7) = identity(8)
      Jpb(:,8:) = 0

      ! Construct a diagonal Jacobian (other side)
      Jbb(:,:7) = identity(8)
      Jbb(:,8:) = 0
    else
      ! Construct the interior matrices
      Mp = Gp % dissipation()
      Qp = Gp % condensate()

      ! Construct the boundary matrices
      call this % kinetic_equation_b(Gp, Gb, Cp, Cb)

      ! Construct the Jacobian (this side)
      Jpb(:,:7) = re(Cp + Qp)
      Jpb(:,8:) = re(   + Mp)

      ! Construct the Jacobian (other side)
      Jbb(:,:7) = re(Cb)
      Jbb(:,8:) = 0
    end if
  end subroutine
end submodule


*DECK CMPTRX
      SUBROUTINE CMPTRX (IDEGBR, IDEGCR, M, A, B, C, Y, TCOS, D, W)
C***BEGIN PROLOGUE  CMPTRX
C***SUBSIDIARY
C***PURPOSE  Subsidiary to CMGNBN
C***LIBRARY   SLATEC
C***TYPE      COMPLEX (TRIX-S, CMPTRX-C)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     Subroutine to solve a system of linear equations where the
C     coefficient matrix is a rational function in the matrix given by
C     tridiagonal  ( . . . , A(I), B(I), C(I), . . . ).
C
C***SEE ALSO  CMGNBN
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  CMPTRX
C
      COMPLEX         A          ,B          ,C          ,Y          ,
     1                TCOS       ,D          ,W          ,X          ,
     2                XX         ,Z
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,Y(*)       ,
     1                TCOS(*)    ,D(*)       ,W(*)
      INTEGER KB, KC
C***FIRST EXECUTABLE STATEMENT  CMPTRX
      MM1 = M-1
      KB = IDEGBR+1
      KC = IDEGCR+1
      L = KB/KC
      LINT = 1
      DO 108 K=1,IDEGBR
         X = TCOS(K)
         IF (K .NE. L) GO TO 102
         I = IDEGBR+LINT
         XX = X-TCOS(I)
         DO 101 I=1,M
            W(I) = Y(I)
            Y(I) = XX*Y(I)
  101    CONTINUE
  102    CONTINUE
         Z = 1./(B(1)-X)
         D(1) = C(1)*Z
         Y(1) = Y(1)*Z
         DO 103 I=2,MM1
            Z = 1./(B(I)-X-A(I)*D(I-1))
            D(I) = C(I)*Z
            Y(I) = (Y(I)-A(I)*Y(I-1))*Z
  103    CONTINUE
         Z = B(M)-X-A(M)*D(MM1)
         IF (ABS(Z) .NE. 0.) GO TO 104
         Y(M) = (0.,0.)
         GO TO 105
  104    Y(M) = (Y(M)-A(M)*Y(MM1))/Z
  105    CONTINUE
         DO 106 IP=1,MM1
            I = M-IP
            Y(I) = Y(I)-D(I)*Y(I+1)
  106    CONTINUE
         IF (K .NE. L) GO TO 108
         DO 107 I=1,M
            Y(I) = Y(I)+W(I)
  107    CONTINUE
         LINT = LINT+1
         L = (LINT*KB)/KC
  108 CONTINUE
      RETURN
      END


      SUBROUTINE rlft3(data,speq,nn1,nn2,nn3,isign)
C
      INTEGER isign,nn1,nn2,nn3,istat,iw
      PARAMETER (iw=20000)
      COMPLEX data(nn1/2,nn2,nn3),speq(nn2,nn3)
C
      REAL work(6*iw+15)
C
      INTEGER i1,i2,i3,j1,j2,j3,nn(3),nnh,nnq
      DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
      COMPLEX c1,c2,h1,h2,w
C
      c1=cmplx(0.5,0.0)
      c2=cmplx(0.0,-0.5*isign)
      theta=6.28318530717959d0/dble(isign*nn1)
      wpr=-2.0d0*sin(0.5d0*theta)**2
      wpi=sin(theta)
      nnh=nn1/2
      nnq=nn1/4
      nn(1)=nnh
      nn(2)=nn2
      nn(3)=nn3
      if(isign.eq.1)then
        call pda_nfftf(3,nn,data,work,istat)
        do 12 i3=1,nn3
          do 11 i2=1,nn2
            speq(i2,i3)=data(1,i2,i3)
11        continue
12      continue
      endif
C
      if(isign.eq.-1)then
        call flip_array(data,speq,nn1,nn2,nn3)
      endif
C
      do 15 i3=1,nn3
        j3=1
        if (i3.ne.1) j3=nn3-i3+2
        wr=1.0d0
        wi=0.0d0
        do 14 i1=1,nnq+1
          j1=nnh-i1+2
          do 13 i2=1,nn2
            j2=1
            if (i2.ne.1) j2=nn2-i2+2
            if(i1.eq.1)then
              h1=c1*(data(1,j2,j3)+conjg(speq(i2,i3)))
              h2=c2*(data(1,j2,j3)-conjg(speq(i2,i3)))
              data(1,j2,j3)=h1+h2
              speq(i2,i3)=conjg(h1-h2)
            else
              h1=c1*(data(j1,j2,j3)+conjg(data(i1,i2,i3)))
              h2=c2*(data(j1,j2,j3)-conjg(data(i1,i2,i3)))
              data(j1,j2,j3)=h1+w*h2
              data(i1,i2,i3)=conjg(h1-w*h2)
            endif
13        continue
          wtemp=wr
          wr=wr*wpr-wi*wpi+wr
          wi=wi*wpr+wtemp*wpi+wi
          w=cmplx(sngl(wr),sngl(wi))
14      continue
15    continue
C
      if(isign.eq.1)then
        call flip_array(data,speq,nn1,nn2,nn3)
      endif
C
      if(isign.eq.-1)then
        call pda_nfftb(3,nn,data,work,istat)
      endif
      return
      END
C
      SUBROUTINE FLIP_ARRAY(DATA,SPEQ,NN1,NN2,NN3)
C
      IMPLICIT NONE
C
      INTEGER NN1,NN2,NN3,I1,I2,I3,J1,J2,J3,NNH
      COMPLEX DATA(NN1/2,NN2,NN3),SPEQ(NN2,NN3),W
C
      nnh=nn1/2
      do 13 i1=1,nnh/2+1
        do 14 i3=1,nn3
          do 15 i2=1,nn2
            j1=1
            if (i1.ne.1) j1=nnh-i1+2
            w=data(i1,i2,i3)
            data(i1,i2,i3)=data(j1,i2,i3)
            data(j1,i2,i3)=w
15        continue
14      continue
13    continue
      do 10 i2=1,nn2/2+1
        do 11 i3=1,nn3
          j2=1
          if (i2.ne.1) j2=nn2-i2+2
          w=speq(i2,i3)
          speq(i2,i3)=speq(j2,i3)
          speq(j2,i3)=w
          do 12 i1=1,nnh
            w=data(i1,i2,i3)
            data(i1,i2,i3)=data(i1,j2,i3)
            data(i1,j2,i3)=w
12        continue
11      continue
10    continue
      do 16 i3=1,nn3/2+1
        j3=1
        if (i3.ne.1) j3=nn3-i3+2
        do 17 i2=1,nn2
          w=speq(i2,i3)
          speq(i2,i3)=speq(i2,j3)
          speq(i2,j3)=w
          do 18 i1=1,nnh
            w=data(i1,i2,i3)
            data(i1,i2,i3)=data(i1,i2,j3)
            data(i1,i2,j3)=w
18        continue
17      continue
16    continue
C
      return
      end


subroutine setgrid

! Initialize vertical grid

use vars
use params

implicit none

real latit, long
integer i,j,it,jt,k, kmax

if(nrestart.eq.0) then

 if(doconstdz) then

    z(1) = 0.5*dz
    do k=2,nz
     z(k)=z(k-1)+dz
    end do

 else

    open(8,file='./'//trim(case)//'/grd',status='old',form='formatted')
    do k=1,nz
      read(8,fmt=*,end=111) z(k)
      kmax=k
    end do
    goto 222
111 do k=kmax+1,nz
     z(k)=z(k-1)+(z(k-1)-z(k-2))
    end do
222 continue
    close (8)

 end if

end if

if(.not.doconstdz) dz = 0.5*(z(1)+z(2))

do k=2,nzm
   adzw(k) = (z(k)-z(k-1))/dz
end do
adzw(1) = 1.
adzw(nz) = adzw(nzm)
adz(1) = 1.
do k=2,nzm-1
   adz(k) = 0.5*(z(k+1)-z(k-1))/dz
end do
adz(nzm) = adzw(nzm)
zi(1) = 0.
do k=2,nz
   zi(k) = zi(k-1) + adz(k-1)*dz
end do

do k=1,nzm
  gamaz(k)=ggr/cp*z(k)
end do

if(dofplane) then

  if(fcor.eq.-999.) fcor = 4*pi/86400.*sin(latitude0*pi/180.)
  fcorz = 0.
  if(docoriolisz) fcorz =  sqrt(4.*(2*pi/(3600.*24.))**2-fcor**2)
  fcory(:) = fcor
  fcorzy(:) = fcorz
  longitude(:,:) = longitude0

else

 call task_rank_to_index(rank,it,jt)

 do j=0,ny
     latit=latitude0+dy*(j+jt-(ny_gl+YES3D-1)/2-1)*2.5e-8*360.
     fcory(j)= 4.*pi/86400.*sin(latit*pi/180.)
     fcorzy(j) = 0.
     if(j.ne.0.and.docoriolisz) fcorzy(j) = sqrt(4.*(2*pi/(3600.*24.))**2-fcory(j)**2)
 end do

end if ! dofplane

if (doradlat) then
 call task_rank_to_index(rank,it,jt)
 do j=1,ny
     latitude(:,j) = latitude0+dy*(j+jt-(ny_gl+YES3D-1)/2-1)*2.5e-8*360.
  end do
else
  latitude(:,:) = latitude0
end if

if (doradlon) then
 call task_rank_to_index(rank,it,jt)
 do i=1,nx
     longitude(i,:) = longitude0+dx/cos(latitude0*pi/180.)* &
                            (i+it-nx_gl/2-1)*2.5e-8*360.
  end do
else
  longitude(:,:) = longitude0
end if

end


SUBROUTINE sweep(g)

!-------------------------------------------------------------
!
!  Sweeps across the 2-D matrix
!   Starts at top right corner (mu, eta < 0), then sweeps
!   down all rows, accounting for reflection if necessary. Then
!   sweeps up all rows for eta>0
!
!-------------------------------------------------------------

USE invar
USE solvar
IMPLICIT NONE
INTEGER, INTENT(IN) :: g
INTEGER :: xs, xe, ys, ye, incx, incy, ord, nfy, quad
INTEGER :: i, j, k, l, m, n, sgm, sge, ydir, xdir, mltx, mlty
INTEGER :: ieq, ll, col, indx, jndx, info
REAL*8, DIMENSION(ordsq, ordsq) :: a
REAL*8, DIMENSION(ordsq) :: b
REAL*8, DIMENSION(0:lambda) :: fx
REAL*8, DIMENSION(nx, 0:lambda, 2) :: fy
REAL*8 :: sig, mu, eta, x, y, c, sgn, factor
INTEGER, DIMENSION(ordsq) :: piv
REAL*8, DIMENSION(ordsq) :: wrk

! Initialize the flux solution to zero
f(:,:,:,:,g) = 0.0

! Start with loop over all angles
DO n = 1, apo
   ! Set up the angles
   mu  = ang(n,1)
   eta = ang(n,2)

   ! Initialize the incoming y-flux for top bc (Q3 and Q4)
   DO k = 0,lambda
      DO i = 1, nx
         indx = (n-1)*nx*order + (i-1)*order + 1 + k
         fy(i,k,1) = psi3(indx)
         fy(i,k,2) = psi4(indx)
      END DO
   END DO

   ! Loop over eta<0 then eta>0
   DO ydir = 1, 2
      IF (ydir == 1) THEN
         ys = ny
         ye = 1
         incy = -1
      ELSE IF (ydir == 2) THEN
         ys = 1
         ye = ny
         incy = 1
         ! Reset incoming y-flux for the bottom bc (Q1 and Q2)
         DO k = 0, lambda
            DO i = 1, nx
               indx = (n-1)*nx*order + (i-1)*order + 1 + k
               fy(i,k,1) = psi2(indx)
               fy(i,k,2) = psi1(indx)
            END DO
         END DO
      END IF

   ! Start the loop in negative y-direction, then do positve y-direction
   DO j = ys, ye, incy
      y = dy(j)

      ! Set the incoming x-flux with the right bc depending on ydir
      IF (ydir == 1) THEN
         ! Quadrant 3
         DO l = 0, lambda
            indx = apo*nx*order + (n-1)*ny*order + (j-1)*order + 1 + l
            fx(l) = psi3(indx)
         END DO
      ELSE IF (ydir == 2) THEN
         ! Quadrant 2
         DO l = 0, lambda
            indx = apo*nx*order + (n-1)*ny*order + (j-1)*order + 1 + l
            fx(l) = psi2(indx)
         END DO
      END IF

      ! Perform two loops, one in negative x-direction, then positive
      DO xdir = 1, 2
         IF (xdir == 1) THEN
            xs = nx
            xe = 1
            incx = -1
            nfy = 1
            IF (ydir == 1) quad = 3
            IF (ydir == 2) quad = 2
         ELSE IF (xdir == 2) THEN
            xs = 1
            xe = nx
            incx = 1
            nfy = 2
            IF (ydir == 1) quad = 4
            IF (ydir == 2) quad = 1
            ! Reset the incoming x-flux for the left bc
            IF (ydir == 1) THEN
               ! Quadrant 1
               DO l = 0, lambda
                  indx = apo*nx*order + (n-1)*ny*order + (j-1)*order + 1 + l
                  fx(l) = psi4(indx)
               END DO
            ELSE IF (ydir == 2) THEN
               ! Quadrant 2
               DO l = 0, lambda
                  indx = apo*nx*order + (n-1)*ny*order + (j-1)*order + 1 + l
                  fx(l) = psi1(indx)
               END DO
            END IF
         END IF

      ! Start the loop in the negative x-direction
      DO i = xs, xe, incx
         x = dx(i)
         m = mat(i,j)
         sig = sigt(m,g)
         ord = lambda
         c = sigs(m,g,g)/sig     ! Scattering ratio

         ! Call for the calculation of the spatial weights
         CALL weight(ord,x,y,sig,mu,eta)

         ! Begin constructing Matrix Equation
         sgm = incx
         sge = incy
         ieq = 0

         ! Initialize 'a' matrix
         a = 0.0

         DO k = 0, lambda
            mltx = sgm**k

            DO l = 0, lambda
               mlty = sge**l
               ieq = ieq + 1

               ! Contributions from outgoing fluxes
               ! Even summations
               DO ll = 0, lambda, 2
                  ! x-constant surface
                  col = order*ll + l + 1
                  a(ieq,col) = a(ieq,col) + mltx*(2.0*ll+1.0)/(ex*(1.0+alpha))
                  ! y-constant surface
                  col = order*k + ll + 1
                  a(ieq,col) = a(ieq,col) + mlty*(2.0*ll+1.0)/(ey*(1.0+beta))
               END DO

               ! Odd summations
               DO ll = 1, lambda, 2
                  ! x-constant surface
                  col = order*ll + l + 1
                  a(ieq,col) = a(ieq,col) + mltx*(2.0*ll+1.0)*sgm*alpha/(ex*(1.0+alpha))
                  ! y-constant surface
                  col = order*k + ll + 1
                  a(ieq,col) = a(ieq,col) + mlty*(2.0*ll+1.0)*sge*beta/(ey*(1.0+beta))
               END DO

               ! Contributions from two summations
               ! x-summations
               DO ll = MOD((k+1),2), (k-1), 2
                  col = order*ll + l + 1
                  a(ieq,col) = a(ieq,col) - sgm*(2.0*ll+1.0)/ex
               END DO
               ! y-summations
               DO ll = MOD((l+1),2), (l-1), 2
                  col = order*k + ll + 1
                  a(ieq,col) = a(ieq,col) - sge*(2.0*ll+1.0)/ey
               END DO

               ! Contribution along the diagonal -- total interaction
               a(ieq,ieq) = a(ieq,ieq) + 1.0
               ! Finished calculating the 'a' matrix LHS

               ! Begin composing the RHS vector
               ! Initially set b to the scattering + fixed source
               b(ieq) = c*e(i,j,k,l) + s(i,j,k,l,g)/sig
               ! Add contributions from incoming fluxes due to elimination
               b(ieq) = b(ieq) + mltx*(1.0-alpha)*fx(l)/(2.0*ex*(1.0+alpha))
               b(ieq) = b(ieq) + mlty*(1.0-beta)*fy(i,k,nfy)/(2.0*ey*(1.0+beta))
               ! Add contributions from incoming fluxes
               b(ieq) = b(ieq) + mltx*((-1)**k)*fx(l)/(2.0*ex)
               b(ieq) = b(ieq) + mlty*((-1)**l)*fy(i,k,nfy)/(2.0*ey)
               ! Finished calculating the b vector, RHS

            END DO
         END DO

         ! Make the matrix symmetric
         IF (order /= 1) THEN
            DO indx = 1, order
               sgn = 1.0
               jndx = indx/2
               jndx = indx - 2*jndx
               IF (jndx == 0) sgn = -1.0
               DO jndx = 1, order
                  factor = sgn*(2.0*indx-1.0)*(2.0*jndx-1.0)
                  ieq = jndx + (indx - 1)*order
                  sgn = -sgn
                  DO col = 1, ordsq
                     a(ieq,col) = factor*a(ieq,col)
                  END DO
                  b(ieq) = factor*b(ieq)
               END DO
            END DO
         END IF

         ! Asymmetric solver
           ! CALL dgesv(ordsq,1,a,ordsq,ipiv,b,ordsq,info)
         ! Symmetric solver
         ! Need to use different lapack solver for lambda>0 because of positive
         ! definite problem
         IF (lambda == 0) THEN
            CALL dposv('U',ordsq,1,a,ordsq,b,ordsq,info)
            IF (info /= 0) THEN
               WRITE (8,'(//,1X,A)') "WARNING: matrix either has illegal value or is singular."
               warn = warn + 1
               IF (info > 0) THEN
                  WRITE (8,'(2X,A,/)') "a-Matrix may not be positive definite, use LAPACK routine for symmetric indefinite."
                  CALL dsysv('U',ordsq,1,a,ordsq,piv,b,ordsq,wrk,ordsq,info)
                  IF (info /= 0) THEN
                     WRITE (8,'(/,1X,A)') "ERROR: Unable to solve system of equations in sweep for current cell."
                     STOP
                  END IF
               ELSE
                  WRITE (8,'(//,1X,A)') "ERROR: matrix has unresolved error and problem not solved."
                  STOP
               END IF
            END IF
         ELSE IF (lambda > 0) THEN
            CALL dsysv('U',ordsq,1,a,ordsq,piv,b,ordsq,wrk,ordsq,info)
            IF (info /= 0) THEN
               WRITE (8,'(/,1X,A)') "ERROR: matrix either has illegal value or is singular."
               STOP
            END IF
         END IF

         ! Update the scalar flux solution
         DO k = 0, lambda
            DO l = 0, lambda
               indx = order*k + l + 1
               f(i,j,k,l,g) = f(i,j,k,l,g) + w(n)*b(indx)
            END DO
         END DO

         ! Compute the outgoing fluxes with the WDD equations
         ! Outgoing flux moments in x-dir
         DO l = 0, lambda
            ! Contribution from incoming flux
            fx(l) = -((1.0 - alpha)/(1.0 + alpha))*fx(l)
            ! Contribution from even summation
            DO ll = 0, lambda, 2
               indx = order*ll + l + 1
               fx(l) = fx(l) + 2.0*(2.0*ll + 1.0)*b(indx)/(1.0+alpha)
               ! Contribution from odd summation
               IF ((ll+1) <= lambda) THEN
                  fx(l) = fx(l) + 2.0*(2.0*ll+3.0)*sgm*alpha*b(indx+order)/(1.0+alpha)
               END IF
            END DO
         END DO

         ! Outgoing flux moments in y-dir
         DO k = 0, lambda
            ! Contribution from incoming flux
            fy(i,k,nfy) = -((1.0-beta)/(1.0+beta))*fy(i,k,nfy)
            ! Contribution from even summation
            DO ll = 0, lambda, 2
               indx = order*k + ll + 1
               fy(i,k,nfy) = fy(i,k,nfy) + 2.0*(2.0*ll+1.0)*b(indx)/(1.0+beta)
               ! Contribution from odd summation
               IF ((ll+1) <= lambda) THEN
                  fy(i,k,nfy) = fy(i,k,nfy) + 2.0*(2.0*ll+3.0)*sge*beta*b(indx+1)/(1.0+beta)
               END IF
            END DO
         END DO

         ! Store the new angular fluxes at ye and xe
         IF (j == ye) THEN
            indx = (n-1)*nx*order + (i-1)*order
            psio((indx+1):(indx+order),quad,g) = fy(i,:,nfy)
         END IF
         IF (i == xe) THEN
            indx = apo*nx*order + (n-1)*ny*order + (j-1)*order
            psio((indx+1):(indx+order),quad,g) = fx(:)
         END IF

      ! End loop over x cells
      END DO
      ! End loop over negative and positive x-directions
      END DO

   ! End loop over y cells
   END DO

   ! End loop over negative and positve y-directions
   END DO

! End loop over angles
END DO

RETURN
END SUBROUTINE sweep


      function fortran() bind(C)
      use, intrinsic :: iso_c_binding
      real(kind=c_double) :: fortran
      fortran = 2.0**rand(1)
      end function fortran


C$Id$
************************************************************************
*                                                                      *
      subroutine ecp_s2ccoef (n,Xc2s,Xs2c,tmp,nc,df)
*                                                                      *
*   Set up inverse transformation, from sphericals to cartesians       *
*                                                                      *
*   n (inp) - angular momentum of s.s.h.                               *
*   Xc2s (inp) - coefficents of cartesian to spherical transformation  *
*   Xs2c (out) - coefficents of spherical to cartesian transformation  *
*   tmp (scr) - array for storing cartesian overlap matrix             *
*   nc (inp) - number of cartesians, (l+1)*(l+2)/2                     *
*   df (inp) - array of double factorials                              *
*                                                                      *
*   Written by K. G. Dyall                                             *
*                                                                      *
************************************************************************
      implicit none
      integer i,ia,ib,ii,ja,jb,jj,ka,kb,kk,n,nc
      double precision d,one,zero
      double precision Xc2s(nc,nc),Xs2c(nc,nc),tmp(nc*nc),df(0:n+1)
      parameter (zero = 0.0D0, one = 1.0D0)
*
      i = 0
      d = df(n+1)
      do ia = n,0,-1
        do ja = n-ia,0,-1
          ka = n-ia-ja
          do ib = n,0,-1
            ii = ia+ib
            do jb = n-ib,0,-1
              jj = ja+jb
              kb = n-ib-jb
              kk = ka+kb
              i = i+1
              if ((mod(ii,2) .eq. 0) .and.
     &            (mod(jj,2) .eq. 0) .and.
     &            (mod(kk,2) .eq. 0)) then
                tmp(i) = df(ii/2)*df(jj/2)*df(kk/2)/d
              else
                tmp(i) = zero
              end if
            end do
          end do
        end do
      end do
      call dgemm ('T','N',nc,nc,nc,one,Xc2s,nc,tmp,nc,zero,Xs2c,nc)
*
      return
      end


program get_qw

  use libatoms_module
  use steinhardt_nelson_qw_module

  implicit none

  !local variables
  type(Dictionary)      :: params
  type(Atoms) :: at
  type(Cinoutput) :: infile, outfile
  character(STRING_LENGTH)   :: atfile_in
  character(STRING_LENGTH)   :: central_mask, neighbour_mask
  integer  :: stat, n_string
  real(dp) :: r_cut, r_cut_min, summa_q, summa_w, q_global, w_glob
  real(dp), dimension(:), pointer :: q, w
  integer :: l, i , error, i_config, iat
  logical :: calc_QWave, print_QWxyz
  logical, allocatable, dimension(:) :: c_mask, n_mask

  call system_initialise(PRINT_NORMAL)
  call verbosity_push(PRINT_NORMAL)

  call initialise(params)
  call param_register(params, 'atfile_in', PARAM_MANDATORY, atfile_in,'') ! xyz input filename
  call param_register(params, 'r_cut', PARAM_MANDATORY, r_cut,'') ! cutoff for neighbours taken into account
  call param_register(params, 'l', PARAM_MANDATORY, l,'') ! l=2, 4, 6, 8, ....
  call param_register(params, 'r_cut_min', '0.0', r_cut_min,'') ! minimum cutoff within which atoms are not considered
  call param_register(params, 'calc_QWave', 'F', calc_QWave,'') ! average bond order params over the configuration
  call param_register(params, 'print_QWxyz', 'F', print_QWxyz,'') ! print an xyz with all QW as properties
  call param_register(params, 'central_mask', 'all', central_mask,'') ! which type of atom can be central
  call param_register(params, 'neighbour_mask', 'all', neighbour_mask,'') ! which type of atoms are neighbours

  if (.not. param_read_args(params, check_mandatory = .true.)) then
       call print("Usage: get_qw [atfile_in] [r_cut] [l] [r_cut_min=0.0] [calc_QWave=F] [print_QWxyz=F] &
                 &[central_mask=all] [neighbour_mask=all]" ,PRINT_SILENT)
       call system_abort('Exit: Mandatory argument(s) missing...')
  endif
  call finalise(params)

  call initialise(infile,atfile_in)

!     read(COMMAND_ARG(4),*) averageL
!     read(COMMAND_ARG(5),*) maximalQ
!     read(COMMAND_ARG(6),*) atom_mask
!     read(COMMAND_ARG(7),*) print_qw

  if (print_QWxyz) then
     if (central_mask /= 'all' .or. neighbour_mask /= 'all') &
        & call system_abort("if qw to be printed to an xyz file, no mask should be used. Use 'all' option (default)")
     call initialise(outfile,"qw"//l//"_"//trim(atfile_in),action=output)
  endif

  i_config = 0
  do
     call read(at, infile, error=error)
     if (error /= 0) then
        exit
     endif
     i_config = i_config + 1

     if (i_config == 1) then ! do the mask initialisation for the first config.

        allocate(c_mask(at%N), n_mask(at%N))
        c_mask = .true. ! default: all atoms taken into account
        n_mask = .true. ! default: all atoms taken into account
        if (central_mask /= 'all') then
           !call print('Selecting all '//trim(ElementName(at%Z(iat)))//' atoms (Z = '//at%Z(iat)//') as the central atom')
           do iat = 1,at%N
              if (central_mask /= trim(ElementName(at%Z(iat)))) c_mask(iat)=.false.
           enddo
        endif
        !write(*,*) c_mask
        if (neighbour_mask /= 'all') then
           !call print('Selecting all '//trim(ElementName(at%Z(iat)))//' atoms (Z = '//at%Z(iat)//') as the central atom')
           do iat = 1,at%N
              if (neighbour_mask /= trim(ElementName(at%Z(iat)))) n_mask(iat)=.false.
           enddo
        endif
        !write(*,*) n_mask

     endif

     call set_cutoff(at,r_cut)
     call calc_connect(at)
     call calc_qw(at,l,do_q=.true.,do_w=.true.,cutoff=r_cut,min_cutoff=r_cut_min,mask=c_mask, &
                  & mask_neighbour=n_mask,cutoff_transition_width=0.0_dp) ! l optional, default 4 (q4 es w4)

     if( .not. assign_pointer(at, 'q'//l, q) ) &
             & call system_abort('could not assign pointer to atoms object')
     if( .not. assign_pointer(at, 'w'//l, w) ) &
             & call system_abort('could not assign pointer to atoms object')

     do i = 1,size(w)
        if (isnan(w(i))) w(i) = 0.0_dp
     enddo
     do i = 1,size(q)
        if (isnan(q(i))) q(i) = 0.0_dp
     enddo

     if (calc_QWave) then ! print average QW parameters

        summa_q = 0.0_dp
        summa_w = 0.0_dp
        do iat = 1,at%N
           ! average only atoms with atom_mask true
           if (c_mask(iat)) then
              summa_q = summa_q + q(iat)
              summa_w = summa_w + w(iat)
           endif
        enddo
        write(*,*) summa_q/count(c_mask) , summa_w/count(c_mask)

     else
        do iat = 1,at%N
           if (c_mask(iat) ) then
              write(*,*) i_config, q(iat), w(iat)
           endif
        enddo
        write(*,*)
        write(*,*)

     endif

     if (print_QWxyz) call write(at,outfile, properties="species:pos:q"//l//":w"//l)
     call finalise(at)
  enddo

  if (print_QWxyz) call finalise(outfile)
  call system_finalise()

end program get_qw


SUBROUTINE conk(n,i,xs,incx,mu,ktmp)

!-----------------------------------------------------------
!
! Constructs the ktmp row for a given octant and cell and
!  returns the values to afcm.
!
! Takes in from afcm: All the computed values not in solvar
!     n,i,xs,incx,mu
! Returns to afcm a temporary matrix ktmp that fills in the
!  particular ktmp#
!
!------------------------------------------------------------

USE invar
USE solvar
IMPLICIT NONE
INTEGER, INTENT(IN) :: n, i, xs, incx
INTEGER :: l
REAL*8, INTENT(IN) :: mu
REAL*8 :: wt, plm1, pl
REAL*8, DIMENSION(sord), INTENT(OUT) :: ktmp

! Initialize ktmp
ktmp = 0.0

! Set the weight
wt = w(n)

! All the bc matrices and gamma matrices needed come from solvar

! Perform the operations to update from the different BCs
IF (i /= xs) THEN
   plm1 = 0.0
   pl   = 1.0
   DO l = 0, anord
      ktmp(l+1) = ktmp(l+1) + wt*pl*gax*xbco
      CALL legpoly(l,incx,mu,plm1,pl)
   END DO
ELSE IF (i == xs) THEN
   plm1 = 0.0
   pl   = 1.0
   DO l = 0, anord
      ktmp(l+1) = ktmp(l+1) + wt*pl*gax
      CALL legpoly(l,incx,mu,plm1,pl)
   END DO
END IF

! Finished updating ktmp for given cell
RETURN

END SUBROUTINE conk


	FUNCTION PR_XVFR  ( ceil, vsby )
C************************************************************************
C* PR_XVFR								*
C*									*
C* This function computes LIFR/IFR/MVFR/VFR flight conditions based on  *
C* ceiling and visibility.                                              *
C*									*
C* REAL PR_XVFR  ( CEIL, VSBY )						*
C*									*
C* Input parameters:							*
C*      CEIL		REAL		Ceiling in hundreds of feet     *
C*	VSBY		REAL    	Visibility in statute miles	*
C*									*
C* Output parameters:							*
C*	PR_XVFR		REAL	        Flight conditions index value   *
C*                                        0 = LIFR                      *
C*                                        1 = IFR                       *
C*                                        2 = MVFR                      *
C*                                        3 = VFR                       *
C*									*
C**									*
C* Log:									*
C* J. Green/AWC		6/99	Original source code			*
C* D. Kidwell/NCEP	7/99	Restructured         			*
C* D. Kidwell/NCEP	5/00	Added LIFR (Low Instrument Flight Rules)*
C* L. Hinson/AWC        1/14    Added fix for comparisons to CIG/VSBY   *
C*                              on borderline MVFR thresholds.          *
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
        INCLUDE         'ERMISS.FNC'
C       This parameter is used in the .le. comparisons to VSBY/CIG
C       on borderline MVFR conditions.  There was a problem found with
C       system not storing 5 SM as exactly 5.0, but something slightly
C       higher causing problems with .le comparisons.  This caused
C       certain TAFs/METARs to read VFR, when they should be MVFR.
C
        PARAMETER       ( EPS = .01 )
C------------------------------------------------------------------------
C*      Check for missing values.
C
	PR_XVFR = RMISSD
	IF  ( ERMISS ( ceil ) .and. ERMISS ( vsby ) ) THEN
	    RETURN
	END IF
C
C*      Compute categorical flight rules.
C*	Check the ceiling value.
C
	vc = RMISSD
      	IF ( .not. ( ERMISS ( ceil ) ) ) THEN
	    IF ( ceil .lt. 0. ) THEN
	      ELSE IF ( ceil .lt. 5. )  THEN
		vc = 0.
              ELSE IF ( ceil .lt. 10. ) THEN
		vc = 1.
	      ELSE IF ( ceil .le. (30. + EPS) ) THEN
		vc = 2.
	      ELSE IF ( ( vsby .gt. (5. + EPS) ) .or.
     +                  ( vsby .lt. 0. ) .or.
     +			( ERMISS ( vsby ) ) ) THEN
		PR_XVFR = 3.
		RETURN
	    END IF
	END IF
C
C*	Check the visibility value.
C
	vs = RMISSD
	IF ( .not. ERMISS ( vsby ) ) THEN
	    IF ( vsby .lt. 0. ) THEN
	      ELSE IF ( vsby .lt. 1. ) THEN
		vs = 0.
	      ELSE IF ( vsby .lt. 3. ) THEN
		vs = 1.
	      ELSE IF ( vsby .le. (5. + EPS) ) THEN
		vs = 2.
	      ELSE
		vs = 3.
	    END IF
	END IF
C
C*	Determine the more restrictive of the two values.
C
	IF ( ERMISS ( vc ) ) THEN
	    PR_XVFR = vs
	  ELSE IF ( ERMISS ( vs ) ) THEN
	    PR_XVFR = vc
	  ELSE
	    PR_XVFR = AMIN1 ( vc, vs )
	END IF
C*
	RETURN
	END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2019 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine beamintscheme(lakonl,mint3d,npropstart,prop,
     &  kk,xi,et,ze,weight)
!
!     provides the integration scheme for beams with a cross section
!     which is not rectangular nor elliptical
!
!     mint3d: number of integration points (returned if kk=0)
!     xi,et,ze: local coordinates of integration point kk
!     weight: weight for integration point kk
!
      implicit none
!
      character*8 lakonl
!
      integer mint3d,npropstart,jj,kk
!
      real*8 prop(*),xi,et,ze,weight,ratio,ratio2,dtheta,theta,r,
     &  t1,t2,t3,t4,a,b
!
      intent(in) lakonl,npropstart,prop,
     &  kk
!
      intent(inout) weight,xi,et,ze,mint3d
!
      if(lakonl(8:8).eq.'P') then
!
!        pipe cross section
!
         if(kk.eq.0) then
            mint3d=16
            return
         endif
!
!        ratio of inner radius to outer radius
!
         ratio=(prop(npropstart+1)-prop(npropstart+2))/
     &              prop(npropstart+1)
         ratio2=ratio*ratio
!
         if(kk.gt.8) then
            jj=kk-8
            xi=1.d0/dsqrt(3.d0)
         else
            jj=kk
            xi=-1.d0/dsqrt(3.d0)
         endif
!
!        pi/4
!
         dtheta=datan(1.d0)
!
         theta=(jj-1)*dtheta
         r=dsqrt((ratio2+1.d0)/2.d0)
!
         et=r*dcos(theta)
         ze=r*dsin(theta)
         weight=dtheta*(1.d0-ratio2)/2.d0
c
c     Box cross section
      elseif(lakonl(8:8).eq.'B') then
         if(kk.eq.0) then
           mint3d=32
           return
         endif
!
!        2 pts in long direction xi
!
         if(kk.gt.16) then
            jj=kk-16
            xi=1.d0/dsqrt(3.d0)
         else
            jj=kk
            xi=-1.d0/dsqrt(3.d0)
         endif
!
!        pts in cross sections
!
         a=prop(npropstart+1)
         b=prop(npropstart+2)
         t1=prop(npropstart+3)
         t2=prop(npropstart+4)
         t3=prop(npropstart+5)
         t4=prop(npropstart+6)
!
         if(jj.eq.1)then
            et = -(t4-b)/b
            ze = -(t1-a)/a
            weight = -((((-2*a)+2*t1+t3)*t4+t1*t2-2*b*t1)/(a*b))/6.0d+0
         elseif(jj.eq.2)then
            et = -((3*t4-t2-2*b)/b)/4.0d+0
            ze = -(t1-a)/a
            weight = -((2*t1*t4+2*t1*t2-4*b*t1)/(a*b))/3.0d+0
         elseif(jj.eq.3)then
            et = -((t4-t2)/b)/2.0d+0
            ze = -(t1-a)/a
            weight = -((t1*t4+t1*t2-2*b*t1)/(a*b))/3.0d+0
         elseif(jj.eq.4)then
            et = -((t4-3*t2+2*b)/b)/4.0d+0
            ze = -(t1-a)/a
            weight = -((2*t1*t4+2*t1*t2-4*b*t1)/(a*b))/3.0d+0
         elseif(jj.eq.5)then
            et = (t2-b)/b
            ze = -(t1-a)/a
            weight = -((t1*t4+t2*t3+(2*t1-2*a)*t2-2*b*t1)/(a*b))/6.0d+0
         elseif(jj.eq.6)then
            et = (t2-b)/b
            ze = ((t3-3*t1+2*a)/a)/4.0d+0
            weight = -((2*t2*t3+(2*t1-4*a)*t2)/(a*b))/3.0d+0
         elseif(jj.eq.7)then
            et = (t2-b)/b
            ze = ((t3-t1)/a)/2.0d+0
            weight = -((t2*t3+(t1-2*a)*t2)/(a*b))/3.0d+0
         elseif(jj.eq.8)then
            et = (t2-b)/b
            ze = ((3*t3-t1-2*a)/a)/4.0d+0
            weight = -((2*t2*t3+(2*t1-4*a)*t2)/(a*b))/3.0d+0
         elseif(jj.eq.9)then
            et = (t2-b)/b
            ze = (t3-a)/a
            weight = -((t3*t4+(2*t2-2*b)*t3+(t1-2*a)*t2)/(a*b))/6.0d+0
         elseif(jj.eq.10)then
            et = -((t4-3*t2+2*b)/b)/4.0d+0
            ze = (t3-a)/a
            weight = -((2*t3*t4+(2*t2-4*b)*t3)/(a*b))/3.0d+0
         elseif(jj.eq.11)then
            et = -((t4-t2)/b)/2.0d+0
            ze = (t3-a)/a
            weight = -((t3*t4+(t2-2*b)*t3)/(a*b))/3.0d+0
         elseif(jj.eq.12)then
            et = -((3*t4-t2-2*b)/b)/4.0d+0
            ze = (t3-a)/a
            weight = -((2*t3*t4+(2*t2-4*b)*t3)/(a*b))/3.0d+0
         elseif(jj.eq.13)then
            et = -(t4-b)/b
            ze = (t3-a)/a
            weight = -((((-2*a)+t1+2*t3)*t4+(t2-2*b)*t3)/(a*b))/6.0d+0
         elseif(jj.eq.14)then
            et = -(t4-b)/b
            ze = ((3*t3-t1-2*a)/a)/4.0d+0
            weight = -(((2*t3+2*t1-4*a)*t4)/(a*b))/3.0d+0
         elseif(jj.eq.15)then
            et = -(t4-b)/b
            ze = ((t3-t1)/a)/2.0d+0
            weight = -(((t3+t1-2*a)*t4)/(a*b))/3.0d+0
         elseif(jj.eq.16)then
            et = -(t4-b)/b
            ze = ((t3-3*t1+2*a)/a)/4.0d+0
            weight = -(((2*t3+2*t1-4*a)*t4)/(a*b))/3.0d+0
         endif
      endif
!
      return
      end


*> \brief \b DLATM2
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       DOUBLE PRECISION FUNCTION DLATM2( M, N, I, J, KL, KU, IDIST,
*                        ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
*
*       .. Scalar Arguments ..
*
*       INTEGER            I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N
*       DOUBLE PRECISION   SPARSE
*       ..
*
*       .. Array Arguments ..
*
*       INTEGER            ISEED( 4 ), IWORK( * )
*       DOUBLE PRECISION   D( * ), DL( * ), DR( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    DLATM2 returns the (I,J) entry of a random matrix of dimension
*>    (M, N) described by the other parameters. It is called by the
*>    DLATMR routine in order to build random test matrices. No error
*>    checking on parameters is done, because this routine is called in
*>    a tight loop by DLATMR which has already checked the parameters.
*>
*>    Use of DLATM2 differs from SLATM3 in the order in which the random
*>    number generator is called to fill in random matrix entries.
*>    With DLATM2, the generator is called to fill in the pivoted matrix
*>    columnwise. With DLATM3, the generator is called to fill in the
*>    matrix columnwise, after which it is pivoted. Thus, DLATM3 can
*>    be used to construct random matrices which differ only in their
*>    order of rows and/or columns. DLATM2 is used to construct band
*>    matrices while avoiding calling the random number generator for
*>    entries outside the band (and therefore generating random numbers
*>
*>    The matrix whose (I,J) entry is returned is constructed as
*>    follows (this routine only computes one entry):
*>
*>      If I is outside (1..M) or J is outside (1..N), return zero
*>         (this is convenient for generating matrices in band format).
*>
*>      Generate a matrix A with random entries of distribution IDIST.
*>
*>      Set the diagonal to D.
*>
*>      Grade the matrix, if desired, from the left (by DL) and/or
*>         from the right (by DR or DL) as specified by IGRADE.
*>
*>      Permute, if desired, the rows and/or columns as specified by
*>         IPVTNG and IWORK.
*>
*>      Band the matrix to have lower bandwidth KL and upper
*>         bandwidth KU.
*>
*>      Set random entries to zero as specified by SPARSE.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>           Number of rows of matrix. Not modified.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>           Number of columns of matrix. Not modified.
*> \endverbatim
*>
*> \param[in] I
*> \verbatim
*>          I is INTEGER
*>           Row of entry to be returned. Not modified.
*> \endverbatim
*>
*> \param[in] J
*> \verbatim
*>          J is INTEGER
*>           Column of entry to be returned. Not modified.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*>          KL is INTEGER
*>           Lower bandwidth. Not modified.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*>          KU is INTEGER
*>           Upper bandwidth. Not modified.
*> \endverbatim
*>
*> \param[in] IDIST
*> \verbatim
*>          IDIST is INTEGER
*>           On entry, IDIST specifies the type of distribution to be
*>           used to generate a random matrix .
*>           1 => UNIFORM( 0, 1 )
*>           2 => UNIFORM( -1, 1 )
*>           3 => NORMAL( 0, 1 )
*>           Not modified.
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*>          ISEED is INTEGER array of dimension ( 4 )
*>           Seed for random number generator.
*>           Changed on exit.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is DOUBLE PRECISION array of dimension ( MIN( I , J ) )
*>           Diagonal entries of matrix. Not modified.
*> \endverbatim
*>
*> \param[in] IGRADE
*> \verbatim
*>          IGRADE is INTEGER
*>           Specifies grading of matrix as follows:
*>           0  => no grading
*>           1  => matrix premultiplied by diag( DL )
*>           2  => matrix postmultiplied by diag( DR )
*>           3  => matrix premultiplied by diag( DL ) and
*>                         postmultiplied by diag( DR )
*>           4  => matrix premultiplied by diag( DL ) and
*>                         postmultiplied by inv( diag( DL ) )
*>           5  => matrix premultiplied by diag( DL ) and
*>                         postmultiplied by diag( DL )
*>           Not modified.
*> \endverbatim
*>
*> \param[in] DL
*> \verbatim
*>          DL is DOUBLE PRECISION array ( I or J, as appropriate )
*>           Left scale factors for grading matrix.  Not modified.
*> \endverbatim
*>
*> \param[in] DR
*> \verbatim
*>          DR is DOUBLE PRECISION array ( I or J, as appropriate )
*>           Right scale factors for grading matrix.  Not modified.
*> \endverbatim
*>
*> \param[in] IPVTNG
*> \verbatim
*>          IPVTNG is INTEGER
*>           On entry specifies pivoting permutations as follows:
*>           0 => none.
*>           1 => row pivoting.
*>           2 => column pivoting.
*>           3 => full pivoting, i.e., on both sides.
*>           Not modified.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array ( I or J, as appropriate )
*>           This array specifies the permutation used. The
*>           row (or column) in position K was originally in
*>           position IWORK( K ).
*>           This differs from IWORK for DLATM3. Not modified.
*> \endverbatim
*>
*> \param[in] SPARSE
*> \verbatim
*>          SPARSE is DOUBLE PRECISION between 0. and 1.
*>           On entry specifies the sparsity of the matrix
*>           if sparse matrix is to be generated.
*>           SPARSE should lie between 0 and 1.
*>           A uniform ( 0, 1 ) random number x is generated and
*>           compared to SPARSE; if x is larger the matrix entry
*>           is unchanged and if x is smaller the entry is set
*>           to zero. Thus on the average a fraction SPARSE of the
*>           entries will be set to zero.
*>           Not modified.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup double_matgen
*
*  =====================================================================
      DOUBLE PRECISION FUNCTION DLATM2( M, N, I, J, KL, KU, IDIST,
     $                 ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
*
*  -- LAPACK auxiliary routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     June 2016
*
*     .. Scalar Arguments ..
*
      INTEGER            I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N
      DOUBLE PRECISION   SPARSE
*     ..
*
*     .. Array Arguments ..
*
      INTEGER            ISEED( 4 ), IWORK( * )
      DOUBLE PRECISION   D( * ), DL( * ), DR( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
*
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
*     ..
*
*     .. Local Scalars ..
*
      INTEGER            ISUB, JSUB
      DOUBLE PRECISION   TEMP
*     ..
*
*     .. External Functions ..
*
      DOUBLE PRECISION   DLARAN, DLARND
      EXTERNAL           DLARAN, DLARND
*     ..
*
*-----------------------------------------------------------------------
*
*     .. Executable Statements ..
*
*
*     Check for I and J in range
*
      IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN
         DLATM2 = ZERO
         RETURN
      END IF
*
*     Check for banding
*
      IF( J.GT.I+KU .OR. J.LT.I-KL ) THEN
         DLATM2 = ZERO
         RETURN
      END IF
*
*     Check for sparsity
*
      IF( SPARSE.GT.ZERO ) THEN
         IF( DLARAN( ISEED ).LT.SPARSE ) THEN
            DLATM2 = ZERO
            RETURN
         END IF
      END IF
*
*     Compute subscripts depending on IPVTNG
*
      IF( IPVTNG.EQ.0 ) THEN
         ISUB = I
         JSUB = J
      ELSE IF( IPVTNG.EQ.1 ) THEN
         ISUB = IWORK( I )
         JSUB = J
      ELSE IF( IPVTNG.EQ.2 ) THEN
         ISUB = I
         JSUB = IWORK( J )
      ELSE IF( IPVTNG.EQ.3 ) THEN
         ISUB = IWORK( I )
         JSUB = IWORK( J )
      END IF
*
*     Compute entry and grade it according to IGRADE
*
      IF( ISUB.EQ.JSUB ) THEN
         TEMP = D( ISUB )
      ELSE
         TEMP = DLARND( IDIST, ISEED )
      END IF
      IF( IGRADE.EQ.1 ) THEN
         TEMP = TEMP*DL( ISUB )
      ELSE IF( IGRADE.EQ.2 ) THEN
         TEMP = TEMP*DR( JSUB )
      ELSE IF( IGRADE.EQ.3 ) THEN
         TEMP = TEMP*DL( ISUB )*DR( JSUB )
      ELSE IF( IGRADE.EQ.4 .AND. ISUB.NE.JSUB ) THEN
         TEMP = TEMP*DL( ISUB ) / DL( JSUB )
      ELSE IF( IGRADE.EQ.5 ) THEN
         TEMP = TEMP*DL( ISUB )*DL( JSUB )
      END IF
      DLATM2 = TEMP
      RETURN
*
*     End of DLATM2
*
      END


module wlExtNumericalModule

USE wlKindModule, ONLY: dp

REAL(dp), PARAMETER  :: zero      = 0.0d0
REAL(dp), PARAMETER  :: half      = 0.5d0
REAL(dp), PARAMETER  :: one       = 1.0d0
REAL(dp), PARAMETER  :: epsilon   = 1.0d-100

REAL(dp), PARAMETER  :: pi        = 3.1415926535897932385d0 ! pi

!-----------------------------------------------------------------------
!  Derived constants
!-----------------------------------------------------------------------

REAL(dp), PARAMETER  :: pi2       = pi * pi
REAL(dp), PARAMETER  :: twpi      = 2.d0 * pi
REAL(dp), PARAMETER  :: frpi      = 4.d0 * pi
REAL(dp), PARAMETER  :: third     = 1.d0/3.d0
REAL(dp), PARAMETER  :: twothd    = 2.d0 * third
REAL(dp), PARAMETER  :: fourthd   = 4.d0 * third
REAL(dp), PARAMETER  :: frpith    = third * frpi
REAL(dp), PARAMETER  :: sxtnpi    = 16.d0 * pi

!-----------------------------------------------------------------------
!  Equation of state coefficients
!
!   kfm : [ # nucleons g^{-1} ][ cm^{3}fm^{-3} ]
!-----------------------------------------------------------------------

REAL(dp)             ::  log_e
REAL(dp)             ::  ln_10

END module wlExtNumericalModule


subroutine ta_vertical_interpolation(m,n,o,p,req,pres,geop,&
	pressure_full_level,surface_pressure,ta_on_model_level,ta_on_press_level)
implicit none
integer :: m,n,o,p,q,req,o_sub
integer :: x,y,s,z,t,plev
double precision ::pres(req),ta_on_model_level(m,n,o,p)
double precision ::geop(m,n)
double precision ::pressure_full_level(m,n,o,p),surface_pressure(m,n,p)
double precision ::delta_ta,delta_p,grad_ta_p,diff_p
double precision ::tstar,ztmsl,zrg,zalp,zalph,zhts,ztsz
double precision, intent(out) :: ta_on_press_level(m,n,req,p)
real ::arg = -1.0,z1
real ::PlanetGrav = 9.80665
real ::PlanetRD = 287.058
real ::zlapse = 0.0065
zrg   = 1.0 / PlanetGrav
o_sub = o - 1
do plev=1,req
 do t=1,p
  do x=1,m
   do y=1,n
    do s=1,o_sub
!above uppest level
     if(pres(plev) .LT. pressure_full_level(x,y,1,t)) then
      ta_on_press_level(x,y,plev,t) = sqrt(arg)
     end if
! in between levels
     if(pres(plev) .GE. pressure_full_level(x,y,s,t) .AND. pres(plev) .LE. &
      pressure_full_level(x,y,s+1,t) ) then
      delta_ta = ta_on_model_level(x,y,s,t) - ta_on_model_level(x,y,s+1,t)
      delta_p = pressure_full_level(x,y,s,t) - pressure_full_level(x,y,s+1,t)
      grad_ta_p = delta_ta /delta_p
      diff_p = pres(plev) - pressure_full_level(x,y,s,t)
      ta_on_press_level(x,y,plev,t) = ta_on_model_level(x,y,s,t) + grad_ta_p &
      * diff_p
     end if
! extrapolation below the ground
     if(pres(plev) .GT. pressure_full_level(x,y,o,t)) then
! temperature at surface equation 5
      tstar = (1.0 + zlapse * PlanetRD * zrg * (surface_pressure(x,y,t) &
       /pressure_full_level(x,y,o,t) - 1.0)) * ta_on_model_level(x,y,o,t)
      ztsz  = tstar
!T _ 0
      z1    = tstar + zlapse * zrg * geop(x,y)
! tests and modifications
! equation 14.3
      if(tstar .LT. 255.0) then
       tstar = 0.5 * (255.0 + tstar)
       ztmsl = tstar + zlapse * zrg * geop(x,y)
      end if
! equation 14.2
      if(ztmsl .GT. 290.5 .AND. tstar .GT. 290.5) then
       tstar = 0.5 * (290.5 + tstar)
       ztmsl = tstar
      end if
! equation 14.1
      if(ztmsl .GT. 290.5 .AND. tstar .LE. 290.5) then
       ztmsl=290.5
       zalph = PlanetRD*zlapse*zrg
      end if
      if(ztmsl-tstar .LE. 0.000001 .AND. tstar-ztmsl .LE. 0.000001) then
       zalph=0.0
      end if
      if((ztmsl-tstar > 0.000001 .OR. tstar-ztmsl > 0.000001) .AND. &
       (geop(x,y) .GT. 0.0001 .OR. geop(x,y) .GT. -0.0001)) then
       zalph = PlanetRD*(ztmsl-tstar)/geop(x,y)
      end if
! linear interpolation
      if(pres(plev) .LE. surface_pressure(x,y,t)) then
       ta_on_press_level(x,y,plev,t) = ((surface_pressure(x,y,t) - pres(plev))&
        *ta_on_model_level(x,y,o,t) +(pres(plev)-pressure_full_level(x,y,o,t))&
        *tstar)/ (surface_pressure(x,y,t)-pressure_full_level(x,y,o,t))
      else
! return to intial values
       ztmsl = z1
       tstar = ztsz
       zhts  = geop(x,y) * zrg
       if(zhts .GT. 2000.0 .AND. z1 .GT. 298.0) then
        ztmsl = 298.0
        if(zhts .LT. 2500.0) then
! eqution 19b
         ztmsl = 0.002*((2500.0 - zhts)*z1 + (zhts-2000.0)*ztmsl)
        end if
       end if
       if((ztmsl-tstar) .LT. 0.000001) then
        zalph = 0.
       else
        if(geop(x,y) .GT. 0.0001 .OR. geop(x,y) .LT. -0.0001) then
         zalph = PlanetRD*(ztmsl-tstar)/geop(x,y)
        else
         zalph = PlanetRD*zlapse*zrg
        end if
       end if
       zalp  = zalph * log(pres(plev)/surface_pressure(x,y,t))
       ta_on_press_level(x,y,plev,t) = tstar*(1.0+zalp*(1.0+zalp &
       *(0.5+0.16666666667*zalp)))
      end if
     end if
    end do
   end do
  end do
 end do
end do
end subroutine ta_vertical_interpolation


      SUBROUTINE RKBAS (S, COEF, K, M, RKB, DM, MODE)
C
C**********************************************************************
C
C   purpose
C           evaluate mesh independent runge-kutta basis for given s
C
C   variables
C     s      - argument, i.e. the relative position for which
C              the basis is to be evaluated ( 0. .le. s .le. 1. ).
C     coef   - precomputed derivatives of the basis
C     k      - number of collocatin points per subinterval
C     m      - maximal order of the differential equation
C     rkb    - the runge-kutta basis (0-th to (m-1)-th derivatives )
C     dm     - basis elements for m-th derivative
C
C**********************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION COEF(K,1), RKB(7,1), DM(1), T(10)
C
      IF ( K .EQ. 1 )                            GO TO 70
      KPM1 = K + M - 1
      DO 10 I = 1, KPM1
   10   T(I) = S / DFLOAT(I)
      DO 40 L = 1, M
         LB = K + L + 1
         DO 30 I = 1, K
           P = COEF(1,I)
           DO 20 J = 2, K
             P = P * T(LB-J)  + COEF(J,I)
   20      CONTINUE
           RKB(I,L) = P
   30    CONTINUE
   40 CONTINUE
      IF ( MODE .EQ. 0 )                         RETURN
      DO 60 I = 1, K
         P = COEF(1,I)
         DO 50 J = 2, K
   50       P = P * T(K+1-J) + COEF(J,I)
         DM(I) = P
   60 CONTINUE
      RETURN
   70 RKB(1,1) = 1.0D0
      DM(1) = 1.0D0
      RETURN
      END


C     LAST UPDATE 07/05/93
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE TQLI(D,E,N,NP,Z)
      IMPLICIT NONE
C
C Purpose: QL algorithm with implicit shifts, to determine the
C          eigenvalues and eigenvectors of a real symmetric tridiagonal
C          matrix, or of a real symmetric matrix previously produced by
C          TRED2. D is a vector of length NP. On input, its first N
C          elements are the diagonal elements of the tridiagonal matrix.
C          On output, it returns the eigenvalues. The vector E inputs
C          the subdiagonal elements of the tridiagonal matrix, with E(1)
C          arbitrary. On output, E is destroyed. If the eigenvectors of
C          a tridiagonal matrix are desired, the matrix Z is input as
C          the identity matrix. If the eigenvectors of a matrix that has
C          been reduced by TRED2 are required then Z is input as the
C          matric output by TRED2. In either case, the Kth column of Z
C          returns the normalized eigenvector corresponding to D(K)
C
      INTEGER N,NP
      REAL*8 D(NP),E(NP),Z(NP,NP)
C
C Calls   0:
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      REAL*8 C,R,S,G,DD,P,B,F
      INTEGER I,K,L,M,ITER
C
C---------------------------------------------------------------------
      DO 10 I=2,N
         E(I-1) = E(I)
 10   CONTINUE
      E(N) = 0.0
      DO 50 L=1,N
         ITER = 0
 1       DO 20 M=L,N-1
            DD = ABS(D(M)) + ABS(D(M+1))
            IF(ABS(E(M))+DD.EQ.DD)GOTO 2
 20      CONTINUE
         M = N
 2       IF(M.NE.L)THEN
            IF(ITER.EQ.50)WRITE(6,1000)
            ITER = ITER + 1
            G = (D(L+1)-D(L))/(2.0*E(L))
            R = SQRT(G**2+1.0)
            G = D(M) - D(L) + E(L)/(G+SIGN(R,G))
            S = 1.0
            C = 1.0
            P = 0.0
            DO 40 I=M-1,L,-1
               F = S*E(I)
               B = C*E(I)
               IF(ABS(F).GE.ABS(G))THEN
                  C = G/F
                  R = SQRT(C**2+1.0)
                  E(I+1) = F*R
                  S = 1.0/R
                  C = C*S
               ELSE
                  S = F/G
                  R = SQRT(S**2+1.0)
                  E(I+1) = G*R
                  C = 1.0/R
                  S = S*C
               ENDIF
               G = D(I+1) - P
               R = (D(I)-G)*S + 2.0*C*B
               P = S*R
               D(I+1) = G + P
               G = C*R - B
               DO 30 K=1,N
                  F = Z(K,I+1)
                  Z(K,I+1) = S*Z(K,I) + C*F
                  Z(K,I) = C*Z(K,I) - S*F
 30            CONTINUE
 40         CONTINUE
            D(L) = D(L) - P
            E(L) = G
            E(M) = 0.0
            IF(ITER.LT.50)GOTO 1
         ENDIF
 50   CONTINUE
      RETURN
 1000 FORMAT(1X,'TQLI: Warning - no convergence in 50 iterations')
C
      END


program kmc
implicit none
! KMC computes the population vs time of a number of species involved in several dynamical processes
! rate: rate constant of a given processes
! p:    population of a given species (p0 is its initial value)
! re (pr): reactant (product) for a given process
! ndisp number of species that dissapear
! ndd species that dissapear
character*80 :: title
integer, parameter :: dp = selected_real_kind(15,307)
integer :: m,nran,nr,nesp,inran,i,j,k,l,mu,ndisp,pd,kk,ijk,tcont,tint
real(dp) :: t,a0,r2a0,suma,ptot
real(dp) :: rnd(2)
integer,dimension(:),allocatable :: p,p0,re,pr,n,ndd,cont,pold,sig,sigold,rep
real (dp) ,dimension(:),allocatable :: a,rate
read(*,"(a80)") title
print "(t3,a80)",title
read(*,*) m,nesp,nran
allocate(re(m),pr(m),a(m),rate(m),p0(nesp),p(nesp),n(nesp),cont(m),pold(nesp),sig(nesp),sigold(nesp),rep(nesp))
n=(/ (l,l=1,nesp) /)
do i=1,m
read(*,*) rate(I),re(i),pr(i)
enddo
ptot=0.d0
print*, "at the beginning"
do ijk=1,m
   cont(ijk)=0
enddo
do i=1,nesp
read(*,*) p0(i)
print*, "P0(",i,")=",p0(i)
ptot=ptot+p0(i)
enddo
read(*,*) ndisp
allocate(ndd(ndisp))
if(ndisp>0) read(*,*) ndd
read(*,*) tint
print "(t3,a,i4,/,t3,a,i4,/,t3,a,i4,/)","# of calcs:",nran,"# of procs:",m,"# of specs:",nesp
print "(t3,a,1p,20(e9.2))","Rates:",rate
print "(t3,a,20(i9))","Reacts:",re
print "(t3,a,20(i9))","Prods :",pr
print "(/,t3,a,1p,i10)","Step size =",tint
outter: do inran=1,nran
   print "(/,t3,a,i4,/,t3,a,9999(i8))","Calculation number",inran,"Time(ps)",n
   p=p0
   pold=p0
   sig=p0
   t=0.d0
   tcont=0
   rep=0
   print "(e10.4,9999(i8))",t,p
   do j=1,m
      a(j)=rate(j)*p(re(j))
   enddo
   a0=sum(a)
   inner: do while(a0>0)
     call random_number(rnd)
     t=t-log(rnd(1))/a0
     r2a0=rnd(2)*a0
     suma=0.d0
     pold=p
     s1: do mu=1,m
       suma=suma+a(mu)
       if(suma>=r2a0) exit s1
     enddo s1
     p(re(mu))=p(re(mu))-1
     p(pr(mu))=p(pr(mu))+1
     cont(mu)=cont(mu)+1
     tcont=tcont+1
!Test of equilibrium
     eq: do j=1,nesp
        sigold(j)=sig(j)
        if(p(j)>pold(j)) sig(j)=1
        if(p(j)<pold(j)) sig(j)=-1
        if(sig(j)*sigold(j)<0) then
           rep(j)=rep(j)+1
           if(rep(j)>=1.d6) exit inner
        endif
     enddo eq
!Test of equilibrium
     do j=1,m
        a(j)=rate(j)*p(re(j))
     enddo
     a0=sum(a)
     if(mod(tcont,tint)==0.or.a0==0) print "(e10.4,9999(i8))",t,p
   enddo inner
!Printing final populations
   print*,"Population of every species"
   do i=1,nesp
      print "(i6,i8)",i,p(i)
   enddo
!Printing statistics
   print*,"counts per process"
   do i=1,m
      print "(i6,i20)",i,cont(i)
   enddo
enddo outter
end program kmc


**********************************************************************
**********************************************************************
      subroutine setstar(ar,cr1,cr2,rstars,nlens,lensmax,lensdata
     &				,masstot,pixdifh)
*
* nlens stars are randomly placed within a circle with radius rstars
* individual masses are attached to each star;
*
* special treatment (end of this routine) if kappa  = 0:
*	       then nlens = 1, put near the origin;
*              for nlens = 2: positions/masses fixed
*
*  input:
*      ar          = a seed number > 0       for subroutine rands
*      cr1, cr2    = auxillary seed numbers   for subroutine rands
*      rstars      = radius of circle with stars
*      nlens       = number of lenses
*
*  output:
*
*      lensdata(1,i) = x-coordinate of lens #i
*      lensdata(2,i) = y-coordinate of lens #i
*      lensdata(3,i) = mass         of lens #i
*
* called in:
*           main
*
* use of subroutines:
*           rands
*
* use of functions:
*           massf
*					October 31, 1991; J. Wambsganss
*
      implicit none
      real         time1,time2,times(20)
      external rands, massf
      integer nlens,ilens,lensmax,debug,nlensin
*
      double precision lensdata(3,lensmax),masstot,massf,pixdifh,ar,cr1
     &,cr2,rstars,randx,randy,randm
*
      common/test/debug
      common/jkwtime/times
*
* calculate two random numbers uniform in the range 0 to 1
*
         time1 = 0.0d0
         time2 = 0.0d0
      nlensin   = 0
      masstot   = 0.0
*
      do ilens = 1,nlens
    1    continue
*
	 call cpu_time (time1)
         call rands(ar,cr1,cr2,randx)
         call rands(ar,cr1,cr2,randy)
         call rands(ar,cr1,cr2,randm)
	 call cpu_time (time2)
         times(11)  = times(11) + (time2-time1)
*
         randx=randx*2.0D0-1
         randy=randy*2.0D0-1
*
* if position is too far from the center then do not use it
*                 ( not inside the given circle !)
*
        if((randx**2+randy**2).gt.1.0d0)go to 1
*
* now the pair (randx,randy) fills uniformly a circle with radius 1;
* expand the random numbers so that they cover a circle with radius
* "rstars";  determine random mass inside mass interval, according
* to power law:
*
         lensdata(1,ilens) = rstars*randx
         lensdata(2,ilens) = rstars*randy
         lensdata(3,ilens) = massf(randm)
*
	 masstot = masstot + lensdata(3,ilens)
	 if(abs(lensdata(1,ilens)).le.pixdifh.and.
     &	    abs(lensdata(2,ilens)).le.pixdifh)then
      		nlensin     = nlensin + 1
  	 endif
      enddo
*
*
*
*
*
*
*
*
* if there is only one lens: set it at the origin of the coordinates:
*
*      if there are two lenses: fix there position symmetrically
*                    mass  2:1
*
*
*
      if(nlens.eq.1)then
         lensdata(1,nlens) = 1.0e-10
         lensdata(2,nlens) = 1.0e-10
         lensdata(3,nlens) = 1.0e0
      elseif(nlens.eq.2)then
         lensdata(1,    1) = -0.92000000e0
         lensdata(2,    1) =  0.0000100e0
         lensdata(3,    1) =  2.000000e0
         lensdata(1,nlens) =  0.92000000e0
         lensdata(2,nlens) = -0.0000100e0
         lensdata(3,nlens) =  0.200000e0
      endif
*
      return
      end


C    @(#)invert.f	20.3 2/13/96
      subroutine invert(nc)
C
      include 'ipfinc/work1.inc'
c	Global variables used:
c	aa(r*8), space(r*8), x(r*8), ierr
C
      double precision a(30,31), temp
      integer nj(30), ntemp
      equivalence (a,aa), (nj,space)

      zero = 1.0e-10
      ierr=0
      nm1=nc-1
      np1=nc+1
      ncv=nc+1
      do 100 i=1,nc
  100 nj(i)=i
      do 110 i=1,nc
  110 a(i,nc+1)=x(i)
      do 210 k=1,nm1
      temp=0.0
      do 120 i=k,nc
      do 120 j=k,nc
      if (dabs(a(i,j)).le.temp) go to 120
      temp=dabs(a(i,j))
      ii=i
      jj=j
  120 continue
      if (temp.gt.zero) go to 130
      ierr=k
      go to 260
  130 if (ii-k) 140,160,140
140   do 150 j=k,ncv
      temp=a(ii,j)
      a(ii,j)=a(k,j)
  150 a(k,j)=temp
  160 if (jj-k) 170,190,170
  170 do 180 i=1,nc
         temp=a(i,jj)
         a(i,jj)=a(i,k)
  180 a(i,k)=temp
      ntemp=nj(jj)
      nj(jj)=nj(k)
      nj(k)=ntemp
  190 l=k+1
      do 200 j=l,ncv
         a(k,j)=a(k,j)/a(k,k)
         do 200 i=l,nc
  200 a(i,j)=a(i,j)-a(i,k)*a(k,j)
  210 continue
      if (dabs(a(nc,nc)).gt.zero) go to 220
      ierr=nc
      go to 260

220   do 240 j=np1,ncv
      a(nc,j)=a(nc,j)/a(nc,nc)
      k=nc
      do 230 l=1,nm1
      k=k-1
      do 230 i=k,nm1
  230 a(k,j)=a(k,j)-a(k,i+1)*a(i+1,j)
  240 continue
      do 250 i=1,nc
      l=nj(i)
  250 x(l)=a(i,nc+1)
  260 return
      end


      function sinfit(x)
      common /pawpar/ par(1)
      sinfit=par(1)*sin(x)
      end