c****************************************************************
        subroutine latlon(elp,r_v,r_llh,i_type)

c****************************************************************
c**
c**   FILE NAME: latlon.f
c**
c**   DATE WRITTEN:7/22/93
c**
c**   PROGRAMMER:Scott Hensley
c**
c**   FUNCTIONAL DESCRIPTION:This program converts a vector to
c**   lat,lon and height above the reference ellipsoid or given a
c**   lat,lon and height produces a geocentric vector.
c**
c**   ROUTINES CALLED:none
c**
c**   NOTES: none
c**
c**   UPDATE LOG:
c**
c****************************************************************

        implicit none

c       INPUT VARIABLES:
        integer i_type          !1=lat,lon to vector,2= vector to lat,lon
c	structure /ellipsoid/
c	   real*8 r_a
c	   real*8 r_e2
c	end structure
c	record /ellipsoid/ elp

	type ellipsoid
           sequence
	   real (8) r_a
	   real (8) r_e2
	end type ellipsoid
	type (ellipsoid) elp

        real*8 r_v(3)                    !geocentric vector (meters)
        real*8 r_llh(3)                  !latitude (deg -90 to 90),longitude (deg -180 to 180),height

c       OUTPUT VARIABLES: see input

c       LOCAL VARIABLES:
        integer i_ft
        real*8 pi,r_dtor,r_re,r_q2,r_q3,r_b,r_q
        real*8 r_p,r_tant,r_theta,r_a,r_e2

c       DATA STATEMENTS:
        data pi /3.141592653589793238d0/
        data r_dtor /1.74532925199d-2/

C       FUNCTION STATEMENTS:

c       PROCESSING STEPS:

        r_a = elp%r_a
        r_e2 = elp%r_e2

        if(i_type .eq. 1)then  !convert lat,lon to vector

           r_re = r_a/sqrt(1.d0 - r_e2*sin(r_llh(1))**2)

           r_v(1) = (r_re + r_llh(3))*cos(r_llh(1))*cos(r_llh(2))
           r_v(2) = (r_re + r_llh(3))*cos(r_llh(1))*sin(r_llh(2))
           r_v(3) = (r_re*(1.d0-r_e2) + r_llh(3))*sin(r_llh(1))

        elseif(i_type .eq. 2)then  !convert vector to lat,lon

           r_q2 = 1.d0/(1.d0 - r_e2)
           r_q = sqrt(r_q2)
           r_q3 = r_q2 - 1.d0
           r_b = r_a*sqrt(1.d0 - r_e2)

           r_llh(2) = atan2(r_v(2),r_v(1))

           r_p = sqrt(r_v(1)**2 + r_v(2)**2)
           r_tant = (r_v(3)/r_p)*r_q
           r_theta = atan(r_tant)
           r_tant = (r_v(3) + r_q3*r_b*sin(r_theta)**3)/
     +          (r_p - r_e2*r_a*cos(r_theta)**3)
           r_llh(1) =  atan(r_tant)
           r_re = r_a/sqrt(1.d0 - r_e2*sin(r_llh(1))**2)
           r_llh(3) = r_p/cos(r_llh(1)) - r_re

        endif

        end


PROGRAM LUCAS_LEHMER
  IMPLICIT NONE

  INTEGER, PARAMETER :: i64 = SELECTED_INT_KIND(18)
  INTEGER(i64) :: s, n
  INTEGER :: i, exponent

  DO exponent = 2, 31
     IF (exponent == 2) THEN
        s = 0
     ELSE
        s = 4
     END IF
     n = 2_i64**exponent - 1
     DO i = 1, exponent-2
        s = MOD(s*s - 2, n)
     END DO
     IF (s==0) WRITE(*,"(A,I0,A)") "M", exponent, " is PRIME"
  END DO

END PROGRAM LUCAS_LEHMER


module poisson_assembly
use types, only: dp
use linalg, only: inv
use utils, only: assert, stop_error
use constants, only: pi
implicit none
private
public assemble_2d, sol_error

contains

real(dp) elemental function f(x, y)
real(dp), intent(in) :: x, y
f = 2 * pi**2 * sin(pi*x) * sin(pi*y)
end function

real(dp) elemental function exact_sol(x, y)
real(dp), intent(in) :: x, y
exact_sol = sin(pi*x) * sin(pi*y)
end function

subroutine assemble_2d(xin, nodes, elems, ib, xiq, wtq, phihq, dphihq, Am, rhs)
! Assemble on a 2D rectangular uniform mesh
real(dp), intent(in):: xin(:), nodes(:, :), xiq(:), wtq(:, :), &
    phihq(:, :), dphihq(:, :)
integer, intent(in):: elems(:, :), ib(:, :, :)
real(dp), intent(out):: Am(:,:), rhs(:)
integer :: Ne, p, e, i, j, iqx, iqy
real(dp), dimension(size(xiq), size(xiq), size(xin), size(xin)) :: &
    phi_v, phi_dx, phi_dy
real(dp) :: x(size(xiq)), y(size(xiq))
real(dp) :: fq(size(xiq), size(xiq)), xp(size(xiq)), yp(size(xiq))
real(dp) :: lx, ly
integer :: ax, ay, bx, by
real(dp) :: jacx, jacy, jac_det

Ne = size(elems, 2)
p = size(xin) - 1
! 2D shape functions
do ay = 1, p+1
    do ax = 1, p+1
        do iqy = 1, size(xiq)
            do iqx = 1, size(xiq)
                phi_v(iqx, iqy, ax, ay) = phihq(iqx, ax)*phihq(iqy, ay)
                phi_dx(iqx, iqy, ax, ay) = dphihq(iqx, ax)*phihq(iqy, ay)
                phi_dy(iqx, iqy, ax, ay) = phihq(iqx, ax)*dphihq(iqy, ay)
            end do
        end do
   end do
end do
Am=0; rhs=0
! Precalculate as much as possible:
lx = nodes(1, elems(3, 1)) - nodes(1, elems(1, 1)) ! Element sizes
ly = nodes(2, elems(3, 1)) - nodes(2, elems(1, 1))
jacx = lx/2
jacy = ly/2
jac_det = abs(jacx*jacy)
xp = (xiq + 1) * jacx
yp = (xiq + 1) * jacy
phi_dx = phi_dx / jacx
phi_dy = phi_dy / jacy
do e = 1, Ne
    x = xp + nodes(1, elems(1, e))
    y = yp + nodes(2, elems(1, e))
    do iqy = 1, size(xiq)
        do iqx = 1, size(xiq)
            fq(iqx, iqy) = f(x(iqx), y(iqy))
        end do
    end do
    fq = fq * jac_det * wtq
    do by = 1, p+1
    do bx = 1, p+1
        j = ib(bx, by, e)
        if (j==0) cycle
        do ay = 1, p+1
        do ax = 1, p+1
            i = ib(ax, ay, e)
            if (i == 0) cycle
            if (j > i) cycle
            Am(i,j) = Am(i,j) + sum( &
                    (phi_dx(:, :, ax, ay)*phi_dx(:, :, bx, by) &
                    +phi_dy(:, :, ax, ay)*phi_dy(:, :, bx, by)) &
                * jac_det * wtq)
        end do
        end do
        rhs(j) = rhs(j) + sum(phi_v(:, :, bx, by) * fq)
    end do
    end do
end do
do j = 1, size(Am, 2)
    do i = 1, j-1
        Am(i, j) = Am(j, i)
    end do
end do
end subroutine

real(dp) function sol_error(nodes, elems, xiq, wtq, solq) result(r)
real(dp), intent(in) :: nodes(:, :)
integer, intent(in) :: elems(:, :)
real(dp), intent(in) :: xiq(:), wtq(:,:), solq(:, :, :)
real(dp) :: fq(size(xiq), size(xiq)), x(size(xiq)), y(size(xiq))
real(dp) :: jacx, jacy, l(2), jac_det
integer :: e, iqx, iqy, Ne
Ne = size(elems, 2)
r = 0
do e = 1, Ne
    ! l is the diagonal vector:
    l = nodes(:, elems(3, e)) - nodes(:, elems(1, e))
    ! Assume rectangular shape:
    jacx = l(1)/2
    jacy = l(2)/2
    jac_det = abs(jacx*jacy)
    x = (xiq + 1) * jacx + nodes(1, elems(1, e))
    y = (xiq + 1) * jacy + nodes(2, elems(1, e))
    do iqy = 1, size(xiq)
        do iqx = 1, size(xiq)
            fq(iqx, iqy) = exact_sol(x(iqx), y(iqy))
        end do
    end do
    fq = fq-solq(:, :, e)
    r = r + sum(fq*fq * jac_det * wtq)
end do
r = sqrt(r)
end function

end module

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

module poisson2d_code

use types, only: dp
use feutils, only: phih, dphih
use fe_mesh, only: cartesian_mesh_2d, cartesian_mesh_3d, &
    define_connect_tensor_2d, c2fullc_2d, fe2quad_2d
use poisson_assembly, only: assemble_2d, sol_error
use feutils, only: get_parent_nodes, get_parent_quad_pts_wts
use linalg, only: solve
use constants, only: pi
implicit none

contains

real(dp) function logg(Nex, Ney, p) result(error)
integer, intent(in) :: p

integer :: Nn, Ne
! nodes(:, i) are the (x,y) coordinates of the i-th mesh node
real(dp), allocatable :: nodes(:, :)
integer, allocatable :: elems(:, :) ! elems(:, i) are nodes of the i-th element
integer :: Nq, Nb
real(dp), allocatable :: xin(:), xiq(:), wtq(:), A(:, :), rhs(:), sol(:), &
        fullsol(:), solq(:, :, :), wtq2(:, :), phihq(:, :), dphihq(:, :)
integer, allocatable :: in(:, :, :), ib(:, :, :)
integer :: i, j
integer, intent(in) :: Nex, Ney

call cartesian_mesh_2d(Nex, Ney, [0.0_dp, 0._dp], [1._dp, 1._dp], nodes, elems)
Nn = size(nodes, 2)
Ne = size(elems, 2)
Nq = p+1

print *, "Number of nodes:", Nn
print *, "Number of elements:", Ne
print *, "Nq =", Nq
print *, "p =", p
allocate(xin(p+1))
call get_parent_nodes(2, p, xin)
allocate(xiq(Nq), wtq(Nq), wtq2(Nq, Nq))
call get_parent_quad_pts_wts(1, Nq, xiq, wtq)
forall(i=1:Nq, j=1:Nq) wtq2(i, j) = wtq(i)*wtq(j)
allocate(phihq(size(xiq), size(xin)))
allocate(dphihq(size(xiq), size(xin)))
! Tabulate parent basis at quadrature points
forall(i=1:size(xiq), j=1:size(xin))  phihq(i, j) =  phih(xin, j, xiq(i))
forall(i=1:size(xiq), j=1:size(xin)) dphihq(i, j) = dphih(xin, j, xiq(i))

call define_connect_tensor_2d(Nex, Ney, p, 1, in)
call define_connect_tensor_2d(Nex, Ney, p, 2, ib)
Nb = maxval(ib)
print *, "DOFs =", Nb
allocate(A(Nb, Nb), rhs(Nb), sol(Nb), fullsol(maxval(in)), solq(Nq, Nq, Ne))

call assemble_2d(xin, nodes, elems, ib, xiq, wtq2, phihq, dphihq, A, rhs)
sol = solve(A, rhs)
call c2fullc_2d(in, ib, sol, fullsol)
call fe2quad_2d(elems, xin, xiq, phihq, in, fullsol, solq)
error = sol_error(nodes, elems, xiq, wtq2, solq)

end function

end module

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

program poisson2d
use types, only: dp
use poisson2d_code, only: logg

real(dp) :: error
integer :: i, N
real(dp) :: t1, t2

N = 1
call cpu_time(t1)
do i = 1, N
    error = logg(1, 1, 8)
end do
call cpu_time(t2)
print *, "L2 error:", error
print "('Total time: ', f10.8)", (t2-t1) / N
end program


      subroutine spline(np,x,y,ddy,work,mode,dy)
C
C     Normal Spline y''(1)=y''(np)=0.
C     ddy returns y''(i)/6.
C     y=A y(i)+B y(i+1)+C ddy(i)+D ddy(i+1)
C     y'=(y(i+1)-y(i))/(x(i+1)-x(i))
C        -(3A^2-1)(x(i+1)-x(i))ddy(i)
C        +(3B^2-1)(x(i+1)-x(i))ddy(i+1)
C     A=(x(i+1)-x)/(x(i+1)-x(i))
C     B=1-A=(x-x(i))/(x(i+1)-x(i))
C     C=(A^3-A)(x(i+1)-x(i))^2
C     D=(B^3-B)(x(i+1)-x(i))^2
C
      implicit none
      integer*4 np,i,mode
      real*8 ,intent(in):: x(np),y(np),dy(2)
      real*8 ,intent(out):: ddy(np),work(np)
      real*8 dy1a,ddy1
      real*8, allocatable :: dddy(:)
      real*8 f
      if(np .le. 2)then
        ddy=0.d0
        return
      endif
      allocate (dddy(np))
      if(mode .eq. 0 .or. mode .eq. 2)then
        ddy(1)=0.d0
        ddy(2)=(y(3)-y(2))/(x(3)-x(2))-(y(2)-y(1))/(x(2)-x(1))
        work(2)=(x(3)-x(1))*2.d0
      elseif(mode .eq. 1 .or. mode .eq. 3)then
        work(1)=(x(2)-x(1))*.5d0
        work(2)=(x(3)-x(1))*2.d0-work(1)
        ddy(1)=.5d0*((y(2)-y(1))/work(1)/2.d0-dy(1))
        ddy(2)=(y(3)-y(2))/(x(3)-x(2))-(y(2)-y(1))/(x(2)-x(1))-ddy(1)
      elseif(mode .eq. 4)then
        dy1a=(y(2)-y(1)+y(np)-y(np-1))/(x(2)-x(1)+x(np)-x(np-1))
        work(1)=(x(2)-x(1))*.5d0
        work(2)=(x(3)-x(1))*2.d0-work(1)
        ddy(1)=.5d0*((y(2)-y(1))/work(1)/2.d0-dy1a)
        ddy(2)=(y(3)-y(2))/(x(3)-x(2))-(y(2)-y(1))/(x(2)-x(1))-ddy(1)
        dddy(1)=-0.5d0
        dddy(2)= 0.5d0
        do i=2,np-2
          f=x(i+1)-x(i)
          work(i+1)=(x(i+2)-x(i))*2.d0-f**2/work(i)
          ddy(i+1) =(y(i+2)-y(i+1))/(x(i+2)-x(i+1))
     1         -(y(i+1)-y(i))/f-f/work(i)*ddy(i)
          dddy(i+1)=-f/work(i)*dddy(i)
        enddo
        work(np)=x(np)-x(np-1)
        ddy(np)=dy1a-(y(np)-y(np-1))/work(np)
        ddy(np-1)=(ddy(np-1)-ddy(np)*.5d0)/
     $       (work(np-1)-.5d0*work(np))
        ddy(np)=(ddy(np)/work(np)-ddy(np-1))*.5d0
        dddy(np-1)=(dddy(np-1)-.5d0)/
     $       (work(np-1)-.5d0*work(np))
        dddy(np)=(1.d0/work(np)-dddy(np-1))*.5d0
        do i=np-2,2,-1
          ddy(i) =( ddy(i)- ddy(i+1)*(x(i+1)-x(i)))/work(i)
          dddy(i)=(dddy(i)-dddy(i+1)*(x(i+1)-x(i)))/work(i)
        enddo
        ddy(1) =(ddy(1)/work(1)- ddy(2))*.5d0
        dddy(1)=(-0.5d0/work(1)-dddy(2))*.5d0
        if(dddy(1) .ne. dddy(np))then
          ddy1=-(ddy(np)-ddy(1))/(dddy(np)-dddy(1))
          ddy=ddy+ddy1*dddy
        endif
        deallocate (dddy)
        return
      endif
      do i=2,np-2
        f=x(i+1)-x(i)
c        write(*,'(a,i4,1p5g12.5)')'spline ',
c     $       i,f,work(i),x(i),x(i+1),x(i+2)
        work(i+1)=(x(i+2)-x(i))*2.d0-f**2/work(i)
        ddy(i+1)=(y(i+2)-y(i+1))/(x(i+2)-x(i+1))
     1           -(y(i+1)-y(i))/f-f/work(i)*ddy(i)
      enddo
      if(mode .eq. 0 .or. mode .eq. 1)then
        ddy(np)=0.d0
        ddy(np-1)=ddy(np-1)/work(np-1)
      elseif(mode .eq. 2 .or. mode .eq. 3)then
        work(np)=x(np)-x(np-1)
        ddy(np)=dy(2)-(y(np)-y(np-1))/work(np)
        ddy(np-1)=(ddy(np-1)-ddy(np)*.5d0)/
     $       (work(np-1)-.5d0*work(np))
        ddy(np)=(ddy(np)/work(np)-ddy(np-1))*.5d0
      endif
      do i=np-2,2,-1
        ddy(i)=(ddy(i)-ddy(i+1)*(x(i+1)-x(i)))/work(i)
c        write(*,*)'spline ',i,work(i),ddy(i)
      enddo
      if(mode .eq. 1 .or. mode .eq. 3)then
        ddy(1)=(ddy(1)/work(1)-ddy(2))*.5d0
      endif
      deallocate (dddy)
      return
      end

      subroutine spline1(np,y,ddy,work,mode1,mode2)
C
C     Spline when dx=const.=1
C     Normal Spline y''(1)=y''(np)=0.
C     ddy returns y''(i)/6.
C     y=A y(i)+B y(i+1)+C ddy(i)+D ddy(i+1)
C     y'=(y(i+1)-y(i))
C        -(3A^2-1)ddy(i)
C        +(3B^2-1)ddy(i+1)
C     A=(x(i+1)-x)
C     B=1-A=(x-x(i))
C     C=(A^3-A)
C     D=(B^3-B)
C
      implicit none
      integer*4 ,intent(in)::np,mode1,mode2
      integer*4 i
      real*8 ,intent(in)::y(np)
      real*8 ,intent(out)::ddy(np),work(np)
      if(mode1 .eq. 0)then
        ddy(1)=0.d0
        if(np .le. 2)then
          ddy(2)=0.d0
          return
        endif
        ddy(2)=y(3)-2.d0*y(2)+y(1)
        work(2)=4.d0
      elseif(mode1 .eq. 1)then
        work(1)=.5d0
        work(2)=3.5d0
        ddy(1)=.5d0*(y(2)-y(1)-ddy(1))
        ddy(2)=y(3)-2.d0*y(2)+y(1)-ddy(1)
      elseif(mode1 .eq. 2)then
        ddy(2)=y(3)-2.d0*y(2)+y(1)-ddy(1)
        work(2)=4.d0
      endif
      do i=2,np-2
        work(i+1)=4.d0-1.d0/work(i)
        ddy(i+1)=y(i+2)-2.d0*y(i+1)+y(i)
     1           -ddy(i)/work(i)
      enddo
      if(mode2 .eq. 0)then
        ddy(np)=0.d0
        ddy(np-1)=ddy(np-1)/work(np-1)
      elseif(mode2 .eq. 1)then
        ddy(np)=ddy(np)-(y(np)-y(np-1))
        ddy(np-1)=(ddy(np-1)-ddy(np)*.5d0)/
     $       (work(np-1)-.5d0)
        ddy(np)=(ddy(np)-ddy(np-1))*.5d0
      elseif(mode2 .eq. 2)then
        ddy(np-1)=(ddy(np-1)-ddy(np))/work(np-1)
      endif
      do 20 i=np-2,2,-1
        ddy(i)=(ddy(i)-ddy(i+1))/work(i)
20    continue
      if(mode1 .eq. 1)then
        ddy(1)=ddy(1)-ddy(2)*.5d0
      endif
      return
      end

      real*8 function splint1(np,y,mode1,mode2,dy)
      implicit none
      integer*4 , intent(in)::np,mode1,mode2
c      integer*4 i
      real*8 ,intent(in)::y(np),dy(2)
c      real*8 s
      real*8,allocatable:: work(:),ddy(:)
      allocate (work(np),ddy(np))
      ddy(1)=dy(1)
      ddy(np)=dy(2)
      call spline1(np,y,ddy,work,mode1,mode2)
      splint1=(y(1)+y(np)-.5d0*(ddy(1)+ddy(np)))*.5d0
     $     +sum(y(2:np-1)-ddy(2:np-1)*.5d0)
      deallocate (work,ddy)
      return
      end

      real*8 function splint(f,x0,x1,mode,dy,eps,epsabs,n0)
      implicit none
      integer*4 nmax,mode
      parameter (nmax=8192)
      integer*4 n,k,k1,i,i1
      integer*4 , intent(in)::n0
      real*8 , external:: f
      real*8 , intent(in)::x0,x1,eps,epsabs,dy(2)
      real*8 , allocatable::x(:,:),y(:,:),ddy(:),work(:)
      real*8 xi,xstep,sddy,s,s0,dx,dx2,s20,s2,ddyi
      logical*4 first
      allocate (x(nmax,2),y(nmax,2),ddy(nmax),work(nmax))
      first=.true.
      n=max(n0,4)
      k=1
      xi=x0
      xstep=(x1-x0)/(n-1)
      s0=0.d0
      do i=1,n
        x(i,1)=xi
        y(i,1)=f(xi)
        xi=xi+xstep
        s0=s0+y(i,1)
      enddo
      s0=(s0-.5d0*(y(1,1)+y(n,1)))*xstep
      s20=s0
 1    call spline(n,x(1,k),y(1,k),ddy,work,mode,dy)
      s=0.d0
      sddy=0.d0
      do i=1,n-1
        dx=x(i+1,k)-x(i,k)
        dx2=.5d0*dx**2
        s=s+(y(i+1,k)+y(i,k)-(ddy(i+1)+ddy(i))*dx2)*dx
        ddyi=merge(-(ddy(i)-ddy(i-1))/(x(i,k)-x(i-1,k)),0.d0,
     $       i .gt. 1)
        if(i .lt. n-1)then
          ddyi=ddyi+(ddy(i+2)-ddy(i+1))/(x(i+2,k)-x(i+1,k))
        endif
        work(i)=abs(ddyi)*dx2**2
        sddy=sddy+work(i)
      enddo
      s=s*.5d0
      s2=merge(s,(4.d0*s-s0)/3.d0,first)
c      write(*,*)n,s2,s
      if(abs(s2-s20) .le. max(eps*s20,epsabs))then
        splint=s2
        deallocate (x,y,ddy,work)
        return
      endif
      first=.false.
      sddy=sddy/(n-1)
      k1=3-k
      x(1,k1)=x(1,k)
      y(1,k1)=y(1,k)
      i1=1
      do i=1,n-1
        if(work(i) .ge. sddy)then
          i1=i1+1
          x(i1,k1)=(x(i,k)+x(i+1,k))*.5d0
          y(i1,k1)=f(x(i1,k1))
        endif
        i1=i1+1
        x(i1,k1)=x(i+1,k)
        y(i1,k1)=y(i+1,k)
        if(i1 .ge. nmax-2)then
          go to 9000
        endif
      enddo
      k=k1
      n=i1
      s0=s
      s20=s2
      go to 1
 9000 write(*,*)'Splint convergence failed. ',s,s0
      splint=s2
      deallocate (x,y,ddy,work)
      return
      end

      subroutine spline1m(m,md,np,y,ddy,work)
C
C     Spline when dx=const.=1, for vector.
C     Normal Spline y''(1)=y''(np)=0.
C     ddy returns y''(i)/6.
C     y=A y(i)+B y(i+1)+C ddy(i)+D ddy(i+1)
C     y'=(y(i+1)-y(i))
C        -(3A^2-1)ddy(i)
C        +(3B^2-1)ddy(i+1)
C     A=(x(i+1)-x)
C     B=1-A=(x-x(i))
C     C=(A^3-A)
C     D=(B^3-B)
C
      implicit none
      integer*4 np,i,m,j,md
      real*8 y(md,np),ddy(md,np),work(np)
      do j=1,m
        ddy(j,1)=0.d0
        ddy(j,2)=y(j,3)-2.d0*y(j,2)+y(j,1)
      enddo
      work(2)=4.d0
      do 10 i=2,np-2
        work(i+1)=4.d0-1.d0/work(i)
        do j=1,m
          ddy(j,i+1)=y(j,i+2)-2.d0*y(j,i+1)+y(j,i)
     1           -ddy(j,i)/work(i)
        enddo
10    continue
      do j=1,m
        ddy(j,np)=0.d0
        ddy(j,np-1)=ddy(j,np-1)/work(np-1)
      enddo
      do 20 i=np-2,2,-1
        do j=1,m
          ddy(j,i)=(ddy(j,i)-ddy(j,i+1))/work(i)
        enddo
20    continue
      return
      end

      subroutine tfspline(isp1,kx,irtc)
      use tfstk
      implicit none
      type (sad_descriptor) kx,kd,k1,k2
      type (sad_dlist), pointer :: klx,kld
      integer*8 ka1,ka2,ix,iy,iddy,ka
      integer*4 isp1,irtc,itfmessage,n,m,mode
      real*8 dy(2)
      type (sad_descriptor), save :: kxperiodic
      data kxperiodic%k /0/
      if(kxperiodic%k .eq. 0)then
        kxperiodic=kxsymbolz('`Periodic',9)
      endif
      mode=0
      if(isp .eq. isp1+2)then
        call tfgetoption('Derivative',ktastk(isp),kd,irtc)
        if(irtc .ne. 0)then
          if(irtc .eq. -1)then
            go to 9100
          endif
          return
        endif
        if(tfsameq(kd,kxperiodic))then
          mode=4
        else
          if(ktfnonlistq(kd,kld))then
            go to 9100
          endif
          if(kld%nl .ne. 2)then
            go to 9100
          endif
          k1=kld%dbody(1)
          if(ktfoperq(k1,ka1))then
            if(ka1 .ne. mtfnull)then
              go to 9100
            endif
          elseif(ktfnonrealq(k1,dy(1)))then
            go to 9100
          else
            mode=1
          endif
          k2=kld%dbody(2)
          if(ktfoperq(k2,ka2))then
            if(ka2 .ne. mtfnull)then
              go to 9100
            endif
          elseif(ktfnonrealq(k2,dy(2)))then
            go to 9100
          else
            mode=mode+2
          endif
        endif
      elseif(isp .ne. isp1+1)then
        go to 9100
      endif
      call tfmsize(ktastk(isp1+1),n,m,irtc)
      if(irtc .ne. 0)then
        return
      endif
      if(n .ne. 2)then
        go to 9000
      endif
      ka=ktfaddr(ktastk(isp1+1))
      ix=ktfaddr(klist(ka+1))
      iy=ktfaddr(klist(ka+2))
      iddy=ktavaloc(0,max(m,3))+1
      call spline2(m,
     $     rlist(ix+1:ix+m),
     $     rlist(iy+1:iy+m),
     $     rlist(iddy:iddy+m-1),mode,dy)
      kx=kxadaloc(-1,3,klx)
      klx%dbody(1)%k=ktflist+ktfcopy1(ix)
      klx%dbody(2)%k=ktflist+ktfcopy1(iy)
      klx%dbody(3)%k=ktflist+iddy-1
      irtc=0
      return
 9000 irtc=itfmessage(9,'General::wrongval',
     $     '"Argument","{{x1, ..}, {y1, ..}}"')
      return
 9100 irtc=itfmessage(9,'General::narg','"1 + Derivative->{dy1,dy2}"')
      return
      end

      subroutine spline2(m,x,y,ddy,mode,dy)
      implicit none
      integer*4 m,mode
      real*8 x(m),y(m),ddy(m),work(m),dy(2)
      call spline(m,x,y,ddy,work,mode,dy)
      return
      end

      subroutine tffindindex(isp1,kx,irtc)
      use tfstk
      implicit none
      type (sad_descriptor) kx
      type (sad_dlist), pointer ::kl
      type (sad_rlist), pointer ::klr,kll
      integer*4 isp1,irtc,itfmessage,i1,i2,ih,n,i,m
      real*8 x
      if(isp1+2 .ne. isp)then
        irtc=itfmessage(9,'General::narg','"2"')
        return
      endif
      if(.not. tflistq(dtastk(isp1+1),kl))then
        irtc=itfmessage(9,'General::wrongval','"#1","List"')
        return
      endif
      if(ktfnonreallistqo(kl))then
        irtc=itfmessage(9,'General::wrongval','"#1","List of Reals"')
        return
      endif
      if(ktfrealq(ktastk(isp)))then
        i1=1
        i2=kl%nl
        x=rtastk(isp)
        irtc=0
        do while(i2 .gt. i1+1)
          ih=i1+(i2-i1)/2
          if(kl%rbody(ih) .eq. x)then
            kx=dfromr(dble(ih))
            return
          elseif(kl%rbody(ih) .gt. x)then
            i2=ih
          else
            i1=ih
          endif
        enddo
        kx=dfromr(dble(i1))
      elseif(tfreallistq(ktastk(isp),kll))then
        n=kll%nl
        m=kl%nl
        kx=kxavaloc(-1,n,klr)
        i1=1
        do i=1,n
          i2=min(i1+1,m)
          x=kll%rbody(i)
          if(x .lt. kl%rbody(i1))then
            i2=i1
            i1=1
          elseif(x .eq. kl%rbody(i2))then
            i1=i2
          elseif(x .gt. kl%rbody(i2))then
            i1=i2
            i2=m
          endif
          do while(i2 .gt. i1+1)
            ih=i1+(i2-i1)/2
            if(kl%rbody(ih) .eq. x)then
              i1=ih
              exit
            elseif(kl%rbody(ih) .gt. x)then
              i2=ih
            else
              i1=ih
            endif
          enddo
          klr%rbody(i)=min(i1,m-1)
        enddo
        irtc=0
      else
        irtc=itfmessage(9,'General::wrongval',
     $       '"#2","Real or list of Reals"')
      endif
      return
      end


    Program dspgv_example

!     DSPGV Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dlansp, dspgv, dtpcon
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: uplo = 'U'
!     .. Local Scalars ..
      Real (Kind=dp) :: anorm, bnorm, eps, rcond, rcondb, t1, t2
      Integer :: i, info, j, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: ap(:), bp(:), eerbnd(:), w(:), work(:)
      Real (Kind=dp) :: dummy(1, 1)
      Integer, Allocatable :: iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, epsilon
!     .. Executable Statements ..
      Write (nout, *) 'DSPGV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n

      Allocate (ap((n*(n+1))/2), bp((n*(n+1))/2), eerbnd(n), w(n), work(3*n), &
        iwork(n))

!     Read the upper or lower triangular parts of the matrices A and
!     B from data file

      If (uplo=='U') Then
        Read (nin, *)((ap(i+(j*(j-1))/2),j=i,n), i=1, n)
        Read (nin, *)((bp(i+(j*(j-1))/2),j=i,n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)((ap(i+((2*n-j)*(j-1))/2),j=1,i), i=1, n)
        Read (nin, *)((bp(i+((2*n-j)*(j-1))/2),j=1,i), i=1, n)
      End If

!     Compute the one-norms of the symmetric matrices A and B

      anorm = dlansp('One norm', uplo, n, ap, work)
      bnorm = dlansp('One norm', uplo, n, bp, work)

!     Solve the generalized symmetric eigenvalue problem
!     A*x = lambda*B*x (itype = 1)

      Call dspgv(1, 'No vectors', uplo, n, ap, bp, w, dummy, 1, work, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) w(1:n)

!       Call DTPCON to estimate the reciprocal condition
!       number of the Cholesky factor of B.  Note that:
!       cond(B) = 1/rcond**2

        Call dtpcon('One norm', uplo, 'Non-unit', n, bp, rcond, work, iwork, &
          info)

!       Print the reciprocal condition number of B

        rcondb = rcond**2
        Write (nout, *)
        Write (nout, *) 'Estimate of reciprocal condition number for B'
        Write (nout, 110) rcondb

!       Get the machine precision, eps, and if rcondb is not less
!       than eps**2, compute error estimates for the eigenvalues

        eps = epsilon(1.0E0_dp)
        If (rcond>=eps) Then
          t1 = eps/rcondb
          t2 = anorm/bnorm
          Do i = 1, n
            eerbnd(i) = t1*(t2+abs(w(i)))
          End Do

!         Print the approximate error bounds for the eigenvalues

          Write (nout, *)
          Write (nout, *) 'Error estimates for the eigenvalues'
          Write (nout, 110) eerbnd(1:n)
        Else
          Write (nout, *)
          Write (nout, *) 'B is very ill-conditioned, error ', &
            'estimates have not been computed'
        End If
      Else If (info>n .And. info<=2*n) Then
        i = info - n
        Write (nout, 120) 'The leading minor of order ', i, &
          ' of B is not positive definite'
      Else
        Write (nout, 130) 'Failure in DSPGV. INFO =', info
      End If

100   Format (3X, (6F11.4))
110   Format (4X, 1P, 6E11.1)
120   Format (1X, A, I4, A)
130   Format (1X, A, I4)
    End Program


C$Procedure   NPELPT  ( Nearest point on ellipse to point )

      SUBROUTINE NPELPT ( POINT, ELLIPS, PNEAR, DIST )

C$ Abstract
C
C     Find the nearest point on an ellipse to a specified point, both
C     in three-dimensional space, and find the distance between the
C     ellipse and the point.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     ELLIPSES
C
C$ Keywords
C
C     CONIC
C     ELLIPSE
C     GEOMETRY
C     MATH
C
C$ Declarations

      INTEGER               UBEL
      PARAMETER           ( UBEL    =   9 )

      DOUBLE PRECISION      ELLIPS ( UBEL )
      DOUBLE PRECISION      POINT  (    3 )
      DOUBLE PRECISION      PNEAR  (    3 )
      DOUBLE PRECISION      DIST

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     POINT      I   Point whose distance to an ellipse is to be found.
C     ELLIPS     I   A SPICELIB ellipse.
C     PNEAR      O   Nearest point on ellipse to input point.
C     DIST       O   Distance of input point to ellipse.
C
C$ Detailed_Input
C
C     ELLIPS         is a SPICELIB ellipse that represents an ellipse
C                    in three-dimensional space.
C
C     POINT          is a point in 3-dimensional space.
C
C$ Detailed_Output
C
C     PNEAR          is the nearest point on ELLIPS to POINT.
C
C     DIST           is the distance between POINT and PNEAR.  This is
C                    the distance between POINT and the ellipse.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  Invalid ellipses will be diagnosed by routines called by
C         this routine.
C
C     2)  Ellipses having one or both semi-axis lengths equal to zero
C         are turned away at the door; the error SPICE(DEGENERATECASE)
C         is signalled.
C
C     3)  If the geometric ellipse represented by ELLIPS does not
C         have a unique point nearest to the input point, any point
C         at which the minimum distance is attained may be returned
C         in PNEAR.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Given an ellipse and a point in 3-dimensional space, if the
C     orthogonal projection of the point onto the plane of the ellipse
C     is on or outside of the ellipse, then there is a unique point on
C     the ellipse closest to the original point.  This routine finds
C     that nearest point on the ellipse.  If the projection falls inside
C     the ellipse, there may be multiple points on the ellipse that are
C     at the minimum distance from the original point.  In this case,
C     one such closest point will be returned.
C
C     This routine returns a distance, rather than an altitude, in
C     contrast to the SPICELIB routine NEARPT.  Because our ellipse is
C     situated in 3-space and not 2-space, the input point is not
C     `inside' or `outside' the ellipse, so the notion of altitude does
C     not apply to the problem solved by this routine.  In the case of
C     NEARPT, the input point is on, inside, or outside the ellipsoid,
C     so it makes sense to speak of its altitude.
C
C$ Examples
C
C     1)  For planetary rings that can be modelled as flat disks with
C         elliptical outer boundaries, the distance of a point in
C         space from a ring's outer boundary can be computed using this
C         routine.  Suppose CENTER, SMAJOR, and SMINOR are the center,
C         semi-major axis, and semi-minor axis of the ring's boundary.
C         Suppose also that SCPOS is the position of a spacecraft.
C         SCPOS, CENTER, SMAJOR, and SMINOR must all be expressed in
C         the same coordinate system.  We can find the distance from
C         the spacecraft to the ring using the code fragment
C
C            C
C            C     Make a SPICELIB ellipse representing the ring,
C            C     then use NPELPT to find the distance between
C            C     the spacecraft position and RING.
C            C
C                  CALL CGV2EL ( CENTER, SMAJOR, SMINOR, RING )
C                  CALL NPELPT ( SCPOS,  RING,   PNEAR,  DIST )
C
C
C     2)  The problem of finding the distance of a line from a tri-axial
C         ellipsoid can be reduced to the problem of finding the
C         distance between the same line and an ellipse; this problem in
C         turn can be reduced to the problem of finding the distance
C         between an ellipse and a point.  The routine NPEDLN carries
C         out this process and uses NPELPT to find the ellipse-to-point
C         distance.
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.2.0, 02-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VADD, VSCL, MTXV and MXV calls.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 02-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     nearest point on ellipse to point
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.2.0, 02-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VADD, VSCL, MTXV and MXV calls.
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VNORM
      DOUBLE PRECISION      VDIST

      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION      CENTER ( 3 )
      DOUBLE PRECISION      MAJLEN
      DOUBLE PRECISION      MINLEN
      DOUBLE PRECISION      ROTATE ( 3, 3 )
      DOUBLE PRECISION      SCALE
      DOUBLE PRECISION      SMAJOR ( 3 )
      DOUBLE PRECISION      SMINOR ( 3 )
      DOUBLE PRECISION      TEMPV  ( 3 )
      DOUBLE PRECISION      TMPPNT ( 3 )
      DOUBLE PRECISION      PRJPNT ( 3 )

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'NPELPT' )
      END IF

C
C     Here's an overview of our solution:
C
C        Let ELPL be the plane containing the ELLIPS, and let PRJ be
C        the orthogonal projection of the POINT onto ELPL.  Let X be
C        any point in the plane ELPL.  According to the Pythagorean
C        Theorem,
C
C                           2                       2                  2
C           || POINT - X ||    =   || POINT - PRJ ||   +  || PRJ - X ||.
C
C        Then if we can find a point X on ELLIPS that minimizes the
C        rightmost term, that point X is the closest point on the
C        ellipse to POINT.
C
C        So, we find the projection PRJ, and then solve the problem of
C        finding the closest point on ELLIPS to PRJ.  To solve this
C        problem, we find a triaxial ellipsoid whose intersection with
C        the plane ELPL is precisely ELLIPS, and two of whose axes lie
C        in the plane ELPL.  The closest point on ELLIPS to PRJ is also
C        the closest point on the ellipsoid to ELLIPS.  But we have the
C        SPICELIB routine NEARPT on hand to find the closest point on an
C        ellipsoid to a specified point, so we've reduced our problem to
C        a solved problem.
C
C        There is a subtle point to worry about here:  if PRJ is outside
C        of ELLIPS (PRJ is in the same plane as ELLIPS, so `outside'
C        does make sense here), then the closest point on ELLIPS to PRJ
C        coincides with the closest point on the ellipsoid to PRJ,
C        regardless of how we choose the z-semi-axis length of the
C        ellipsoid.  But the correspondence may be lost if PRJ is inside
C        the ellipse, if we don't choose the z-semi-axis length
C        correctly.
C
C        Though it takes some thought to verify this (and we won't prove
C        it here), making the z-semi-axis of the ellipsoid longer than
C        the other two semi-axes is sufficient to maintain the
C        coincidence of the closest point on the ellipsoid to PRJPNT and
C        the closest point on the ellipse to PRJPNT.
C

C
C     Find the ellipse's center and semi-axes.
C
      CALL EL2CGV ( ELLIPS, CENTER, SMAJOR, SMINOR )

C
C     Find the lengths of the semi-axes, and scale the vectors to try
C     to prevent arithmetic unpleasantness.  Degenerate ellipses are
C     turned away at the door.
C
      MINLEN = VNORM (SMINOR)
      MAJLEN = VNORM (SMAJOR)

      IF (   MIN ( MAJLEN, MINLEN )  .EQ.  0.D0  ) THEN

         CALL SETMSG ( 'Semi-axis lengths: # #. ' )
         CALL ERRDP  ( '#', MAJLEN                )
         CALL ERRDP  ( '#', MINLEN                )
         CALL SIGERR ( 'SPICE(DEGENERATECASE)'    )
         CALL CHKOUT ( 'NPELPT'                   )
         RETURN

      END IF

      SCALE = 1.D0 / MAJLEN

      CALL VSCLIP ( SCALE, SMAJOR )
      CALL VSCLIP ( SCALE, SMINOR )

C
C     Translate ellipse and point so that the ellipse is centered at
C     the origin.  Scale the point's coordinates to maintain the
C     correct relative position to the scaled ellipse.
C
      CALL VSUB   ( POINT, CENTER, TMPPNT )
      CALL VSCLIP ( SCALE,         TMPPNT )

C
C     We want to reduce the problem to a two-dimensional one.  We'll
C     work in a coordinate system whose x- and y- axes are aligned with
C     the semi-major and semi-minor axes of the input ellipse.  The
C     z-axis is picked to give us a right-handed system.  We find the
C     matrix that transforms coordinates to our new system using TWOVEC.
C
      CALL TWOVEC ( SMAJOR, 1, SMINOR, 2, ROTATE )

C
C     Apply the coordinate transformation to our scaled input point.
C
      CALL MXV  ( ROTATE, TMPPNT, TEMPV  )
      CALL VEQU ( TEMPV,          TMPPNT )

C
C     We must find the distance between the orthogonal projection of
C     TMPPNT onto the x-y plane and the ellipse.  The projection is
C     just
C
C        ( TMPPNT(1), TMPPNT(2), 0 );
C
C     we'll call this projection PRJPNT.
C
C
      CALL VPACK ( TMPPNT(1),  TMPPNT(2),  0.D0,  PRJPNT )

C
C     Now we're ready to find the distance between and a triaxial
C     ellipsoid whose intersection with the x-y plane is the ellipse
C     and whose third semi-axis lies on the z-axis.
C
C     Because we've scaled the ellipse's axes so as to give the longer
C     axis length 1, a length of 2.D0 suffices for the ellipsoid's
C     z-semi-axis.
C

C
C     Find the nearest point to PRJPNT on the ellipoid, PNEAR.
C
      CALL NEARPT ( PRJPNT, 1.D0, MINLEN/MAJLEN, 2.D0, PNEAR, DIST )

C
C     Scale the near point coordinates back to the original scale.
C
      CALL VSCLIP ( MAJLEN, PNEAR )

C
C     Apply the required inverse rotation and translation to PNEAR.
C     Compute the point-to-ellipse distance.
C
      CALL MTXV ( ROTATE, PNEAR,  TEMPV )
      CALL VADD ( TEMPV,  CENTER, PNEAR )

      DIST = VDIST ( PNEAR, POINT )

      CALL CHKOUT  ( 'NPELPT' )
      RETURN
      END


program test_plate_motion
!  Find Euler pole for Africa (AF) for NUVEL1A and rotation rate at 0,60

   use plate_motion

   implicit none

   type(plate) :: p1,p2
   character(len=MODEL_NAME_LENGTH) :: model_name
   real(8) :: lon,lat,v(2)

   lon = 0._8
   lat = 60._8

   p1%name = "EU"
   p2%name = "AF"
   model_name = 'HS3-NUVEL1A'

!  Test apm calculation
   call absolute_plate_motion(lon, lat, p1, model_name, v=v)

   write(*,'(a,2(i0,a))') 'Absolute plate motion of Africa at ',int(lon),',',int(lat),':'
   write(*,'("   ",a,f0.2,x,f0.2)') 'E, N:    ',v
   write(*,'("   ",a,f5.1,x,f0.2)') 'az,rate: ', &
      mod(atan2(v(1), v(2))*180._8/3.14159_8+3600._8, 360._8), &
      sqrt(v(1)**2 + v(2)**2)

!  Test relative plate motion calculation
   write(*,'(a,2(i0,a))') 'Relative motion of EU to AF at ',int(lon),',',int(lat),':'
   call relative_plate_motion(lon,lat,P1,P2,model_name,v=v)
   write(*,'("   ",f5.1,x,f0.2)')  mod(atan2(v(1), v(2))*180._8/3.14159_8+3600._8, 360._8), &
      sqrt(v(1)**2 + v(2)**2)

end program


!   To draw the Lissajous figures using given equations & studying the effect of varying phi

program Lissajous
    real::A=1.0, B=2.0, w1=2.0, w2=3.0, pi=4*atan(1.0), i
    real,dimension(100)::x,y,t
    phi=pi
    do i=0,100
        x(i)=A*sin(2*w1*0.1*i)
        y(i)=B*cos(2*w2*0.1*i+phi)
        print*,x(i),y(i)
        write(6,*),x(i),y(i)
    end do
end program


module mod_calculate_flow_velocity

!Moudle contains a function to compute the flow velocity of a river using
!the retention parameter and the cell area and river directio  for diagnostic
!purposes. This is reserving a previous calculation to find the retention parameter

implicit none

contains

function calculate_flow_velocity(retention_constant,FDIR,DLON,nlat,nlon) &
result(flow_velocities)

!As stated above, reserves the retention constant calculation to get the flow parameter

implicit none

!Kind parameters for double precision from JSBACH, could potentially be moved
!to a seperate module to produce a more unified kind scheme with HD scripting
integer, parameter :: pd =  12
integer, parameter :: rd = 307
integer, parameter :: dp = SELECTED_REAL_KIND(pd,rd)

!Variables with intent IN
!Dimension of the input array
integer, intent(in) :: nlat, nlon
!Input retention constant array (in days?)
real(dp), intent(in), dimension(nlon,nlat) :: retention_constants
!River directions array (given as double for historical reasons although it always
!takes integer values).
real(dp), intent(in), dimension(nlon,nlat) :: FDIR
!Longitudal grid spacings (in metres)
real(dp), intent(in), dimension(nlat) :: DLON
!Local variables
!Flow velocities calculated (in m/s)
real(dp), dimension(nlon,nlat) :: flow_velocities
!Loop counters
integer :: JB,JL
!Distance between grid cells centres
real(dp) :: DX
!River flow retention constant normalisation constant
real(dp), parameter :: ARF_K0 = 0.4112
!Grid spacing normalisation parameter (metres)
real(dp), parameter :: ARF_DX = 228000.
!River flow velocity normalisation constant
real(dp), parameter :: ARF_V0 = 1.0039
!Latitudal grid spacing (metres)
real(dp), paramter :: DLAT
!From globuse.f value of DLAT
DLAT = DLON(2)

do JB = 1,nlat
    do JL = 1,nlon
         !Calculate relative coordinates between grid cell and neighbor it flows into
         IB = -( INT( (FDIR(JL,JB)-1.)/3. + 0.1) - 1)
         IL = INT( ( (FDIR(JL,JB)+2.)/3. -
     &        INT((FDIR(JL,JB)+2.)/3. + 0.1) ) * 3. + 0.1) -1
        !Thus calculate the distance between the centres of the grid cells
        DX = SQRT(IB*IB*DLAT*DLAT + IL*IL*DLON(JB)*DLON(JB))
        !Reserve the calculation of the retention constant to give a flow direction
        flow_velocities(JL,JB) = ARF_K0 * DX/ARF_DX * ARF_V0/retention_constants(JL,JB)
    end do
end do

end function calculate_flow_velocity

end module mod_calculate_flow_velocity


!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  User-defined Rate Law functions
!  Note: the default argument type for rate laws, as read from the equations file, is single precision
!        but all the internal calculations are performed in double precision
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

!~~~>  Arrhenius
   KPP_REAL FUNCTION ARR( A0,B0,C0 )
      REAL A0,B0,C0
      ARR =  DBLE(A0) * EXP(-DBLE(B0)/TEMP) * (TEMP/300.0_dp)**DBLE(C0)
   END FUNCTION ARR

!~~~> Simplified Arrhenius, with two arguments
!~~~> Note: The argument B0 has a changed sign when compared to ARR
   KPP_REAL FUNCTION ARR2( A0,B0 )
      REAL A0,B0
      ARR2 =  DBLE(A0) * EXP( DBLE(B0)/TEMP )
   END FUNCTION ARR2

   KPP_REAL FUNCTION EP2(A0,C0,A2,C2,A3,C3)
      REAL A0,C0,A2,C2,A3,C3
      REAL(dp) K0,K2,K3
      K0 = DBLE(A0) * EXP(-DBLE(C0)/TEMP)
      K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP)
      K3 = DBLE(A3) * EXP(-DBLE(C3)/TEMP)
      K3 = K3*CFACTOR*1.0E6_dp
      EP2 = K0 + K3/(1.0_dp+K3/K2 )
   END FUNCTION EP2

   KPP_REAL FUNCTION EP3(A1,C1,A2,C2)
      REAL A1, C1, A2, C2
      REAL(dp) K1, K2
      K1 = DBLE(A1) * EXP(-DBLE(C1)/TEMP)
      K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP)
      EP3 = K1 + K2*(1.0E6_dp*CFACTOR)
   END FUNCTION EP3

   KPP_REAL FUNCTION FALL ( A0,B0,C0,A1,B1,C1,CF)
      REAL A0,B0,C0,A1,B1,C1,CF
      REAL(dp) K0, K1
      K0 = DBLE(A0) * EXP(-DBLE(B0)/TEMP)* (TEMP/300.0_dp)**DBLE(C0)
      K1 = DBLE(A1) * EXP(-DBLE(B1)/TEMP)* (TEMP/300.0_dp)**DBLE(C1)
      K0 = K0*CFACTOR*1.0E6_dp
      K1 = K0/K1
      FALL = (K0/(1.0_dp+K1))*   &
           DBLE(CF)**(1.0_dp/(1.0_dp+(LOG10(K1))**2))
   END FUNCTION FALL

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

  ELEMENTAL REAL(dp) FUNCTION k_3rd(temp,cair,k0_300K,n,kinf_300K,m,fc)

    INTRINSIC LOG10

    REAL(dp), INTENT(IN) :: temp      ! temperature [K]
    REAL(dp), INTENT(IN) :: cair      ! air concentration [molecules/cm3]
    REAL,     INTENT(IN) :: k0_300K   ! low pressure limit at 300 K
    REAL,     INTENT(IN) :: n         ! exponent for low pressure limit
    REAL,     INTENT(IN) :: kinf_300K ! high pressure limit at 300 K
    REAL,     INTENT(IN) :: m         ! exponent for high pressure limit
    REAL,     INTENT(IN) :: fc        ! broadening factor (usually fc=0.6)
    REAL                 :: zt_help, k0_T, kinf_T, k_ratio

    zt_help = 300._dp/temp
    k0_T    = k0_300K   * zt_help**(n) * cair ! k_0   at current T
    kinf_T  = kinf_300K * zt_help**(m)        ! k_inf at current T
    k_ratio = k0_T/kinf_T
    k_3rd   = k0_T/(1._dp+k_ratio)*fc**(1._dp/(1._dp+LOG10(k_ratio)**2))

  END FUNCTION k_3rd

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

  ELEMENTAL REAL(dp) FUNCTION k_arr (k_298,tdep,temp)
    ! Arrhenius function

    REAL,     INTENT(IN) :: k_298 ! k at T = 298.15K
    REAL,     INTENT(IN) :: tdep  ! temperature dependence
    REAL(dp), INTENT(IN) :: temp  ! temperature

    INTRINSIC EXP

    k_arr = k_298 * EXP(tdep*(1._dp/temp-3.3540E-3_dp)) ! 1/298.15=3.3540e-3

  END FUNCTION k_arr

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  End of User-defined Rate Law functions
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


      SUBROUTINE SG02ND( DICO, JOBE, JOB, JOBX, FACT, UPLO, JOBL, TRANS,
     $                   N, M, P, A, LDA, E, LDE, B, LDB, R, LDR, IPIV,
     $                   L, LDL, X, LDX, RNORM, K, LDK, H, LDH, XE,
     $                   LDXE, OUFACT, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the optimal gain matrix K for the problem of optimal
C     control given by
C
C                        -1
C          K = (R + B'XB)  (B'Xop(A) + L')                           (1)
C
C     in the discrete-time case and
C
C               -1
C          K = R  (B'Xop(E) + L')                                    (2)
C
C     in the continuous-time case, where A, E, B and L are N-by-N,
C     N-by-N, N-by-M, and N-by-M matrices, respectively; R and X are
C     M-by-M and N-by-N symmetric matrices, respectively, and op(W) is
C     either W or W'. Matrix op(K) defines the feedback gain matrix, if
C     op(W) = W, and the estimator matrix, if op(W) = W'. The formulas
C     above are also useful in Newton's algorithms for solving algebraic
C     Riccati equations, when X is the current iterate.
C
C     Optionally, matrix R may be specified in a factored form, and L
C     may be zero. If R or R + B'XB (for DICO = 'C', or DICO = 'D',
C     respectively), is positive definite, let C be its Cholesky factor
C     (denoted, e.g., C = chol(R), for DICO = 'C'). Optionally, the
C     matrix H, defined by
C
C          H = op(E)'XB + L, if DICO = 'C', or
C          H = op(A)'XB + L, if DICO = 'D',                          (3)
C
C     is returned on exit, besides K; if C exists, the matrix F, defined
C     by FC = H may be optionally returned, instead of K and H. The
C     matrix F or the pair of matrices H and K may be used for computing
C     the residual matrix for an (approximate) solution of an algebraic
C     Riccati equation (see SLICOT Library routine SG02CW).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the equation from which K is to be determined,
C             as follows:
C             = 'D':  Equation (1), discrete-time case;
C             = 'C':  Equation (2), continuous-time case.
C
C     JOBE    CHARACTER*1
C             Specifies whether E is a general or an identity matrix,
C             as follows:
C             = 'G':  The matrix E is general and is given;
C             = 'I':  The matrix E is assumed identity and is not given.
C             This parameter is not relevant for DICO = 'D'.
C
C     JOB     CHARACTER*1
C             Specifies what should be computed, as follows:
C             = 'K':  Compute and return the matrix K only;
C             = 'H':  Compute and return both matrices H and K;
C             = 'F':  Compute the matrix F, if possible; otherwise,
C                     compute and return H and K;
C             = 'D':  Compute and return both matrices H and K, when
C                     B and L have previously been transformed using
C                     SLICOT Library routines SB02MT or SB02MX, which
C                     returned OUFACT = 1. This is useful for computing
C                     K in (2), since then K is the solution of CK = H'.
C                     In this case, FACT should be set to 'C', and the
C                     array R must contain the Cholesky factor of
C                     R + B'XB, if DICO = 'D';
C             = 'C':  Compute and return the matrix F, when B and L have
C                     previously been transformed using SB02MT or
C                     SB02MX, which returned OUFACT = 1. In this case,
C                     FACT should be set to 'C', and the array R must
C                     contain the Cholesky factor of R + B'XB, if
C                     DICO = 'D'.
C             JOB should not be set to 'F' if FACT = 'U'.
C
C     JOBX    CHARACTER*1
C             Specifies whether the matrix op(Xop(E)), if DICO = 'C', or
C             op(Xop(A)), if DICO = 'D', must be computed, as follows:
C             = 'C':  Compute and return the coresponding matrix;
C             = 'N':  Do not compute that matrix.
C             This parameter is not relevant for DICO = 'C' and
C             JOBE = 'I'.
C
C     FACT    CHARACTER*1
C             Specifies how the matrix R is given (factored or not), as
C             follows:
C             = 'N':  Array R contains the matrix R;
C             = 'D':  Array R contains a P-by-M matrix D, where R = D'D;
C             = 'C':  Array R contains the Cholesky factor of R;
C             = 'U':  Array R contains the symmetric indefinite UdU' or
C                     LdL' factorization of R. This option is not
C                     available for DICO = 'D'.
C
C     UPLO    CHARACTER*1
C             Specifies which triangle of the possibly factored matrix R
C             (or R + B'XB, on exit) is or should be stored, as follows:
C             = 'U':  Upper triangle is stored;
C             = 'L':  Lower triangle is stored.
C
C     JOBL    CHARACTER*1
C             Specifies whether or not the matrix L is zero, as follows:
C             = 'Z':  L is zero;
C             = 'N':  L is nonzero.
C
C     TRANS   CHARACTER*1
C             Specifies the form of op(W) to be used in the matrix
C             multiplication, as follows:
C             = 'N':  op(W) = W;
C             = 'T':  op(W) = W';
C             = 'C':  op(W) = W'.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A and X.  N >= 0.
C             No computations are performed if MIN(N,M) = 0.
C
C     M       (input) INTEGER
C             The order of the matrix R and the number of columns of the
C             matrices B and L.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of the matrix D.
C             P >= M for DICO = 'C';
C             P >= 0 for DICO = 'D'.
C             This parameter is relevant only for FACT = 'D'.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             If DICO = 'D', the leading N-by-N part of this array must
C             contain the state matrix A of the system.
C             If DICO = 'C', this array is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of array A.
C             LDA >= MAX(1,N) if DICO = 'D';
C             LDA >= 1        if DICO = 'C'.
C
C     E       (input) DOUBLE PRECISION array, dimension (LDE,*)
C             If JOBE = 'G' and DICO = 'C', the leading N-by-N part of
C             this array must contain the matrix E.
C             If JOBE = 'I' or DICO = 'D', this array is not referenced.
C
C     LDE     INTEGER
C             The leading dimension of array E.
C             LDE >= MAX(1,N), if JOBE = 'G' and DICO = 'C';
C             LDE >= 1,        if JOBE = 'I'  or DICO = 'D'.
C
C     B       (input/worksp.) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             input matrix B of the system, transformed by SB02MT or
C             SB02MX, if JOB = 'D' or JOB = 'C'.
C             If DICO = 'D' and FACT = 'D' or 'C', the contents of this
C             array is destroyed. Specifically, if, on exit,
C             OUFACT(2) = 1, this array contains chol(X)*B, and if
C             OUFACT(2) = 2 and INFO < M+2, but INFO >= 0, its trailing
C             part (in the first N rows) contains the submatrix of
C             sqrt(V)*U'B corresponding to the non-negligible, positive
C             eigenvalues of X, where V and U are the matrices with the
C             eigenvalues and eigenvectors of X.
C             Otherwise, B is unchanged on exit.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
C             On entry, if FACT = 'N', the leading M-by-M upper
C             triangular part (if UPLO = 'U') or lower triangular part
C             (if UPLO = 'L') of this array must contain the upper
C             triangular part or lower triangular part, respectively,
C             of the symmetric input weighting matrix R.
C             On entry, if FACT = 'D', the leading P-by-M part of this
C             array must contain the direct transmission matrix D of the
C             system.
C             On entry, if FACT = 'C', the leading M-by-M upper
C             triangular part (if UPLO = 'U') or lower triangular part
C             (if UPLO = 'L') of this array must contain the Cholesky
C             factor of the positive definite input weighting matrix R
C             (as produced by LAPACK routine DPOTRF).
C             On entry, if DICO = 'C' and FACT = 'U', the leading M-by-M
C             upper triangular part (if UPLO = 'U') or lower triangular
C             part (if UPLO = 'L') of this array must contain the
C             factors of the UdU' or LdL' factorization, respectively,
C             of the symmetric indefinite input weighting matrix R (as
C             produced by LAPACK routine DSYTRF).
C             The strictly lower triangular part (if UPLO = 'U') or
C             strictly upper triangular part (if UPLO = 'L') of this
C             array is used as workspace (filled in by symmetry with the
C             other strictly triangular part of R, of R+B'XB, or of the
C             result, if DICO = 'C', DICO = 'D' (if FACT = 'N', in both
C             cases), or (DICO = 'D' and (FACT = 'D' or FACT = 'C') and
C             UPLO = 'L'), respectively.
C             On exit, if OUFACT(1) = 1, and INFO = 0 (or INFO = M+1),
C             the leading M-by-M upper triangular part (if UPLO = 'U')
C             or lower triangular part (if UPLO = 'L') of this array
C             contains the Cholesky factor of the given input weighting
C             matrix R (for DICO = 'C'), or that of the matrix R + B'XB
C             (for DICO = 'D').
C             On exit, if OUFACT(1) = 2, and INFO = 0 (or INFO = M+1),
C             the leading M-by-M upper triangular part (if UPLO = 'U')
C             or lower triangular part (if UPLO = 'L') of this array
C             contains the factors of the UdU' or LdL' factorization,
C             respectively, of the given input weighting matrix
C             (for DICO = 'C'), or that of the matrix R + B'XB
C             (for DICO = 'D' and FACT = 'N').
C             On exit R is unchanged if FACT = 'U' or N = 0.
C
C     LDR     INTEGER.
C             The leading dimension of the array R.
C             LDR >= MAX(1,M)   if FACT <> 'D';
C             LDR >= MAX(1,M,P) if FACT =  'D'.
C
C     IPIV    (input/output) INTEGER array, dimension (M)
C             On entry, if FACT = 'U', this array must contain details
C             of the interchanges performed and the block structure of
C             the d factor in the UdU' or LdL' factorization of matrix R
C             (as produced by LAPACK routine DSYTRF).
C             On exit, if OUFACT(1) = 2, this array contains details of
C             the interchanges performed and the block structure of the
C             d factor in the UdU' or LdL' factorization of matrix R or
C             R + B'XB, as produced by LAPACK routine DSYTRF.
C             This array is not referenced if FACT = 'D', or FACT = 'C',
C             or N = 0.
C
C     L       (input) DOUBLE PRECISION array, dimension (LDL,M)
C             If JOBL = 'N', the leading N-by-M part of this array must
C             contain the cross weighting matrix L, transformed by
C             SB02MT or SB02MX, if JOB = 'D' or JOB = 'C'.
C             If JOBL = 'Z', this array is not referenced.
C
C     LDL     INTEGER
C             The leading dimension of array L.
C             LDL >= MAX(1,N) if JOBL = 'N';
C             LDL >= 1        if JOBL = 'Z'.
C
C     X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
C             On entry, the leading N-by-N part of this array must
C             contain the (approximate) solution matrix X of the
C             algebraic Riccati equation as produced by SLICOT Library
C             routines SB02MD or SB02OD (or SG02CD). Matrix X is assumed
C             non-negative definite if DICO = 'D', FACT <> 'N',
C             JOB <> 'D' and JOB <> 'C'. The full matrix X must be given
C             on input in this case.
C             For minimal workspace, full matrix X must also be given if
C             ((JOBX = 'C', DICO = 'D', FACT = 'N', and M > N), or
C              (JOBX = 'N', ((DICO = 'C' or FACT = 'N'), (DICO = 'D' or
C               JOBE = 'I') or N >= M, or LDWORK < N*N) and (DICO = 'D'
C               or JOBE = 'G' or JOB = 'K'))) and LDWORK < N*M.
C             (Simpler, but more demanding conditions are the following:
C             ((JOBX = 'C',  DICO = 'D', FACT = 'N', and M > N), or
C              (JOBX = 'N', (DICO = 'D' or ((DICO = 'C', JOBE = 'G') or
C               JOB = 'K'))),  LDWORK < N*N.)
C             For optimal workspace, full matrix X is not needed in any
C             of the cases described above for minimal workspace.
C             On exit, if DICO = 'D', FACT = 'D' or FACT = 'C', and
C             OUFACT(2) = 1, the N-by-N upper triangular part
C             (if UPLO = 'U') or lower triangular part (if UPLO = 'L')
C             of this array contains the Cholesky factor of the given
C             matrix X, which is found to be positive definite.
C             On exit, if DICO = 'D', FACT = 'D' or 'C', OUFACT(2) = 2,
C             and INFO <> M+2 (but INFO >= 0), the leading N-by-N part
C             of this array contains the matrix of orthonormal
C             eigenvectors of X.
C             On exit X is unchanged if DICO = 'C' or FACT = 'N'.
C
C     LDX     INTEGER
C             The leading dimension of array X.  LDX >= MAX(1,N).
C
C     RNORM   (input) DOUBLE PRECISION
C             If FACT = 'U', this parameter must contain the 1-norm of
C             the original matrix R (before factoring it).
C             Otherwise, this parameter is not used.
C
C     K       (output) DOUBLE PRECISION array, dimension (LDK,N)
C             If JOB = 'K' or JOB = 'H' or JOB = 'D' or OUFACT(1) = 2,
C             the leading M-by-N part of this array contains the gain
C             matrix K.
C
C     LDK     INTEGER
C             The leading dimension of array K.  LDK >= MAX(1,M).
C
C     H       (output) DOUBLE PRECISION array, dimension (LDH,*)
C             If JOB = 'H' or JOB = 'D' or (JOB = 'F' and
C             OUFACT(1) = 2), the leading N-by-M part of this array
C             contains the matrix H.
C             If JOB = 'C' or (JOB = 'F' and OUFACT(1) = 1), the leading
C             N-by-M part of this array contains the matrix F.
C             If JOB = 'K', this array is not referenced.
C
C     LDH    INTEGER
C             The leading dimension of array H.
C             LDH >= MAX(1,N), if JOB <> 'K';
C             LDH >= 1,        if JOB =  'K'.
C
C     XE      (output) DOUBLE PRECISION array, dimension (LDXE,*)
C             If JOBX = 'C', DICO = 'C', and JOBE = 'G', the leading
C             N-by-N part of this array contains the matrix product X*E,
C             if TRANS = 'N', or E*X, if TRANS = 'T' or TRANS = 'C'.
C             If JOBX = 'C' and DICO = 'D', the leading N-by-N part of
C             this array contains the matrix product X*A, if
C             TRANS = 'N', or A*X, if TRANS = 'T' or TRANS = 'C'.
C             These matrix products may be needed for computing the
C             residual matrix for an (approximate) solution of a Riccati
C             equation (see SLICOT Library routine SG02CW).
C             If JOBX = 'N' or (DICO = 'C' and JOBE = 'I'), this array
C             is not referenced.
C
C     LDXE    INTEGER
C             The leading dimension of array XE.
C             LDXE >= MAX(1,N), if JOBX = 'C', and either DICO = 'C' and
C                               JOBE = 'G', or DICO = 'D';
C             LDXE >= 1,        if JOBX = 'N' or (DICO = 'C' and
C                                                 JOBE = 'I').
C
C     OUFACT  (output) INTEGER array, dimension (2)
C             Information about the factorization finally used.
C             OUFACT(1) = 1:  Cholesky factorization of R (or R + B'XB)
C                             has been used;
C             OUFACT(1) = 2:  UdU' (if UPLO = 'U') or LdL' (if UPLO =
C                             'L') factorization of R (or R + B'XB)
C                             has been used;
C             OUFACT(2) = 1:  Cholesky factorization of X has been used;
C             OUFACT(2) = 2:  Spectral factorization of X has been used.
C             The value of OUFACT(2) is not set for DICO = 'C' or for
C             DICO = 'D' and FACT = 'N'.
C             This array is not set if N = 0 or M = 0.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (M)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0 or LDWORK = -1, DWORK(1) returns the
C             optimal value of LDWORK, and for LDWORK set as specified
C             below, DWORK(2) contains the reciprocal condition number
C             of the matrix R (for DICO = 'C') or of R + B'XB (for
C             DICO = 'D'), if FACT = 'N' or FACT = 'U' or OUFACT(1) = 2,
C             or of its Cholesky factor, if FACT = 'C' or FACT = 'D' and
C             OUFACT(1) = 1; DWORK(2) is set to 1 if N = 0.
C             On exit, if LDWORK = -2 on input or INFO = -35, then
C             DWORK(1) returns the minimal value of LDWORK.
C             If on exit INFO = 0, and OUFACT(2) = 2, then DWORK(3),...,
C             DWORK(N+2) contain the eigenvalues of X, in ascending
C             order.
C
C     LDWORK  INTEGER
C             Dimension of working array DWORK.
C             Let a = N, if JOBX = 'N' and (DICO = 'D' or JOBE = 'G');
C                 a = 0, otherwise. Then
C             LDWORK >= max(2,2*M,a)       if FACT =  'U';
C             LDWORK >= max(2,3*M,4*N+1)   if FACT =  'D' or
C                                            (FACT =  'C' and JOB <> 'C'
C                                          and JOB <> 'D'), DICO = 'D';
C             LDWORK >= max(2,3*M,a)       otherwise.
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, an optimal workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
C
C             If LDWORK = -2, a minimal workspace query is assumed; the
C             routine only calculates the minimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = i:  if the i-th element of the d factor is exactly zero;
C                   the UdU' (or LdL') factorization has been completed,
C                   but the block diagonal matrix d is exactly singular;
C             = M+1:  if the matrix R (if DICO = 'C'), or R + B'XB
C                   (if DICO = 'D') is numerically singular (to working
C                   precision);
C             = M+2:  if one or more of the eigenvalues of X has not
C                   converged;
C             = M+3:  if the matrix X is indefinite and updating the
C                   triangular factorization failed.
C             If INFO > M+1, call the routine again with an appropriate,
C             unfactored matrix R.
C
C     METHOD
C
C     The (optimal) gain matrix K is obtained as the solution to the
C     system of linear equations
C
C        (R + B'XB) * K = B'Xop(A) + L'
C
C     in the discrete-time case and
C
C        R * K = B'Xop(E) + L'
C
C     in the continuous-time case, with R replaced by D'D if FACT = 'D'.
C     If FACT = 'N', Cholesky factorization is tried first, but
C     if the coefficient matrix is not positive definite, then UdU' (or
C     LdL') factorization is used. If FACT <> 'N', the factored form
C     of R is taken into account. The discrete-time case then involves
C     updating of a triangular factorization of R (or D'D); Cholesky or
C     symmetric spectral factorization of X is employed to avoid
C     squaring of the condition number of the matrix. When D is given,
C     its QR factorization is determined, and the triangular factor is
C     used as described above.
C
C     NUMERICAL ASPECTS
C
C     The algorithm consists of numerically stable steps.
C                                                   3     2
C     For DICO = 'C' and JOBE = 'I', it requires O(m  + mn ) floating
C                                            2
C     point operations if FACT = 'N' and O(mn ) floating point
C     operations, otherwise.
C     For DICO = 'D' or JOBE = 'G', the operation counts are similar,
C                       3
C     but additional O(n ) floating point operations may be needed in
C     the worst case.
C     These estimates assume that M <= N.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Jan. 2014.
C
C     REVISIONS
C
C     V. Sima, Feb. 2014, July 2017, Dec. 2017.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, closed loop system, continuous-time
C     system, discrete-time system, matrix algebra, optimal control,
C     optimal regulator.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, FACT, JOB, JOBE, JOBL, JOBX, TRANS, UPLO
      INTEGER           INFO, LDA, LDB, LDE, LDH, LDK, LDL, LDR, LDWORK,
     $                  LDX, LDXE, M, N, P
      DOUBLE PRECISION  RNORM
C     .. Array Arguments ..
      INTEGER           IPIV(*), IWORK(*), OUFACT(2)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), DWORK(*), E(LDE,*),
     $                  H(LDH,*), K(LDK,*), L(LDL,*), R(LDR,*),
     $                  X(LDX,*), XE(LDXE,*)
C     .. Local Scalars ..
      LOGICAL           DISCR, LASTCS, LFACTA, LFACTC, LFACTD, LFACTU,
     $                  LJOBE, LNFACT, LTRANS, LUPLOU, SUFWRK, WITHC,
     $                  WITHCD, WITHD, WITHF, WITHH, WITHL, WITHXE
      CHARACTER         NT, NTRANS, NUPLO, SIDE, TR, TRL
      INTEGER           I, IFAIL, JW, JZ, MS, NM, NR, WRKMIN, WRKOPT
      DOUBLE PRECISION  EPS, RCOND, RNORMP, TEMP, TMP
C     .. Local Arrays ..
      DOUBLE PRECISION  DUMMY(1)
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANSY
      EXTERNAL          DLAMCH, DLANSY, LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEMM, DGEQRF, DLACPY, DLASET,
     $                  DPOCON, DPOTRF, DPOTRS, DSCAL, DSYCON, DSYEV,
     $                  DSYMM, DSYTRF, DSYTRS, DTRCON, DTRMM, DTRSM,
     $                  MA02AD, MA02ED, MB01RB, MB01RU, MB04KD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, INT, MAX, MIN, SQRT
C     .. Executable Statements ..
C
      INFO   = 0
      DISCR  = LSAME( DICO,  'D' )
      LFACTC = LSAME( FACT,  'C' )
      LFACTD = LSAME( FACT,  'D' )
      LFACTU = LSAME( FACT,  'U' )
      LJOBE  = LSAME( JOBE,  'G' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
      LUPLOU = LSAME( UPLO,  'U' )
      WITHC  = LSAME( JOB,   'C' )
      WITHD  = LSAME( JOB,   'D' )
      WITHF  = LSAME( JOB,   'F' )
      WITHH  = LSAME( JOB,   'H' )
      WITHL  = LSAME( JOBL,  'N' )
      WITHXE = LSAME( JOBX,  'C' )
      LFACTA = LFACTC .OR. LFACTD .OR. LFACTU
      WITHCD = WITHC  .OR. WITHD
      WITHH  = WITHH  .OR. WITHF .OR. WITHCD
      LNFACT = .NOT.LFACTA
C
C     Test the input scalar arguments.
C
      IF(       .NOT.DISCR .AND. .NOT.LSAME( DICO,  'C' ) ) THEN
         INFO = -1
      ELSE IF(  .NOT.LJOBE .AND. .NOT.LSAME( JOBE,  'I' ) .AND.
     $                           .NOT.DISCR               ) THEN
         INFO = -2
      ELSE IF( .NOT.WITHH  .AND. .NOT.LSAME( JOB,   'K' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.WITHXE .AND. .NOT.LSAME( JOBX,  'N' ) ) THEN
         IF( DISCR .OR. LJOBE )
     $      INFO = -4
      ELSE IF( (    LNFACT .AND. .NOT.LSAME( FACT,  'N' ) ) .OR.
     $         (    DISCR  .AND. LFACTU ) .OR.
     $       ( .NOT.LFACTC .AND. WITHCD ) ) THEN
         INFO = -5
      ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO,  'L' ) ) THEN
         INFO = -6
      ELSE IF( .NOT.WITHL  .AND. .NOT.LSAME( JOBL,  'Z' ) ) THEN
         INFO = -7
      ELSE IF( .NOT.LTRANS .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN
         INFO = -8
      ELSE IF( N.LT.0 ) THEN
         INFO = -9
      ELSE IF( M.LT.0 ) THEN
         INFO = -10
      ELSE IF( LFACTD .AND. ( P.LT.0 .OR. ( .NOT.DISCR .AND. P.LT.M ) )
     $       ) THEN
         INFO = -11
      ELSE IF( LDA.LT.1 .OR. ( LDA.LT.N .AND.      DISCR ) ) THEN
         INFO = -13
      ELSE IF( LDE.LT.1 .OR. ( LDE.LT.N .AND. .NOT.DISCR
     $                                  .AND.      LJOBE ) ) THEN
         INFO = -15
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE IF( LDR.LT.MAX( 1, M ) .OR. ( LFACTD .AND. LDR.LT.P ) ) THEN
         INFO = -19
      ELSE IF( LDL.LT.1 .OR. ( WITHL .AND. LDL.LT.N ) ) THEN
         INFO = -22
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -24
      ELSE IF( LFACTU ) THEN
         IF( RNORM.LT.ZERO )
     $      INFO = -25
      END IF
      IF ( INFO.EQ.0 ) THEN
         IF( LDK.LT.MAX( 1, M ) ) THEN
            INFO = -27
         ELSE IF( LDH.LT.1  .OR. ( WITHH  .AND.  LDH.LT.N ) ) THEN
            INFO = -29
         ELSE IF( LDXE.LT.1 .OR. ( WITHXE .AND. ( DISCR .OR. LJOBE )
     $                                    .AND. LDXE.LT.N ) ) THEN
            INFO = -31
         ELSE
            IF ( LUPLOU ) THEN
               NUPLO = 'Lower'
            ELSE
               NUPLO = 'Upper'
            END IF
            NM = N*M
            IF ( DISCR .AND. LFACTA .AND. .NOT.WITHCD ) THEN
               WRKMIN = MAX( 2, 3*M, 4*N + 1 )
            ELSE
               IF ( .NOT.WITHXE .AND. ( DISCR .OR. LJOBE ) ) THEN
                  WRKMIN = MAX( 2, N )
               ELSE
                  WRKMIN = 2
               END IF
               IF( LFACTU ) THEN
                  WRKMIN = MAX( WRKMIN, 2*M )
               ELSE
                  WRKMIN = MAX( WRKMIN, 3*M )
               END IF
            END IF
            IF( LDWORK.EQ.-1 ) THEN
               IF ( WITHXE .AND. ( DISCR .OR. LJOBE ) ) THEN
                  IF ( DISCR .AND. LNFACT .AND. M.GT.N ) THEN
                     WRKOPT = NM
                  ELSE
                     WRKOPT = 0
                  END IF
               ELSE IF ( ( ( DISCR .AND. LFACTA ) .OR. ( .NOT.DISCR
     $                             .AND. LJOBE  ) ) .AND. N.LT.M ) THEN
                  WRKOPT = N*N
               ELSE IF ( .NOT.( DISCR .OR. LJOBE ) .AND. WITHH ) THEN
                  WRKOPT = 0
               ELSE
                  WRKOPT = NM
               END IF
C
               IF( LFACTA ) THEN
                  IF ( LFACTD ) THEN
                     CALL DGEQRF( P, M, R, LDR, DWORK, DWORK, -1, IFAIL)
                     WRKOPT = MAX( WRKOPT, INT( DWORK(1) )+MIN( P, M ) )
                  END IF
                  IF( DISCR .AND. .NOT.WITHCD ) THEN
                     CALL DSYEV( 'Vectors', NUPLO, N, X, LDX, DWORK,
     $                           DWORK, -1, IFAIL )
                     WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + N + 2,
     $                             NM + N + 2 )
                  END IF
               ELSE
                  CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, -1, IFAIL )
                  WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
               END IF
               DWORK(1) = MAX( WRKMIN, WRKOPT )
               RETURN
            ELSE IF( LDWORK.EQ.-2 ) THEN
               DWORK(1) = WRKMIN
               RETURN
            ELSE IF( LDWORK.LT.WRKMIN ) THEN
               INFO = -35
               DWORK(1) = WRKMIN
               RETURN
            END IF
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SG02ND', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. M.EQ.0 ) THEN
         DWORK(1) = TWO
         IF ( N.EQ.0 ) THEN
            DWORK(2) = ONE
         ELSE
            DWORK(2) = ZERO
         END IF
         RETURN
      END IF
C
      EPS = DLAMCH( 'Precision' )
C
C     Determine the right-hand side of the matrix equation, and R+B'XB,
C     if needed.
C     1. If JOBX = 'N' or (DICO = 'C' and JOBE = 'I'), compute  B'X
C     in K or XB either in H, if JOB <> 'K', or in the workspace, if
C     enough space. If JOB <> 'K', compute H in (3), otherwise compute
C     H' in K. The same formulas for H are used for JOB = 'D' or
C     JOB = 'C', but B and L on entry are transformed matrices; however,
C     the returned results correspond to the original matrices.
C     2. If JOBX = 'C', compute op(Xop(E)) or op(Xop(A)) in XE, for
C     DICO = 'C' (and JOBE = 'G') or DICO = 'D', respectively.
C     Then, use XE in computations similar to those described above.
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
C     Workspace: need   0;
C                prefer N*N, if M > N and ((DICO = 'D' and FACT <> 'N')
C                                      or  (DICO = 'C' and JOBE =  'G'))
C                                     and   JOBX = 'N';
C                       M*N, otherwise.
C     Only a triangle of X is needed when using the preferred length.
C
      SUFWRK = LDWORK.GE.NM
C
      NT = 'No transpose'
      TR = 'Transpose'
      IF ( LTRANS ) THEN
         NTRANS = NT
         SIDE   = 'Right'
      ELSE
         NTRANS = TR
         SIDE   = 'Left'
      END IF
C
      IF ( WITHL ) THEN
         TEMP = ONE
      ELSE
         TEMP = ZERO
      END IF
C
      IF ( WITHXE .AND. ( DISCR .OR. LJOBE ) ) THEN
         LASTCS = .FALSE.
         IF ( DISCR ) THEN
            IF ( LNFACT ) THEN
C
C              Discrete-time case. Compute a triangle of R + B'XB.
C
               IF ( M.LE.N ) THEN
                  CALL MB01RU( UPLO, TR, M, N, ONE, ONE, R, LDR, B, LDB,
     $                         X, LDX, XE, NM, INFO )
                  WRKOPT = 0
               ELSE IF ( SUFWRK ) THEN
                  CALL DSYMM(  'Left', UPLO, N, M, ONE, X, LDX, B, LDB,
     $                         ZERO, DWORK, N )
                  CALL MB01RB( 'Left', UPLO, TR, M, N, ONE, ONE, R, LDR,
     $                         B, LDB, DWORK, N, IFAIL )
                  WRKOPT = NM
               ELSE
C
C                 This case needs a full matrix X.
C
                  CALL DGEMM(  TR, NT, M, N, N, ONE, B, LDB, X, LDX,
     $                         ZERO, K, LDK )
                  CALL MB01RB( 'Left', UPLO, NT, M, N, ONE, ONE, R, LDR,
     $                         K, LDK, B, LDB, IFAIL )
                  WRKOPT = 0
               END IF
            END IF
            CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, A, LDA, ZERO, XE,
     $                  LDXE )
         ELSE
            CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, E, LDE, ZERO, XE,
     $                  LDXE )
            WRKOPT = 0
         END IF
         IF ( WITHH ) THEN
            IF ( WITHL )
     $         CALL DLACPY( 'All', N, M, L, LDL, H, LDH )
            CALL DGEMM(  NTRANS, NT, N, M, N, ONE, XE, LDXE, B, LDB,
     $                   TEMP, H, LDH )
            CALL MA02AD( 'All', N, M, H, LDH, K, LDK )
         ELSE
            IF ( WITHL )
     $         CALL MA02AD( 'All', N, M, L, LDL, K, LDK )
            CALL DGEMM( TR, TRANS, M, N, N, ONE, B, LDB, XE, LDXE, TEMP,
     $                  K, LDK )
         END IF
C
      ELSE IF ( (( DISCR .AND. LFACTA ) .OR. ( .NOT.DISCR .AND. LJOBE ))
     $                   .AND. N.LT.M  .AND. LDWORK.GE.N*N ) THEN
         LASTCS = .FALSE.
         IF ( DISCR ) THEN
            CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, A, LDA, ZERO,
     $                  DWORK, N )
         ELSE
            CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, E, LDE, ZERO,
     $                  DWORK, N )
         END IF
C
         IF ( WITHH ) THEN
            IF ( WITHL )
     $         CALL DLACPY( 'All', N, M, L, LDL, H, LDH )
            CALL DGEMM(  NTRANS, NT, N, M, N, ONE, DWORK, N, B, LDB,
     $                   TEMP, H, LDH )
            CALL MA02AD( 'All', N, M, H, LDH, K, LDK )
         ELSE
            IF ( WITHL )
     $         CALL MA02AD( 'All', N, M, L, LDL, K, LDK )
            CALL DGEMM( TR, TRANS, M, N, N, ONE, B, LDB, DWORK, N, TEMP,
     $                  K, LDK )
         END IF
         WRKOPT = N*N
C
      ELSE IF ( .NOT.( DISCR .OR. LJOBE ) .AND. WITHH ) THEN
C
C        Continuous-time case, with E identity, JOB <> 'K'.
C
         LASTCS = .FALSE.
C
         IF ( WITHH ) THEN
            IF ( WITHL )
     $         CALL DLACPY( 'All', N, M, L, LDL, H, LDH )
            CALL DSYMM(  'Left', UPLO, N, M, ONE, X, LDX, B, LDB, TEMP,
     $                   H, LDH )
            CALL MA02AD( 'All', N, M, H, LDH, K, LDK )
            WRKOPT = 0
         END IF
C
      ELSE IF ( SUFWRK ) THEN
         LASTCS = .FALSE.
         IF ( DISCR .OR. LJOBE ) THEN
            CALL DSYMM( 'Left', UPLO, N, M, ONE, X, LDX, B, LDB, ZERO,
     $                  DWORK, N )
            IF ( WITHH ) THEN
               IF ( WITHL )
     $            CALL DLACPY( 'All', N, M, L, LDL, H, LDH )
               IF ( DISCR ) THEN
                  CALL DGEMM( NTRANS, NT, N, M, N, ONE, A, LDA, DWORK,
     $                        N, TEMP, H, LDH )
               ELSE
                  CALL DGEMM( NTRANS, NT, N, M, N, ONE, E, LDE, DWORK,
     $                        N, TEMP, H, LDH )
               END IF
               CALL MA02AD( 'All', N, M, H, LDH, K, LDK )
            ELSE
               IF ( WITHL )
     $            CALL MA02AD( 'All', N, M, L, LDL, K, LDK )
               IF ( DISCR ) THEN
                  CALL DGEMM( TR, TRANS, M, N, N, ONE, DWORK, N, A, LDA,
     $                        TEMP, K, LDK )
               ELSE
                  CALL DGEMM( TR, TRANS, M, N, N, ONE, DWORK, N, E, LDE,
     $                        TEMP, K, LDK )
               END IF
            END IF
            WRKOPT = NM
C
        ELSE IF ( .NOT.WITHH .OR. LDWORK.GE.NM ) THEN
C
C           Continuous-time case, E identity.
C
            IF ( WITHH ) THEN
               IF ( WITHL )
     $            CALL DLACPY( 'All', N, M, L, LDL, H, LDH )
               CALL DSYMM(  'Left', UPLO, N, M, ONE, X, LDX, B, LDB,
     $                      TEMP, H, LDH )
               CALL MA02AD( 'All', N, M, H, LDH, K, LDK )
               WRKOPT = 0
            ELSE
               IF ( WITHL )
     $            CALL DLACPY( 'All', N, M, L, LDL, DWORK, N )
               CALL DSYMM(  'Left', UPLO, N, M, ONE, X, LDX, B, LDB,
     $                      TEMP, DWORK, N )
               CALL MA02AD( 'All', N, M, DWORK, N, K, LDK )
               WRKOPT = NM
            END IF
         END IF
C
      ELSE
C
C        This case needs a full matrix X.
C
         LASTCS = .TRUE.
C
         IF( WITHH ) THEN
            CALL DGEMM( NT, NT, N, M, N, ONE, X, LDX, B, LDB, ZERO, H,
     $                  LDH )
         ELSE
            CALL DGEMM( TR, NT, M, N, N, ONE, B, LDB, X, LDX, ZERO, K,
     $                  LDK )
         END IF
         WRKOPT = 0
      END IF
C
      IF ( LNFACT ) THEN
C
C        R not factored.
C
         IF ( DISCR .AND. .NOT.WITHXE ) THEN
C
C           Discrete-time case. Compute a triangle of R + B'XB.
C
            IF ( SUFWRK ) THEN
               CALL MB01RB( 'Left', UPLO, TR, M, N, ONE, ONE, R, LDR,
     $                      DWORK, N, B, LDB, IFAIL )
            ELSE IF( WITHH ) THEN
               CALL MB01RB( 'Left', UPLO, TR, M, N, ONE, ONE, R, LDR, B,
     $                      LDB, H, LDH, IFAIL )
            ELSE
               CALL MB01RB( 'Left', UPLO, NT, M, N, ONE, ONE, R, LDR, K,
     $                      LDK, B, LDB, IFAIL )
            END IF
         END IF
C
C        Compute the 1-norm of the matrix  R  or  R + B'XB.
C        Workspace: need M.
C
         RNORMP = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK )
      END IF
C
      IF ( LASTCS ) THEN
         MS = MAX( INT( LDWORK/N ), 1 )
C
C        Workspace (for DICO = 'D' or JOBE = 'G'): need   N;
C                                                  prefer N*M.
         IF ( WITHH ) THEN
C
C           Premultiply XB by op(A)' or by op(E)' (on block-columns).
C           Add L if needed.
C
            IF ( DISCR ) THEN
C
               DO 10 I = 1, M, MS
                  NR = MIN( MS, M-I+1 )
                  CALL DLACPY( 'All', N, NR, H(1,I), LDH, DWORK, N )
                  IF ( WITHL )
     $               CALL DLACPY( 'All', N, NR, L(1,I), LDL, H(1,I),
     $                            LDH )
                  CALL DGEMM( NTRANS, NT, N, NR, N, ONE, A, LDA, DWORK,
     $                        N, TEMP, H(1,I), LDH )
   10          CONTINUE
C
            ELSE IF ( LJOBE ) THEN
C
               DO 20 I = 1, M, MS
                  NR = MIN( MS, M-I+1 )
                  CALL DLACPY( 'All', N, NR, H(1,I), LDH, DWORK, N )
                  IF ( WITHL )
     $               CALL DLACPY( 'All', N, NR, L(1,I), LDL, H(1,I),
     $                            LDH )
                  CALL DGEMM( NTRANS, NT, N, NR, N, ONE, E, LDE, DWORK,
     $                        N, TEMP, H(1,I), LDH )
   20          CONTINUE
C
            ELSE IF ( WITHL ) THEN
C
               DO 30 I = 1, M
                  CALL DAXPY( N, ONE, L(1,I), 1, K(I,1), LDK )
   30          CONTINUE
C
            END IF
            CALL MA02AD( 'All', N, M, H, LDH, K, LDK )
C
         ELSE
C
C           Postmultiply B'X by op(A) or by op(E) (on block-rows).
C           Add L if needed.
C
            IF ( DISCR ) THEN
C
               DO 40 I = 1, M, MS
                  NR = MIN( MS, M-I+1 )
                  CALL DLACPY( 'All', NR, N, K(I,1), LDK, DWORK, NR )
                  IF ( WITHL )
     $               CALL MA02AD( 'All', N, NR, L(1,I), LDL, K(I,1),
     $                            LDK )
                  CALL DGEMM( NT, TRANS, NR, N, N, ONE, DWORK, NR, A,
     $                        LDA, TEMP, K(I,1), LDK )
   40          CONTINUE
C
            ELSE IF ( LJOBE ) THEN
C
               DO 50 I = 1, M, MS
                  NR = MIN( MS, M-I+1 )
                  CALL DLACPY( 'All', NR, N, K(I,1), LDK, DWORK, NR )
                  IF ( WITHL )
     $               CALL MA02AD( 'All', N, NR, L(1,I), LDL, K(I,1),
     $                            LDK )
                  CALL DGEMM( NT, TRANS, NR, N, N, ONE, DWORK, NR, E,
     $                        LDE, TEMP, K(I,1), LDK )
   50          CONTINUE
C
            ELSE IF ( WITHL ) THEN
C
               DO 60 I = 1, M
                  CALL DAXPY( N, ONE, L(1,I), 1, K(I,1), LDK )
   60          CONTINUE
C
            END IF
         END IF
C
      END IF
C
      WRKOPT = MAX( WRKMIN, WRKOPT )
C
C     Solve the matrix equation.
C
      IF ( LUPLOU ) THEN
         TRL = NT
      ELSE
         TRL = TR
      END IF
C
      IF ( LFACTA ) THEN
C
C        Case 1: Matrix R is given in a factored form.
C
         IF ( LFACTD ) THEN
C
C           Use QR factorization of D.
C           Workspace: need   min(P,M) + M,
C                      prefer min(P,M) + M*NB.
C
            JW = MIN( P, M ) + 1
            CALL DGEQRF( P, M, R, LDR, DWORK, DWORK(JW), LDWORK-JW+1,
     $                   IFAIL )
            WRKOPT = MAX( WRKOPT, INT( DWORK(JW) )+JW-1 )
            IF ( P.LT.M )
     $         CALL DLASET( 'Full', M-P, M, ZERO, ZERO, R(P+1,1), LDR )
C
C           Make positive the diagonal elements of the triangular
C           factor. Construct the strictly lower triangle, if requested.
C
            DO 70 I = 1, M
               IF ( .NOT.LUPLOU )
     $            CALL DCOPY( I-1, R(1,I), 1, R(I,1), LDR )
               IF ( R(I,I).LT.ZERO )
     $            CALL DSCAL( M-I+1, -ONE, R(I,I), LDR )
   70       CONTINUE
C
         END IF
C
         IF ( DISCR .AND. .NOT.WITHCD ) THEN
            JZ = 0
C
C           Discrete-time case. Update the factorization for B'XB.
C           Try first the Cholesky factorization of X, saving the
C           diagonal of X, in order to recover it, if X is not positive
C           definite. In the later case, use spectral factorization.
C           Workspace: need N.
C
            CALL DCOPY(  N, X, LDX+1, DWORK, 1 )
            CALL DPOTRF( UPLO, N, X, LDX, IFAIL )
C
            IF ( IFAIL.EQ.0 ) THEN
C
C              Use Cholesky factorization of X to compute chol(X)*B.
C
               OUFACT(2) = 1
               CALL DTRMM( 'Left', UPLO, TRL, 'Non unit', N, M, ONE, X,
     $                     LDX, B, LDB )
            ELSE
C
C              Use spectral factorization of X, X = UVU'.
C              Workspace: need   4*N+1,
C                         prefer N*(NB+2)+N+2.
C
               JW = N + 3
               OUFACT(2) = 2
               CALL DCOPY( N, DWORK, 1, X, LDX+1 )
               CALL DSYEV( 'Vectors', NUPLO, N, X, LDX, DWORK(3),
     $                     DWORK(JW), LDWORK-JW+1, IFAIL )
               IF ( IFAIL.GT.0 ) THEN
                  INFO = M + 2
                  RETURN
               END IF
               WRKOPT = MAX( WRKOPT, INT( DWORK(JW) )+JW-1 )
               TEMP   = ABS( DWORK(N+2) )*EPS*DBLE( N )
C
C              Check out the positive (semi-)definiteness of X.
C              First, count the negligible eigenvalues.
C
   80          CONTINUE
               IF ( ABS( DWORK(JZ+3) ).LE.TEMP ) THEN
                  JZ = JZ + 1
                  IF ( JZ.LT.N )
     $               GO TO 80
               END IF
C
               IF ( LFACTD .AND. N-JZ+P.LT.M ) THEN
C
C                 The coefficient matrix is (numerically) singular.
C
                  OUFACT(1) = 1
                  DWORK(2)  = ZERO
                  INFO = M + 1
                  RETURN
               END IF
C
               IF ( DWORK(JZ+3).LT.ZERO ) THEN
C
C                 X is not positive (semi-)definite. Updating fails.
C
                  INFO = M + 3
                  RETURN
               ELSE
C
C                 Compute sqrt(V)U'B.
C                 Workspace: need     2*N+2;
C                            prefer N*M+N+2.
C
                  WRKOPT = MAX( WRKOPT, NM + JW - 1 )
                  MS = MAX( INT( ( LDWORK - JW + 1 )/N ), 1 )
C
                  DO 90 I = 1, M, MS
                     NR = MIN( MS, M-I+1 )
                     CALL DLACPY( 'All', N, NR, B(1,I), LDB, DWORK(JW),
     $                            N )
                     CALL DGEMM(  TR, NT, N-JZ, NR, N, ONE, X(1,JZ+1),
     $                            LDX, DWORK(JW), N, ZERO, B(JZ+1,I),
     $                            LDB )
   90             CONTINUE
C
                  DO 100 I = JZ + 1, N
                     CALL DSCAL( M, SQRT( DWORK(I+2) ), B(I,1), LDB )
  100             CONTINUE
C
               END IF
C
            END IF
C
C           Update the triangular factorization.
C
            IF ( .NOT.LUPLOU )
C
C              Transpose the lower triangle for using MB04KD.
C
     $         CALL MA02ED( UPLO, M, R, LDR )
C
C           Workspace: need 2*M.
C
            CALL MB04KD( 'Full', M, 0, N-JZ, R, LDR, B(JZ+1,1), LDB,
     $                   DUMMY, N, DUMMY, M, DWORK, DWORK(M+1) )
C
C           Make positive the diagonal elements of the triangular
C           factor.
C
            DO 110 I = 1, M
               IF ( R(I,I).LT.ZERO )
     $            CALL DSCAL( M-I+1, -ONE, R(I,I), LDR )
  110       CONTINUE
C
            IF ( .NOT.LUPLOU )
C
C              Construct the lower triangle.
C
     $         CALL MA02ED( NUPLO, M, R, LDR )
C
         END IF
C
C        Compute the condition number of the coefficient matrix.
C
         IF ( .NOT.LFACTU ) THEN
C
C           Workspace: need 3*M.
C
            CALL DTRCON( '1-norm', UPLO, 'Non unit', M, R, LDR, RCOND,
     $                    DWORK, IWORK, IFAIL )
            OUFACT(1) = 1
         ELSE
C
C           Workspace: need 2*M.
C
            CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK,
     $                   IWORK, IFAIL )
            OUFACT(1) = 2
         END IF
C
      ELSE
C
C        Case 2: Matrix R is given in an unfactored form.
C
C        Save the given triangle of  R  or  R + B'XB  in the other
C        strict triangle and the diagonal in the workspace, and try
C        Cholesky factorization.
C        Workspace: need M.
C
         CALL DCOPY( M, R, LDR+1, DWORK, 1 )
         CALL MA02ED( UPLO, M, R, LDR )
         CALL DPOTRF( UPLO, M, R, LDR, IFAIL )
         IF( IFAIL.EQ.0 ) THEN
            OUFACT(1) = 1
C
C           Compute the reciprocal of the condition number of R
C           or R + B'XB.
C           Workspace: need 3*M.
C
            CALL DPOCON( UPLO, M, R, LDR, RNORMP, RCOND, DWORK, IWORK,
     $                   IFAIL )
         ELSE
            OUFACT(1) = 2
C
C           Use UdU' or LdL' factorization, first restoring the saved
C           triangle.
C
            CALL DCOPY( M, DWORK, 1, R, LDR+1 )
            CALL MA02ED( NUPLO, M, R, LDR )
C
C           Workspace: need   1,
C                      prefer M*NB.
C
            CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO )
            IF( INFO.GT.0 )
     $         RETURN
            WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
C
C           Compute the reciprocal of the condition number of R.
C           Workspace: need   2*M.
C
            CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORMP, RCOND, DWORK,
     $                   IWORK, IFAIL )
         END IF
      END IF
C
C     Return if the matrix is singular to working precision.
C
      DWORK(2) = RCOND
      IF( RCOND.LT.EPS ) THEN
         INFO = M + 1
         RETURN
      END IF
C
      IF ( OUFACT(1).EQ.1 ) THEN
C
C        Solve the positive definite linear system.
C
         IF ( WITHF ) THEN
            CALL DTRSM(  'Right', UPLO, TRL, 'Non-unit', N, M, ONE, R,
     $                   LDR, H, LDH )
         ELSE IF ( WITHD ) THEN
            CALL DTRMM(  'Right', UPLO, TRL, 'Non-unit', N, M, ONE, R,
     $                   LDR, H, LDH )
            CALL DTRSM(  'Left',  UPLO, TRL, 'Non-unit', M, N, ONE, R,
     $                   LDR, K, LDK )
         ELSE IF ( .NOT.WITHC ) THEN
            CALL DPOTRS( UPLO, M, N, R, LDR, K, LDK, IFAIL )
         END IF
      ELSE
C
C        Solve the indefinite linear system.
C
         CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, K, LDK, IFAIL )
      END IF
C
C     Set the optimal workspace.
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of SG02ND ***
      END