!!# LIBRARY MODULE: <<LIB_genMoments>>
MODULE LIB_genMoments

!!## PURPOSE
!! Contains a library of moment-taking routines, meant for
!! discrete ordinates integration of functions on the sphere,
!! for the most general case.

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE OVERLOADING
!! * Moment0
INTERFACE Moment0
 MODULE PROCEDURE Moment0_Rsp
 MODULE PROCEDURE Moment0_Rdp
END INTERFACE
!! * Moment0 with incoming directions only
INTERFACE Moment0_IN
 MODULE PROCEDURE Moment0_IN_Rsp
 MODULE PROCEDURE Moment0_IN_Rdp
END INTERFACE
!! * Moment0 With outgoing directions only
INTERFACE Moment0_OUT
 MODULE PROCEDURE Moment0_OUT_Rsp
 MODULE PROCEDURE Moment0_OUT_Rdp
END INTERFACE
!! * Moment1
INTERFACE Moment1
 MODULE PROCEDURE Moment1_Rsp
 MODULE PROCEDURE Moment1_Rdp
END INTERFACE
!! * Moment1 for a single dimension
INTERFACE Moment1_Dim
 MODULE PROCEDURE Moment1_Dim_Rsp
 MODULE PROCEDURE Moment1_Dim_Rdp
END INTERFACE
!! * Moment1 with incoming directions only
INTERFACE Moment1_IN
 MODULE PROCEDURE Moment1_IN_Rsp
 MODULE PROCEDURE Moment1_IN_Rdp
END INTERFACE
!! * Moment1 With outgoing directions only
INTERFACE Moment1_OUT
 MODULE PROCEDURE Moment1_OUT_Rsp
 MODULE PROCEDURE Moment1_OUT_Rdp
END INTERFACE
!! * Moment1 for a single dimension
!!   with incoming directions only
INTERFACE Moment1_DimIN
 MODULE PROCEDURE Moment1_DimIN_Rsp
 MODULE PROCEDURE Moment1_DimIN_Rdp
END INTERFACE
!! * Moment1 for a single dimension
!!   with outgoing directions only
INTERFACE Moment1_DimOUT
 MODULE PROCEDURE Moment1_DimOUT_Rsp
 MODULE PROCEDURE Moment1_DimOUT_Rdp
END INTERFACE
!! * Moment1 with normal vector in integral
INTERFACE Moment1_Normal
 MODULE PROCEDURE Moment1_Normal_Rsp
 MODULE PROCEDURE Moment1_Normal_Rdp
END INTERFACE
!! * Moment1 with normal and integration over
!!   inward directions only
INTERFACE Moment1_NormalIN
 MODULE PROCEDURE Moment1_NormalIN_Rsp
 MODULE PROCEDURE Moment1_NormalIN_Rdp
END INTERFACE
!! * Moment1 with normal and integration over
!!   outward directions only
INTERFACE Moment1_NormalOUT
 MODULE PROCEDURE Moment1_NormalOUT_Rsp
 MODULE PROCEDURE Moment1_NormalOUT_Rdp
END INTERFACE
!! * Moment2  (tensor stored in 1D array, diagonal first, then left
!!             to right off-diagonal elements on lower triangular part)
INTERFACE Moment2
 MODULE PROCEDURE Moment2_Rsp
 MODULE PROCEDURE Moment2_Rdp
END INTERFACE
!! * Moment2 for a single dimension pair
INTERFACE Moment2_Dim
 MODULE PROCEDURE Moment2_Dim_Rsp
 MODULE PROCEDURE Moment2_Dim_Rdp
END INTERFACE
!! * Renormalize a quadrature set
INTERFACE RENORMALIZE
! MODULE PROCEDURE RENORMALIZE_Rsp
 MODULE PROCEDURE RENORMALIZE_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: Moment0
PUBLIC :: Moment0_IN
PUBLIC :: Moment0_OUT
PUBLIC :: Moment1
PUBLIC :: Moment1_Dim
PUBLIC :: Moment1_DimIN
PUBLIC :: Moment1_DimOUT
PUBLIC :: Moment1_Normal
PUBLIC :: Moment1_NormalIN
PUBLIC :: Moment1_NormalOUT
PUBLIC :: Moment2
PUBLIC :: Moment2_Dim

PUBLIC :: PRINT_genMomentTest
PUBLIC :: PRINT_QuadratureSet

PUBLIC :: TEST_prodMoment
PUBLIC :: Renormalize

!!## CONTAINED PROCEDURES
CONTAINS

!!### PURE FUNCTION: <Moment0>
PURE FUNCTION Moment0_Rsp( f , x , w ) RESULT(Moment0)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment0.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment0.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION Moment0_Rdp( f , x , w ) RESULT(Moment0)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment0.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment0.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Moment1>
PURE FUNCTION Moment1_Rsp( f , x , w ) RESULT(Moment1)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION Moment1_Rdp( f , x , w ) RESULT(Moment1)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Moment2>
PURE FUNCTION Moment2_Rsp( f , x , w ) RESULT(Moment2)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment2.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment2.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION Moment2_Rdp( f , x , w ) RESULT(Moment2)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment2.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment2.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Moment1_Dim>
PURE FUNCTION Moment1_Dim_Rsp( f , x , w , Dim ) RESULT(Moment1_Dim)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_Dim.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_Dim.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION Moment1_Dim_Rdp( f , x , w , Dim ) RESULT(Moment1_Dim)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_Dim.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_Dim.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Moment2_Dim>
PURE FUNCTION Moment2_Dim_Rsp(  f , x , w , Dim1,Dim2 ) RESULT(Moment2_Dim)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment2_Dim.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment2_Dim.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION Moment2_Dim_Rdp(  f , x , w , Dim1,Dim2 ) RESULT(Moment2_Dim)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment2_Dim.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment2_Dim.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Moment1_Normal>
PURE FUNCTION Moment1_Normal_Rsp( f , x , w , u ) RESULT(Moment1_Normal)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_Normal.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_Normal.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION Moment1_Normal_Rdp( f , x , w , u ) RESULT(Moment1_Normal)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_Normal.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_Normal.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Moment1_NormalIN>
PURE FUNCTION Moment1_NormalIN_Rsp( f , x , w , u ) RESULT(Moment1_NormalIN)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_NormalIN.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_NormalIN.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION Moment1_NormalIN_Rdp( f , x , w , u ) RESULT(Moment1_NormalIN)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_NormalIN.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_NormalIN.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Moment1_NormalOUT>
PURE FUNCTION Moment1_NormalOUT_Rsp( f , x , w , u ) RESULT(Moment1_NormalOUT)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_NormalOUT.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_NormalOUT.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION Moment1_NormalOUT_Rdp( f , x , w , u ) RESULT(Moment1_NormalOUT)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_NormalOUT.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_NormalOUT.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Moment0_OUT>
PURE FUNCTION Moment0_OUT_Rsp( f , x , w , u ) RESULT(Moment0_OUT)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment0_OUT.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment0_OUT.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION Moment0_OUT_Rdp( f , x , w , u ) RESULT(Moment0_OUT)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment0_OUT.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment0_OUT.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Moment0_IN>
PURE FUNCTION Moment0_IN_Rsp( f , x , w , u ) RESULT(Moment0_IN)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment0_IN.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment0_IN.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION Moment0_IN_Rdp( f , x , w , u ) RESULT(Moment0_IN)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment0_IN.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment0_IN.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Moment1_IN>
PURE FUNCTION Moment1_IN_Rsp( f , x , w , u ) RESULT(Moment1_IN)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_IN.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_IN.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION Moment1_IN_Rdp( f , x , w , u ) RESULT(Moment1_IN)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_IN.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_IN.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Moment1_OUT>
PURE FUNCTION Moment1_OUT_Rsp( f , x , w , u ) RESULT(Moment1_OUT)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_OUT.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_OUT.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION Moment1_OUT_Rdp( f , x , w , u ) RESULT(Moment1_OUT)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_OUT.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_OUT.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Moment1_DimIN>
PURE FUNCTION Moment1_DimIN_Rsp( f , x , w , Dim , u ) RESULT(Moment1_DimIN)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_DimIN.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_DimIN.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION Moment1_DimIN_Rdp( f , x , w , Dim , u ) RESULT(Moment1_DimIN)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_DimIN.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_DimIN.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Moment1_DimOUT>
PURE FUNCTION Moment1_DimOUT_Rsp( f , x , w , Dim , u ) RESULT(Moment1_DimOUT)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_DimOUT.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_DimOUT.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION Moment1_DimOUT_Rdp( f , x , w , Dim , u ) RESULT(Moment1_DimOUT)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments.f90.hdr"
INCLUDE "13-B-LIB_genMoments__Moment1_DimOUT.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__Moment1_DimOUT.f90.bdy"
!!--end--
END FUNCTION

SUBROUTINE TEST_prodMoment(Unit)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
USE SUB_genQuadrature_FROM_prod               !!((07-B-SUB_genQuadrature_FROM_prod.f90))
USE SUB_prodQuadrature                        !!((07-B-SUB_prodQuadrature.f90))

!!#### OPTIONAL INPUT
INTEGER,OPTIONAL,INTENT(IN) :: Unit

!!#### LOCAL VARIABLES
INTEGER :: aorder,porder,errint,m,Nm
CHARACTER(100) :: errmsg
REAL(KIND_R),POINTER :: wa(:),xp(:),wp(:),xa(:,:),x(:,:),w(:)
INTEGER,POINTER :: m_map(:,:)

!!--begin--

!initialize
NULLIFY( wa,xa,wp,xp,m_map,x,w )

!get the orders
WRITE(*,*)"<aOrder> <pOrder>"
READ(*,*)aOrder,pOrder

!get the product quadrature
CALL prodQuadrature( "GL" , aOrder , &
                     "dGL" , pOrder , &
                      xa , xp , wa , wp , &
                      errint , errmsg , &
                      UniformZGeometry=.FALSE. )

!get the general quadrature
CALL genQuadrature_FROM_prod( xa , xp , wa , wp , &
  m_map , x , w , errint , errmsg )

CALL PRINT_genMomentTest(x,w,Unit)

!!--end--
END SUBROUTINE

SUBROUTINE PRINT_QuadratureSet(x,w,Unit)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
USE PRN_RowVectors                            !!((12-C-PRN_RowVectors.f90))
USE PAR_Constants_Rdp,ONLY: c_1_by_4_times_PI !!((02-A-PAR_Constants_Rdp.f90))
USE FUN_STR                                   !!((05-B-FUN_STR.f90))
USE VAR_Units                                 !!((03-A-VAR_Units.f90))
USE FUN_Default                               !!((04-A-FUN_Default.f90))

REAL(KIND_R),POINTER :: x(:,:),w(:)
INTEGER,INTENT(IN),OPTIONAL :: Unit

INTEGER :: Unit_,i
REAL(KIND_R),POINTER :: f(:)
REAL(KIND_R) :: coeff,resid,tol
LOGICAL :: Pass
REAL(KIND_R),POINTER :: xplusw(:,:)
CHARACTER(10),POINTER :: NAME_x(:)

!!--begin--
Unit_ = DEFAULT(DEFAULT_OUTPUT_UNIT,Unit)

!print row vectors
WRITE(Unit_,*)" * Directions $\vec{\Omega}$ and weights $w$"
ALLOCATE( xplusw(SIZE(x,1)+1,SIZE(x,2)) ,NAME_x(SIZE(x,2)) )
xplusw(1:SIZE(x,1),:) = x
xplusw(1+SIZE(x,1),:) = w
DO i=1,SIZE(x,2)
 NAME_x(i) = TRIM(STR(i))
END DO
CALL PRINT_RowVectors( xplusw , unit=Unit_ , NAME_x=NAME_x , &
  NAME_i=(/"Ox(m)","Oy(m)","Oz(m)","w(m) "/) , NAME_index="m" )
DEALLOCATE( xplusw , NAME_x )
!!--end--
END SUBROUTINE

SUBROUTINE PRINT_genMomentTest(x,w,Unit)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
USE PRN_RowVectors                            !!((12-C-PRN_RowVectors.f90))
USE PAR_Constants_Rdp,ONLY: c_1_by_4_times_PI !!((02-A-PAR_Constants_Rdp.f90))
USE FUN_STR                                   !!((05-B-FUN_STR.f90))
USE VAR_Units                                 !!((03-A-VAR_Units.f90))
USE FUN_Default                               !!((04-A-FUN_Default.f90))

REAL(KIND_R),POINTER :: x(:,:),w(:)
INTEGER,INTENT(IN),OPTIONAL :: Unit
INTEGER :: Unit_,i
REAL(KIND_R),POINTER :: f(:)
REAL(KIND_R) :: coeff,resid,tol
LOGICAL :: Pass
REAL(KIND_R),POINTER :: xplusw(:,:)
CHARACTER(10),POINTER :: NAME_x(:)

!!--begin--
Unit_ = DEFAULT(DEFAULT_OUTPUT_UNIT,Unit)

WRITE(Unit_,*)" * Diagnostic Tests of Moment Taking Routines"
!** set the test function <f>
ALLOCATE( f(SIZE(w)) )
f = c_1_by_4_times_Pi

!** Test of 0th moment integration such that full=half1+half2
tol = -1._KIND_R
Pass = TEST_Mom0f( f,x,w,tol=tol,resid=resid )
WRITE(Unit_,"(1x,a)")"Mom0f: "//MERGE("PASS","FAIL",Pass)//"("//TRIM(STR(resid,"(Es7.1)"))//&
  "/"//TRIM(STR(tol,"(Es7.1)"))//")"

!** Test of 1st moment integration such that full=half1+half2
tol = -1._KIND_R
Pass = TEST_Mom1f( f,x,w,tol=tol,resid=resid )
WRITE(Unit_,"(1x,a)")"Mom1f: "//MERGE("PASS","FAIL",Pass)//"("//TRIM(STR(resid,"(Es7.1)"))//&
  "/"//TRIM(STR(tol,"(Es7.1)"))//")"

!** Test of 1st moment integration such that getting each dimension individually
!   is the same as returning the full vector
tol = -1._KIND_R
Pass = TEST_Mom1d( f,x,w,tol=tol,resid=resid )
WRITE(Unit_,"(1x,a)")"Mom1d: "//MERGE("PASS","FAIL",Pass)//"("//TRIM(STR(resid,"(Es7.1)"))//&
  "/"//TRIM(STR(tol,"(Es7.1)"))//")"

!** Test of 2nd moment integration such that getting each dimension individually
!   is the same as returning the full tensor
tol = -1._KIND_R
Pass = TEST_Mom2d( f,x,w,tol=tol,resid=resid )
WRITE(Unit_,"(1x,a)")"Mom2d: "//MERGE("PASS","FAIL",Pass)//"("//TRIM(STR(resid,"(Es7.1)"))//&
  "/"//TRIM(STR(tol,"(Es7.1)"))//")"

!** print tables where we check the moments
WRITE(Unit_,*)" * Full Integral Check"
CALL PRINT_MomentsCheck0(x,w,Unit=Unit_)
WRITE(Unit_,*)" * Half Integral Check (+/- x half-spaces)"
CALL PRINT_MomentsCheck1(x,w,Unit=Unit_,u=(/1._KIND_R,0._KIND_R,0._KIND_R/))
WRITE(Unit_,*)" * Half Integral Check (+/- y half-spaces)"
CALL PRINT_MomentsCheck1(x,w,Unit=Unit_,u=(/0._KIND_R,1._KIND_R,0._KIND_R/))
WRITE(Unit_,*)" * Half Integral Check (+/- z half-spaces)"
CALL PRINT_MomentsCheck1(x,w,Unit=Unit_,u=(/0._KIND_R,0._KIND_R,1._KIND_R/))
WRITE(Unit_,*)" * Half Integral with Normal Check (+/- x half-spaces)"
CALL PRINT_MomentsCheck2(x,w,Unit=Unit_,u=(/1._KIND_R,0._KIND_R,0._KIND_R/))
WRITE(Unit_,*)" * Half Integral with Normal Check (+/- y half-spaces)"
CALL PRINT_MomentsCheck2(x,w,Unit=Unit_,u=(/0._KIND_R,1._KIND_R,0._KIND_R/))
WRITE(Unit_,*)" * Half Integral with Normal Check (+/- z half-spaces)"
CALL PRINT_MomentsCheck2(x,w,Unit=Unit_,u=(/0._KIND_R,0._KIND_R,1._KIND_R/))

!!--end--
END SUBROUTINE

SUBROUTINE PRINT_MomentsCheck0( x,w,Unit )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rdp                         !!((02-A-PAR_Constants_Rdp.f90))
USE FUN_STR                                   !!((05-B-FUN_STR.f90))
USE PRN_Table                                 !!((11-B-PRN_Table.f90))
USE SUB_CLEAR                                 !!((04-A-SUB_CLEAR.f90))
REAL(KIND_R),INTENT(IN) :: x(:,:),w(SIZE(x,2))
REAL(KIND_R) :: f(SIZE(x,2))
INTEGER,INTENT(IN),OPTIONAL :: Unit
CHARACTER(64),ALLOCATABLE :: T(:,:)
REAL(KIND_R) :: m0,m1(3),m2(6)

!!--begin--

ALLOCATE( T(11,5) )
CALL CLEAR(T)
T(2:,1 ) = (/"0  ","1x ","1y ","1z ","2xx","2yy","2zz","2xy","2xz","2yz"/)
T(1 ,2:) = (/" 1/4*pi","Ox/4*pi","Oy/4*pi","Oz/4*pi"/)

f = c_1_by_4_times_PI
CALL UpdateColumn(2)

f = x(1,:)*c_1_by_4_times_PI
CALL UpdateColumn(3)

f = x(2,:)*c_1_by_4_times_PI
CALL UpdateColumn(4)

f = x(3,:)*c_1_by_4_times_PI
CALL UpdateColumn(5)

CALL PRINT_Table(T,Unit=Unit)

DEALLOCATE( T )

!!--end--
CONTAINS

SUBROUTINE UpdateColumn(col)
INTEGER,INTENT(IN) :: col

m0 = Moment0(f,x,w)
m1 = Moment1(f,x,w)
m2 = Moment2(f,x,w)
T(02,col) = STR(m0,"(F)")
T(03,col) = STR(m1(1),"(F)")
T(04,col) = STR(m1(2),"(F)")
T(05,col) = STR(m1(3),"(F)")
T(06,col) = STR(m2(1),"(F)")
T(07,col) = STR(m2(2),"(F)")
T(08,col) = STR(m2(3),"(F)")
T(09,col) = STR(m2(4),"(F)")
T(10,col) = STR(m2(5),"(F)")
T(11,col) = STR(m2(6),"(F)")

END SUBROUTINE

END SUBROUTINE

SUBROUTINE RENORMALIZE_Rdp(x,w)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(INOUT) :: x(:,:),w(SIZE(x,2))
REAL(KIND_R) :: c_4pi,sum_w,norm_x
INTEGER :: m
!!--begin--
c_4pi = 8*ACOS(0._KIND_R)

!make sure weights add up to 4pi
sum_w = SUM(w)
w = c_4pi*w/sum_w

!make sure the directions are unit vectors
DO m=1,SIZE(x,2)
 norm_x = SQRT(SUM(x(:,m)**2))
 x(:,m) = x(:,m)/norm_x
END DO

!!--end--
END SUBROUTINE

SUBROUTINE PRINT_MomentsCheck1( x,w,Unit,u)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rdp                         !!((02-A-PAR_Constants_Rdp.f90))
USE FUN_STR                                   !!((05-B-FUN_STR.f90))
USE PRN_Table                                 !!((11-B-PRN_Table.f90))
USE SUB_CLEAR                                 !!((04-A-SUB_CLEAR.f90))
USE FUN_Default                               !!((04-A-FUN_Default.f90))
REAL(KIND_R),INTENT(IN) :: x(:,:),w(SIZE(x,2))
REAL(KIND_R),INTENT(IN),OPTIONAL :: u(SIZE(x,1))
REAL(KIND_R) :: f(SIZE(x,2))
INTEGER,INTENT(IN),OPTIONAL :: Unit
CHARACTER(64),ALLOCATABLE :: T(:,:)
REAL(KIND_R) :: m0,mi(3),mo(3),u_(3)

!!--begin--
u_ = DEFAULT( (/1._KIND_R,0._KIND_R,0._KIND_R/) , u )

ALLOCATE( T(9,5) )
CALL CLEAR(T)
T(2:,1 ) = (/"IN-0  ","IN-1x ","IN-1y ","IN-1z ","OUT-0 ","OUT-1x","OUT-1y","OUT-1z"/)
T(1 ,2:) = (/" 1/4*pi","Ox/4*pi","Oy/4*pi","Oz/4*pi"/)

f = c_1_by_4_times_PI
CALL UpdateColumn(2)

f = x(1,:)*c_1_by_4_times_PI
CALL UpdateColumn(3)

f = x(2,:)*c_1_by_4_times_PI
CALL UpdateColumn(4)

f = x(3,:)*c_1_by_4_times_PI
CALL UpdateColumn(5)

CALL PRINT_Table(T,Unit=Unit)

DEALLOCATE( T )

!!--end--
CONTAINS

SUBROUTINE UpdateColumn(col)
INTEGER,INTENT(IN) :: col

mi = Moment1_IN (f,x,w,u_)
mo = Moment1_OUT(f,x,w,u_)

m0 = Moment0_IN(f,x,w,u_)
T(02,col) = STR(m0,"(F)")
T(03,col) = STR(mi(1),"(F)")
T(04,col) = STR(mi(2),"(F)")
T(05,col) = STR(mi(3),"(F)")

m0 = Moment0_OUT(f,x,w,u_)
T(06,col) = STR(m0,"(F)")
T(07,col) = STR(mo(1),"(F)")
T(08,col) = STR(mo(2),"(F)")
T(09,col) = STR(mo(3),"(F)")

END SUBROUTINE

END SUBROUTINE

SUBROUTINE PRINT_MomentsCheck2( x,w,Unit,u)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rdp                         !!((02-A-PAR_Constants_Rdp.f90))
USE FUN_STR                                   !!((05-B-FUN_STR.f90))
USE PRN_Table                                 !!((11-B-PRN_Table.f90))
USE SUB_CLEAR                                 !!((04-A-SUB_CLEAR.f90))
USE FUN_Default                               !!((04-A-FUN_Default.f90))
REAL(KIND_R),INTENT(IN) :: x(:,:),w(SIZE(x,2))
REAL(KIND_R),INTENT(IN),OPTIONAL :: u(SIZE(x,1))
REAL(KIND_R) :: f(SIZE(x,2))
INTEGER,INTENT(IN),OPTIONAL :: Unit
CHARACTER(64),ALLOCATABLE :: T(:,:)
REAL(KIND_R) :: m,mi,mo,u_(3)

!!--begin--
u_ = DEFAULT( (/1._KIND_R,0._KIND_R,0._KIND_R/) , u )

ALLOCATE( T(4,5) )
CALL CLEAR(T)
T(2:,1 ) = (/"1    ","IN-1 ","OUT-1"/)
T(1 ,2:) = (/" 1/4*pi","Ox/4*pi","Oy/4*pi","Oz/4*pi"/)

f = c_1_by_4_times_PI
CALL UpdateColumn(2)

f = x(1,:)*c_1_by_4_times_PI
CALL UpdateColumn(3)

f = x(2,:)*c_1_by_4_times_PI
CALL UpdateColumn(4)

f = x(3,:)*c_1_by_4_times_PI
CALL UpdateColumn(5)

CALL PRINT_Table(T,Unit=Unit)

DEALLOCATE( T )

!!--end--
CONTAINS

SUBROUTINE UpdateColumn(col)
INTEGER,INTENT(IN) :: col

m  = Moment1_Normal   (f,x,w,u_)
mi = Moment1_NormalIN (f,x,w,u_)
mo = Moment1_NormalOUT(f,x,w,u_)

T(02,col) = STR(m ,"(F)")
T(03,col) = STR(mi,"(F)")
T(04,col) = STR(mo,"(F)")

END SUBROUTINE

END SUBROUTINE

FUNCTION TEST_Mom0f( f,x,w,tol,resid ) RESULT(Pass)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments__TEST.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__TEST.f90.sup"
INCLUDE "13-B-LIB_genMoments__TEST_Mom0f.f90.bdy"
INCLUDE "13-B-LIB_genMoments__TEST.f90.wup"
!!--end--
END FUNCTION

FUNCTION TEST_Mom1f( f,x,w,tol,resid ) RESULT(Pass)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments__TEST.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__TEST.f90.sup"
INCLUDE "13-B-LIB_genMoments__TEST_Mom1f.f90.bdy"
INCLUDE "13-B-LIB_genMoments__TEST.f90.wup"
!!--end--
END FUNCTION

FUNCTION TEST_Mom1d( f,x,w,tol,resid ) RESULT(Pass)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments__TEST.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__TEST.f90.sup"
INCLUDE "13-B-LIB_genMoments__TEST_Mom1d.f90.bdy"
INCLUDE "13-B-LIB_genMoments__TEST.f90.wup"
!!--end--
END FUNCTION

FUNCTION TEST_Mom2d( f,x,w,tol,resid ) RESULT(Pass)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "13-B-LIB_genMoments__TEST.f90.hdr"
!!--begin--
INCLUDE "13-B-LIB_genMoments__TEST.f90.sup"
INCLUDE "13-B-LIB_genMoments__TEST_Mom2d.f90.bdy"
INCLUDE "13-B-LIB_genMoments__TEST.f90.wup"
!!--end--
END FUNCTION

END MODULE


subroutine bvls ( m, n, a, b, bnd, x, rnorm, nsetp, w, index, ierr )

!*****************************************************************************80
!
!! BVLS solves a least squares problem with bounds on the variables.
!
!  Discussion:
!
!    Given an M by N matrix, A, and an M-vector, B,  compute an
!    N-vector, X, that solves the least-squares problem
!      A * X = B
!    subject to the lower and upper bounds:
!      BND(1,1:N) <= X(J) <= BND(2,1:N)
!
!    In cases where no bound is intended, simply set the corresponding entry
!    of BND to a very negative or very positive value.
!
!    This algorithm is a generalization of NNLS, which solves
!    the least-squares problem,
!      A * X = B
!    subject to the constraints
!      0 <= X(1:N).
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    22 June 2014
!
!  Author:
!
!    Original FORTRAN90 version by Charles Lawson, Richard Hanson.
!    This FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Charles Lawson, Richard Hanson,
!    Solving Least Squares Problems,
!    SIAM, 1995,
!    ISBN: 0898713560,
!    LC: QA275.L38.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N, the number of rows and columns in A.
!
!    Input/output, real ( kind = 8 ) A(M,N).
!    On input, A() contains the M by N matrix, A.
!    On output, A() contains the product matrix, Q*A, where
!    Q is an M by M orthogonal matrix generated by this
!    subroutine.  The dimensions are M=size(A,1) and N=size(A,2).
!
!    Input/output, real ( kind = 8 ) B(M).
!    On input, B() contains the M-vector, B.
!    On output, B() contains Q*B.  The same Q multiplies A.
!
!    Input, real ( kind = 8 ) BND(2,N), lower and upper bounds for X.
!    BND(1,J) <= X(J) <= BND(2,J).
!
!    Output, real ( kind = 8 ) X(N), the solution vector.
!
!    Output, real ( kind = 8 ) RNORM, the Euclidean norm of the residual
!    vector, b - A*X.
!
!    Output, integer ( kind = 4 ) NSETP, the number of components of the
!    solution vector, X(), that are not at their constraint values.
!
!    Output, real ( kind = 8 ) W(N), the dual solution vector.
!    Using Set definitions below:
!    * W(J) = 0 for all j in Set P,
!    * W(J)  <=  0 for all j in Set Z, such that X(J) is at its
!      lower bound, and
!    * W(J)  >=  0 for all j in Set Z, such that X(J) is at its
!      upper bound.
!    If BND(1,J) = BND(2,J), so the variable X(J) is fixed,
!    then W(J) will have an arbitrary value.
!
!    Output, integer ( kind = 4 ) INDEX(N), defines the sets P, Z, and F:
!    * INDEX(1)   through INDEX(NSETP) =  Set P.
!    * INDEX(IZ1) through INDEX(IZ2)      = Set Z.
!    * INDEX(IZ2+1) through INDEX(N)     = Set F.
!    * IZ1 = NSETP + 1 = NPP1
!    Any of these sets may be empty.  Set F is those components
!    that are constrained to a unique value by the given
!    constraints.   Sets P and Z are those that are allowed a non-zero
!    range of values.  Of these, set Z are those whose final
!    value is a constraint value, while set P are those whose
!    final value is not a constraint.  The value of IZ2 is not returned.
!    It is computable as the number of bounds constraining a component
!    of X uniquely.
!
!    Output, integer ( kind = 4 ) IERR, status flag.
!    * 0, Solution completed.
!    * 1, M  <=  0 or N  <=  0
!    * 2, B(:), X(:), BND(:,:), W(:), or INDEX(:) size or shape violation.
!    * 3, Input bounds are inconsistent.
!    * 4, Exceed maximum number of iterations.
!
!  Local Parameters:
!
!   ITMAX  [integer]
!       Set to 100*N.  Maximum number of iterations permitted.
!       This is usually larger than required.  Library software will
!       likely make this an optional argument.
!
!   ITER   [integer]
!       Iteration counter.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  real ( kind = 8 ) b(m)
  real ( kind = 8 ) bnd(2,n)
  logical ( kind = 4 ) find
  logical ( kind = 4 ) free
  integer ( kind = 4 ) ierr
  integer ( kind = 4 ) index(n)
  integer ( kind = 4 ) iter
  integer ( kind = 4 ) itmax
  integer ( kind = 4 ) iz
  integer ( kind = 4 ) iz1
  integer ( kind = 4 ) iz2
  integer ( kind = 4 ) j
  integer ( kind = 4 ) npp1
  integer ( kind = 4 ) nsetp
  real ( kind = 8 ), parameter :: one = 1.0D+00
  real ( kind = 8 ) rnorm
  real ( kind = 8 ) up
  real ( kind = 8 ) w(n)
  real ( kind = 8 ) x(n)
  real ( kind = 8 ) z(m)

  call initialize ( m, n, a, b, bnd, ierr, index, iter, itmax, &
    iz, iz1, iz2, j, npp1, nsetp, w, x )

  do
!
!  Quit (failure) on error flag.
!
    if ( ierr /= 0 ) then
      exit
    end if
!
!  Quit (success) if all coefficients are already in the solution
!
    if ( iz2 < iz1 ) then
      exit
    end if
!
!  Quit (success) if M columns of A have been triangularized.
!
    if ( m <= nsetp ) then
      exit
    end if

    call select_another_coeff ( m, n, iz, iz1, iz2, j, npp1, nsetp, free, &
      up, b, bnd, index, x, a, w, find, z )
!
!  Quit if no index was found to move from set Z to set P.
!
    if ( .not. find ) then
      exit
    end if

    call move_index_j ( m, n, iz, iz2, j, up, iz1, npp1, a, index, w, &
      z, nsetp, b )

    call test_set_p_against_constraints ( m, n, a, b, bnd, index, iter, &
      itmax, iz1, npp1, nsetp, x, z, ierr )

  end do

  call termination ( ierr, m, n, npp1, b, w, rnorm )

  return
end
subroutine bvls_report ( m, n, a, b, bnd, x, rnorm, nsetp, w, index, ierr )

!*****************************************************************************80
!
!! BVLS_REPORT reports on the results of a successful call to BVLS.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    25 June 2014
!
!  Author:
!
!    Original FORTRAN90 version by Charles Lawson, Richard Hanson.
!    This FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Charles Lawson, Richard Hanson,
!    Solving Least Squares Problems,
!    SIAM, 1995,
!    ISBN: 0898713560,
!    LC: QA275.L38.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N, the number of rows and columns in A.
!
!    Input, real ( kind = 8 ) A(M,N), the matrix.
!
!    Input, real ( kind = 8 ) B(M), the right-hand-side vector, B.
!
!    Input, real ( kind = 8 ) BND(2,N), lower and upper bounds on X.
!
!    Input, real ( kind = 8 ) X(N), the solution vector.
!
!    Input, real ( kind = 8 ) RNORM, the Euclidean norm of the residual
!    vector, b - A*X.
!
!    Input, integer ( kind = 4 ) NSETP, the number of components of the
!    solution vector, X(), that are not at their constraint values.
!
!    Input, real ( kind = 8 ) W(N), the dual solution vector.
!
!    Input, integer ( kind = 4 ) INDEX(N), defines the sets P, Z, and F:
!    * INDEX(1)   through INDEX(NSETP) =  Set P.
!    * INDEX(IZ1) through INDEX(IZ2) = Set Z.
!    * INDEX(IZ2+1) through INDEX(N) = Set F.
!    * IZ1 = NSETP + 1 = NPP1
!    Any of these sets may be empty.  Set F is those components
!    that are constrained to a unique value by the given
!    constraints.   Sets P and Z are those that are allowed a non-
!    zero range of values.  Of these, set Z are those whose final
!    value is a constraint value, while set P are those whose
!    final value is not a constraint.  The value of IZ2 is not returned.
!    It is computable as the number of bounds constraining a component
!    of X uniquely.
!
!    Input, integer ( kind = 4 ) IERR, status flag.
!    * 0, Solution completed.
!    * 1, M  <=  0 or N  <=  0
!    * 2, B(:), X(:), BND(:,:), W(:), or INDEX(:) size or shape violation.
!    * 3, Input bounds are inconsistent.
!    * 4, Exceed maximum number of iterations.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  real ( kind = 8 ) b(m)
  real ( kind = 8 ) bnd(2,n)
  integer ( kind = 4 ) ierr
  integer ( kind = 4 ) index(n)
  integer ( kind = 4 ) nsetp
  real ( kind = 8 ) r(m)
  real ( kind = 8 ) rnorm
  real ( kind = 8 ) rnorm2
  real ( kind = 8 ) w(n)
  real ( kind = 8 ) w2(n)
  real ( kind = 8 ) x(n)

  write ( *, '(a)' ) ''
  write ( *, '(a)' ) 'BVLS_REPORT:'

  if ( ierr /= 0 ) then
    write ( *, '(a,i8)' ) '  Abnormal error flag, IERR = ', ierr
    return
  end if

  write ( *, '(a,i8)' ) '  Number of components not at constraints =', nsetp
!
!  X
!
  write ( *, '(a)' ) ''
  write ( *, '(a)' ) '  Solution vector, X:'
  write ( *, '(a)' ) ''
  write ( *, '(2x,5g14.6)' ) x(1:n)
!
!  INDEX
!
  write ( *, '(a)' ) ''
  write ( *, '(a)' ) '  Variable index INDEX:'
  write ( *, '(a)' ) ''
  write ( *, '(2x,5i14)' ) index(1:n)
!
!  R = B - A * X
!
  r(1:m) = b(1:m) - matmul ( a(1:m,1:n), x(1:n) )
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Residual R = B - A*X:'
  write ( *, '(a)' ) ' '
  write ( *, '(2x,5g14.6)' ) r(1:m)
!
!  ||R||
!
  rnorm2 = sqrt ( dot_product ( r(1:m), r(1:m) ) )
  write ( *, '(a)' ) ' '
  write ( *, '(a,g17.5)') '  Residual norm           = ', rnorm2
  write ( *, '(a,g17.5)') '  Residual norm from BVLS = ', rnorm
!
!  W2 = A'*R
!
  w2(1:n) = matmul ( r(1:m), a(1:m,1:n) )
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Dual vector: W = (A'')*R:'
  write ( *, '(a)' ) ' '
  write ( *, '(2x,5g14.6)' ) w2(1:n)
!
!  W: Dual vector.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Dual vector from BVLS: W'
  write ( *, '(a)' ) ' '
  write ( *, '(2x,5g14.6)' ) w(1:n)

  return
end
subroutine constrained_feasible ( nsetp, index, bnd, x, z, hitbnd, alpha, &
  jj, ibound )

!*****************************************************************************80
!
!! CONSTRAINED_FEASIBLE determines if each coefficient is interior.
!
!  Discussion:
!
!    See if each coefficient in set P is strictly interior to its constraint
!    region.
!
!    If so, set HITBND = false.
!
!    If not, set HITBND = true, and also set ALPHA, JJ, and IBOUND.
!    Then ALPHA will satisfy 0 < ALPHA <= 1.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    11 June 2014
!
!  Author:
!
!    Original FORTRAN90 version by Charles Lawson, Richard Hanson.
!    This FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Charles Lawson, Richard Hanson,
!    Solving Least Squares Problems,
!    SIAM, 1995,
!    ISBN: 0898713560,
!    LC: QA275.L38.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) NSETP.
!
!    Input, integer ( kind = 4 ) INDEX(N), defines the sets P, Z, and F.
!
!    Input, real ( kind = 8 ) BND(2,N).
!
!    Input, real ( kind = 8 ) X(N).
!
!    Input, real ( kind = 8 ) Z(M).
!
!    Output, logical HITBND.
!
!    Output, real ( kind = 8 ) ALPHA.
!
!    Output, integer ( kind = 4 ) JJ.
!
!    Output, integer ( kind = 4 ) IBOUND.
!
  implicit none

  integer ( kind = 4 ) nsetp

  real ( kind = 8 ) alpha
  real ( kind = 8 ) bnd(2,*)
  logical ( kind = 4 ) hitbnd
  integer ( kind = 4 ) ibound
  integer ( kind = 4 ) index(*)
  integer ( kind = 4 ) ip
  integer ( kind = 4 ) jj
  integer ( kind = 4 ) l
  integer ( kind = 4 ) lbound
  real ( kind = 8 ) t
  real ( kind = 8 ) x(*)
  real ( kind = 8 ) z(*)

  alpha = 2.0D+00

  do ip = 1, nsetp

    l = index(ip)
!
!  Z(IP) hits lower bound
!
    if ( z(ip) <= bnd(1,l) ) then

      lbound = 1
!
!  Z(IP) hits upper bound
!
    else if ( bnd(2,l) <= z(ip) ) then

      lbound = 2
!
!  Z(IP) is in the interior:
!
    else
      lbound = 0
    end if

    if ( lbound /= 0 ) then
      t = ( bnd(lbound,l) - x(l) ) / ( z(ip) - x(l) )
      if ( t < alpha ) then
        alpha = t
        jj = ip
        ibound = lbound
      end if
    end if

  end do

  hitbnd = ( 0.0D+00 < abs ( alpha - 2.0D+00 ) )

  return
end
subroutine htc ( p, m, u, up )

!*****************************************************************************80
!
!! HTC constructs a Householder transformation.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    12 June 2014
!
!  Author:
!
!    Original FORTRAN90 version by Charles Lawson, Richard Hanson.
!    This FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Charles Lawson, Richard Hanson,
!    Solving Least Squares Problems,
!    SIAM, 1995,
!    ISBN: 0898713560,
!    LC: QA275.L38.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) P, an index into the U vector.
!
!    Input, integer ( kind = 4 ) M, the length of U.
!
!    Input/output, real ( kind = 8 ) U(M).
!
!    Output, real ( kind = 8 ) UP.
!
  implicit none

  integer ( kind = 4 ) m

  real ( kind = 8 ) nrm2
  integer ( kind = 4 ) p
  real ( kind = 8 ) u(m)
  real ( kind = 8 ) up
  real ( kind = 8 ) vnorm

  vnorm = nrm2 ( m + 1 - p, u(p:m) )

  if ( 0.0D+00 < u(p) ) then
    vnorm = - vnorm
  end if

  up = u(p) - vnorm
  u(p) = vnorm

  return
end
subroutine initialize ( m, n, a, b, bnd, ierr, index, iter, itmax, &
  iz, iz1, iz2, j, npp1, nsetp, w, x )

!*****************************************************************************80
!
!! INITIALIZE initializes internal data.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    22 June 2014
!
!  Author:
!
!    Original FORTRAN90 version by Charles Lawson, Richard Hanson.
!    This FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Charles Lawson, Richard Hanson,
!    Solving Least Squares Problems,
!    SIAM, 1995,
!    ISBN: 0898713560,
!    LC: QA275.L38.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N, the dimensions of the matrix.
!
!    Input, real ( kind = 8 ) A(M,N), the matrix.
!
!    Input, real ( kind = 8 ) B(M).
!
!    Input, real ( kind = 8 ) BND(2,N).
!
!    Output, integer ( kind = 4 ) IERR.
!
!    Output, integer ( kind = 4 ) INDEX(N), defines the sets P, Z, and F.
!
!    Output, integer ( kind = 4 ) ITER.
!
!    Output, integer ( kind = 4 ) ITMAX.
!
!    Output, integer ( kind = 4 ) IZ.
!
!    Output, integer ( kind = 4 ) IZ1.
!
!    Output, integer ( kind = 4 ) IZ2.
!
!    Output, integer ( kind = 4 ) J.
!
!    Output, integer ( kind = 4 ) NPP1.
!
!    Output, integer ( kind = 4 ) NSETP.
!
!    Output, real ( kind = 8 ) W(N).
!
!    Output, real ( kind = 8 ) X(N).
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  real ( kind = 8 ) b(m)
  real ( kind = 8 ) bnd(2,n)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ierr
  integer ( kind = 4 ) index(n)
  integer ( kind = 4 ) iter
  integer ( kind = 4 ) itmax
  integer ( kind = 4 ) iz
  integer ( kind = 4 ) iz1
  integer ( kind = 4 ) iz2
  integer ( kind = 4 ) j
  integer ( kind = 4 ) npp1
  integer ( kind = 4 ) nsetp
  real ( kind = 8 ), parameter :: one = 1.0D+00
  real ( kind = 8 ) r
  real ( kind = 8 ) w(n)
  real ( kind = 8 ) x(n)

  ierr = 0
  itmax = 100 * n
  iter = 0
!
!  Initialize the array index().
!
  do i = 1, n
    index(i) = i
  end do

  iz2 = n
  iz1 = 1
  nsetp = 0
  npp1 = 1
!
!  Loop on IZ to initialize X().
!
  iz = iz1

  do

    if ( iz2 < iz ) then
      exit
    end if

    j = index(iz)

    if ( bnd(1,j) <= - huge ( one ) ) then

      if ( huge ( one ) <= bnd(2,j) ) then
        x(j) = 0.0D+00
      else
        x(j) = min ( 0.0D+00, bnd(2,j) )
      end if

    else if ( huge ( one ) <= bnd(2,j) ) then

      x(j) = max ( 0.0D+00, bnd(1,j) )

    else

      r = bnd(2,j) - bnd(1,j)
!
!  Here X(J) is constrained to a single value.
!
      if ( r <= 0.0D+00 ) then

        index(iz) = index(iz2)
        index(iz2) = j
        iz = iz - 1
        iz2 = iz2 - 1
        x(j) = bnd(1,j)
        w(j) = 0.0D+00
!
!  Sets X(J) to 0 if the constraint interval includes 0;
!  otherwise set X(J) to the endpoint of the constraint interval closest to 0.
!
      else if ( 0.0D+00 < r ) then

        x(j) = max ( bnd(1,j), min ( bnd(2,j), 0.0D+00 ) )

      else

        ierr = 3
        return

      end if

    end if
!
!  Change B() to reflect a nonzero starting value for X(J).
!
    if ( 0.0D+00 < abs ( x(j) ) ) then
      b(1:m) = b(1:m) - a(1:m,j) * x(j)
    end if

    iz = iz + 1

  end do

  return
end
subroutine move_coef_i ( m, n, i, ibound, bnd, jj, b, a, x, nsetp, index, &
  npp1, iz1 )

!*****************************************************************************80
!
!! MOVE_COEF_I moves coefficient I from set P to set Z.
!
!  Discussion:
!
!    Modify A(*,*), B(*) and the index arrays to move coefficient I
!    from set P to set Z.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    12 June 2014
!
!  Author:
!
!    Original FORTRAN90 version by Charles Lawson, Richard Hanson.
!    This FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Charles Lawson, Richard Hanson,
!    Solving Least Squares Problems,
!    SIAM, 1995,
!    ISBN: 0898713560,
!    LC: QA275.L38.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the number of rows of A.
!
!    Input, integer ( kind = 4 ) N, the number of columns of A.
!
!    Input, integer ( kind = 4 ) I, the index of the coefficient to be moved.
!
!    Input, integer ( kind = 4 ) IBOUND.
!
!    Input, real ( kind = 8 ) BND(2,N).
!
!    Input, integer ( kind = 4 ) JJ.
!
!    Input/output, real ( kind = 8 ) B(M).
!
!    Input/output, real ( kind = 8 ) A(M,N), the matrix.
!
!    Input/output, real ( kind = 8 ) X(N).
!
!    Input/output, integer ( kind = 4 ) NSETP.
!
!    Input/output, integer ( kind = 4 ) INDEX(N), defines the sets P, Z, and F.
!
!    Input/output, integer ( kind = 4 ) NPP1.
!
!    Input/output, integer ( kind = 4 ) IZ1.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  real ( kind = 8 ) b(m)
  real ( kind = 8 ) bnd(2,n)
  real ( kind = 8 ) cc
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ibound
  integer ( kind = 4 ) ii
  integer ( kind = 4 ) index(n)
  integer ( kind = 4 ) iz1
  integer ( kind = 4 ) j
  integer ( kind = 4 ) jj
  integer ( kind = 4 ) npp1
  integer ( kind = 4 ) nsetp
  real ( kind = 8 ) s(n)
  real ( kind = 8 ) sm
  real ( kind = 8 ) ss
  real ( kind = 8 ) x(n)

  x(i) = bnd(ibound,i)

  if ( 0.0D+00 < abs ( x(i) ) .and. 0 < jj ) then
    b(1:jj) = b(1:jj) - a(1:jj,i) * x(i)
  end if

  do j = jj + 1, nsetp

    ii = index(j)
    index(j-1) = ii
    call rotg ( a(j-1,ii), a(j,ii), cc, ss )
    sm = a(j-1,ii)
!
!  The plane rotation is applied to two rows of A and the right-hand
!  side.  One row is moved to the scratch array S and then the updates
!  are computed.  The intent is for array operations to be performed
!  and minimal extra data movement.  One extra rotation is applied
!  to column II in this approach.
!
    s(1:n) = a(j-1,1:n)
    a(j-1,1:n) = cc * s(1:n) + ss * a(j,1:n)
    a(j,1:n) = cc * a(j,1:n) - ss * s(1:n)

    a(j-1,ii) = sm
    a(j,ii) = 0.0D+00

    sm = b(j-1)
    b(j-1) = cc * sm + ss * b(j)
    b(j) = cc * b(j) - ss * sm

  end do

  npp1 = nsetp
  nsetp = nsetp - 1
  iz1 = iz1 - 1
  index(iz1) = i

  return
end
subroutine move_index_j ( m, n, iz, iz2, j, up, iz1, npp1, a, index, w, &
  z, nsetp, b )

!*****************************************************************************80
!
!! MOVE_INDEX_J moves the index J from set Z to set P.
!
!  Discussion:
!
!    The index J=index(IZ) has been selected to be moved from
!    set Z to set P.  Z() contains the old B() adjusted as though X(J) = 0.
!
!    A(*,J) contains the new Householder transformation vector.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    11 June 2014
!
!  Author:
!
!    Original FORTRAN90 version by Charles Lawson, Richard Hanson.
!    This FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Charles Lawson, Richard Hanson,
!    Solving Least Squares Problems,
!    SIAM, 1995,
!    ISBN: 0898713560,
!    LC: QA275.L38.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M.
!
!    Input, integer ( kind = 4 ) N.
!
!    Input, integer ( kind = 4 ) IZ.
!
!    Input, integer ( kind = 4 ) IZ2.
!
!    Input, integer ( kind = 4 ) J, the index to be moved.
!
!    Input, real ( kind = 8 ) UP.
!
!    Input/output, integer ( kind = 4 ) IZ1.
!
!    Input/output, integer ( kind = 4 ) NPP1.
!
!    Input/output, real ( kind = 8 ) A(M,N), the matrix.
!
!    Input/output, integer ( kind = 4 ) INDEX(N), defines the sets P, Z, and F.
!
!    Input/output, real ( kind = 8 ) W(N).
!
!    Input/output, real ( kind = 8 ) Z(M).
!
!    Output, integer ( kind = 4 ) NSETP.
!
!    Output, real ( kind = 8 ) B(M).
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  real ( kind = 8 ) b(m)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ii
  integer ( kind = 4 ) index(n)
  integer ( kind = 4 ) iz
  integer ( kind = 4 ) iz1
  integer ( kind = 4 ) iz2
  integer ( kind = 4 ) j
  integer ( kind = 4 ) jj
  integer ( kind = 4 ) jz
  integer ( kind = 4 ) l
  real ( kind = 8 ) norm
  integer ( kind = 4 ) npp1
  integer ( kind = 4 ) nsetp
  real ( kind = 8 ) sm
  real ( kind = 8 ) up
  real ( kind = 8 ) w(n)
  real ( kind = 8 ) z(m)

  b(1:m) = z(1:m)

  index(iz) = index(iz1)
  index(iz1) = j
  iz1 = iz1 + 1
  nsetp = npp1
  npp1 = npp1 + 1

  norm = a(nsetp,j)
  a(nsetp,j) = up

  if ( 0.0D+00 < abs ( norm ) ) then

    do jz = iz1, iz2
      jj = index(jz)
      sm = dot_product ( a(nsetp:m,j) / norm, a(nsetp:m,jj) ) / up
      a(nsetp:m,jj) = a(nsetp:m,jj) + sm * a(nsetp:m,j)
    end do

    a(nsetp,j) = norm

  end if

  a(npp1:m,j) = 0.0D+00

  w(j) = 0.0D+00
!
!  Solve the triangular system.
!  Store the solution temporarily in Z().
!
  do i = nsetp, 1, -1
    if ( i /= nsetp ) then
      z(1:i) = z(1:i) - a(1:i,ii) * z(i+1)
    end if
    ii = index(i)
    z(i) = z(i) / a(i,ii)
  end do

  return
end
function nrm2 ( n, x )

!*****************************************************************************80
!
!! NRM2 returns the Euclidean norm of a vector.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    11 June 2014
!
!  Author:
!
!    Original FORTRAN90 version by Charles Lawson, Richard Hanson.
!    This FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Charles Lawson, Richard Hanson,
!    Solving Least Squares Problems,
!    SIAM, 1995,
!    ISBN: 0898713560,
!    LC: QA275.L38.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the length of the vector.
!
!    Input, real ( kind = 8 ) X(N), the vector.
!
!    Output, real ( kind = 8 ) NRM2, the norm of the vector.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) absxi
  integer ( kind = 4 ) ix
  real ( kind = 8 ) norm
  real ( kind = 8 ) nrm2
  real ( kind = 8 ) scale
  real ( kind = 8 ) ssq
  real ( kind = 8 ) x(n)

  if ( n < 1 ) then
    norm = 0.0D+00
  else if ( n == 1 ) then
    norm = abs ( x(1) )
  else
    scale = 0.0D+00
    ssq = 1.0D+00

    do ix = 1, n
      absxi = abs ( x(ix) )
      if ( 0.0D+00 < absxi ) then
        if ( scale < absxi ) then
          ssq = 1.0D+00 + ssq * ( scale / absxi )**2
          scale = absxi
        else
          ssq = ssq + ( absxi / scale )**2
        end if
      end if
    end do
    norm  = scale * sqrt ( ssq )
  end if

  nrm2 = norm

  return
end
subroutine r8mat_uniform_01 ( m, n, seed, r )

!*****************************************************************************80
!
!! R8MAT_UNIFORM_01 fills an R8MAT with unit pseudorandom numbers.
!
!  Discussion:
!
!    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    11 August 2004
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Springer Verlag, pages 201-202, 1983.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, pages 362-376, 1986.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, pages 136-143, 1969.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N, the number of rows and columns in
!    the array.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R(M,N), the array of pseudorandom values.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  integer ( kind = 4 ), parameter :: i4_huge = 2147483647
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  integer ( kind = 4 ) seed
  real ( kind = 8 ) r(m,n)

  do j = 1, n

    do i = 1, m

      k = seed / 127773

      seed = 16807 * ( seed - k * 127773 ) - k * 2836

      if ( seed < 0 ) then
        seed = seed + i4_huge
      end if

      r(i,j) = real ( seed, kind = 8 ) * 4.656612875D-10

    end do
  end do

  return
end
subroutine r8vec_uniform_01 ( n, seed, r )

!*****************************************************************************80
!
!! R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC.
!
!  Discussion:
!
!    An R8VEC is a vector of R8's.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    05 July 2006
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Springer Verlag, pages 201-202, 1983.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, pages 362-376, 1986.
!
!    Peter Lewis, Allen Goodman, James Miller
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, pages 136-143, 1969.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of entries in the vector.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R(N), the vector of pseudorandom values.
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  integer ( kind = 4 ) k
  integer ( kind = 4 ) seed
  real ( kind = 8 ) r(n)

  if ( seed == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'R8VEC_UNIFORM_01 - Fatal error!'
    write ( *, '(a)' ) '  Input value of SEED = 0.'
    stop 1
  end if

  do i = 1, n

    k = seed / 127773

    seed = 16807 * ( seed - k * 127773 ) - k * 2836

    if ( seed < 0 ) then
      seed = seed + 2147483647
    end if

    r(i) = real ( seed, kind = 8 ) * 4.656612875D-10

  end do

  return
end
subroutine rotg ( sa, sb, c, s )

!*****************************************************************************80
!
!! ROTG defines a Givens rotation.
!
!  Discussion:
!
!    Given values A and B, this routine computes
!
!    SIGMA = sign ( A ) if abs ( A ) >  abs ( B )
!          = sign ( B ) if abs ( A ) <= abs ( B );
!
!    R     = SIGMA * ( A * A + B * B );
!
!    C = A / R if R is not 0
!      = 1     if R is 0;
!
!    S = B / R if R is not 0,
!        0     if R is 0.
!
!    The computed numbers then satisfy the equation
!
!    (  C  S ) ( A ) = ( R )
!    ( -S  C ) ( B ) = ( 0 )
!
!    The routine also computes
!
!    Z = S     if abs ( A ) > abs ( B ),
!      = 1 / C if abs ( A ) <= abs ( B ) and C is not 0,
!      = 1     if C is 0.
!
!    The single value Z encodes C and S, and hence the rotation:
!
!    If Z = 1, set C = 0 and S = 1;
!    If abs ( Z ) < 1, set C = sqrt ( 1 - Z * Z ) and S = Z;
!    if abs ( Z ) > 1, set C = 1/ Z and S = sqrt ( 1 - C * C );
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    15 June 2014
!
!  Author:
!
!    Original FORTRAN90 version by Charles Lawson, Richard Hanson.
!    This FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Charles Lawson, Richard Hanson,
!    Solving Least Squares Problems,
!    SIAM, 1995,
!    ISBN: 0898713560,
!    LC: QA275.L38.
!
!  Parameters:
!
!    Input/output, real ( kind = 8 ) SA, the value of A.
!    On output, SA is overwritten with R.
!
!    Input, real ( kind = 8 ) SB, the value of B.
!
!    Output, real ( kind = 8 ) C, S, the cosine and sine of the
!    Givens rotation.
!
  implicit none

  real ( kind = 8 ) c
  real ( kind = 8 ) r
  real ( kind = 8 ) roe
  real ( kind = 8 ) s
  real ( kind = 8 ) sa
  real ( kind = 8 ) sb
  real ( kind = 8 ) scale

  roe = sb

  if ( abs ( sb ) < abs ( sa ) ) then
    roe = sa
  end if

  scale = abs ( sa ) + abs ( sb )

  if ( scale <= 0.0D+00 ) then
    c = 1.0D+00
    s = 0.0D+00
    return
  end if

  r = scale * sqrt ( ( sa / scale ) ** 2 + ( sb / scale ) ** 2 )

  if ( roe < 0.0D+00 ) then
    r = - r
  end if

  c = sa / r
  s = sb / r
  sa = r

  return
end
subroutine select_another_coeff ( m, n, iz, iz1, iz2, j, npp1, nsetp, free, &
  up, b, bnd, index, x, a, w, find, z )

!*****************************************************************************80
!
!! SELECT_ANOTHER_COEFF searches set Z for a new coefficient to solve for.
!
!  Discussion:
!
!    1. Search through set z for a new coefficient to solve for.
!    First select a candidate that is either an unconstrained
!    coefficient or else a constrained coefficient that has room
!    to move in the direction consistent with the sign of its dual
!    vector component.  Components of the dual (negative gradient)
!    vector will be computed as needed.
!
!    2. For each candidate start the transformation to bring this
!    candidate into the triangle, and then do two tests:  Test size
!    of new diagonal value to avoid extreme ill-conditioning, and
!    the value of this new coefficient to be sure it moved in the
!    expected direction.
!
!    3. if some coefficient passes all these conditions, set FIND = true,
!    The index of the selected coefficient is J = INDEX(IZ).
!
!    4. if no coefficient is selected, set FIND = false.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 June 2014
!
!  Author:
!
!    Original FORTRAN90 version by Charles Lawson, Richard Hanson.
!    This FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Charles Lawson, Richard Hanson,
!    Solving Least Squares Problems,
!    SIAM, 1995,
!    ISBN: 0898713560,
!    LC: QA275.L38.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the number of rows of A.
!
!    Input, integer ( kind = 4 ) N, the number of columns of A.
!
!    Output, integer ( kind = 4 ) IZ.
!
!    Input, integer ( kind = 4 ) IZ1, IZ2.
!
!    Input, integer ( kind = 4 ) J.
!
!    Input, integer ( kind = 4 ) NPP1.
!
!    Input, integer ( kind = 4 ) NSETP.
!
!    Input, logical ( kind = 4 ) FREE.
!
!    Input, real ( kind = 8 ) UP.
!
!    Input, real ( kind = 8 ) B(M).
!
!    Input, real ( kind = 8 ) BND(2,N).
!
!    Input, integer ( kind = 4 ) INDEX(N), defines the sets P, Z, and F.
!
!    Input, real ( kind = 8 ) X(N).
!
!    Input/output, real ( kind = 8 ) A(M,N), the matrix.
!
!    Input/output, real ( kind = 8 ) W(N).
!
!    Output, logical ( kind = 4 ) FIND.
!
!    Output, real ( kind = 8 ) Z(M).
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  real ( kind = 8 ) b(m)
  real ( kind = 8 ) bnd(2,n)
  logical ( kind = 4 ) find
  logical ( kind = 4 ) free
  logical ( kind = 4 ) free1
  logical ( kind = 4 ) free2
  integer ( kind = 4 ) index(n)
  integer ( kind = 4 ) iz
  integer ( kind = 4 ) iz_index
  integer ( kind = 4 ) iz1
  integer ( kind = 4 ) iz2
  integer ( kind = 4 ) j
  integer ( kind = 4 ) npp1
  integer ( kind = 4 ) nsetp
  real ( kind = 8 ) up
  real ( kind = 8 ) w(n)
  real ( kind = 8 ) x(n)
  real ( kind = 8 ) z(m)

  find = .false.

  do iz_index = iz1, iz2

    iz = iz_index

    j = index(iz)
!
!  FREE1 = true if X(J) is not at the left end-point of its constraint region.
!  FREE2 = true if X(J) is not at the right end-point of its constraint region.
!  FREE = true if X(J) is not at either end-point of its constraint region.
!
    free1 = ( bnd(1,j) < x(j) )
    free2 = ( x(j) < bnd(2,j) )
    free = ( free1 .and. free2 )

    if ( free ) then

      call test_coef_j ( m, n, j, npp1, nsetp, free, up, b, x, a, w, &
        find, z )
!
!  Compute dual coefficient W(J).
!
    else

      w(j) = dot_product ( a(npp1:m,j), b(npp1:m) )
!
!  Can X(J) move in the direction indicated by the sign of W(J)?
!
      if ( w(j) < 0.0D+00 ) then
        if ( free1 ) then
          call test_coef_j ( m, n, j, npp1, nsetp, free, up, b, x, a, &
            w, find, z )
        end if
      else if ( 0.0D+00 < w(j) ) then
        if ( free2 ) then
          call test_coef_j ( m, n, j, npp1, nsetp, free, up, b, x, a, &
            w, find, z )
        end if
      end if

    end if

    if ( find ) then
      return
    end if

  end do

  return
end
subroutine termination ( ierr, m, n, npp1, b, w, rnorm )

!*****************************************************************************80
!
!! TERMINATION handles the termination of the BVLS algorithm.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    11 June 2014
!
!  Author:
!
!    Original FORTRAN90 version by Charles Lawson, Richard Hanson.
!    This FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Charles Lawson, Richard Hanson,
!    Solving Least Squares Problems,
!    SIAM, 1995,
!    ISBN: 0898713560,
!    LC: QA275.L38.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) IERR, error flag.
!
!    Input, integer ( kind = 4 ) M.
!
!    Input, integer ( kind = 4 ) N.
!
!    Input, integer ( kind = 4 ) NPP1.
!
!    Input, real ( kind = 8 ) B(M).
!
!    Output, real ( kind = 8 ) W(N).
!
!    Output, real ( kind = 8 ) RNORM.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) b(m)
  integer ( kind = 4 ) ierr
  integer ( kind = 4 ) npp1
  real ( kind = 8 ) nrm2
  real ( kind = 8 ) rnorm
  real ( kind = 8 ) w(n)
!
!  Compute the norm of the residual vector.
!
  rnorm = 0.0D+00

  if ( ierr <= 0 ) then

    if ( npp1 <= m ) then
      rnorm = nrm2 ( m + 1 - npp1, b(npp1:m) )
    else
      w(1:n) = 0.0D+00
    end if

  end if

  return
end
subroutine test_coef_j ( m, n, j, npp1, nsetp, free, up, b, x, a, w, &
  find, z )

!*****************************************************************************80
!
!! TEST_COEF_J
!
!  Discussion:
!
!    The sign of W(J) is OK for J to be moved to set P.
!
!    Begin the transformation and check new diagonal element to avoid
!    near linear dependence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    11 June 2014
!
!  Author:
!
!    Original FORTRAN90 version by Charles Lawson, Richard Hanson.
!    This FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Charles Lawson, Richard Hanson,
!    Solving Least Squares Problems,
!    SIAM, 1995,
!    ISBN: 0898713560,
!    LC: QA275.L38.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the number of rows of A.
!
!    Input, integer ( kind = 4 ) N, the number of columns of A.
!
!    Input, integer ( kind = 4 ) J.
!
!    Input, integer ( kind = 4 ) NPP1.
!
!    Input, integer ( kind = 4 ) NSETP.
!
!    Input, logical ( kind = 4 ) FREE.
!
!    Input, real ( kind = 8 ) UP.
!
!    Input, real ( kind = 8 ) B(M).
!
!    Input, real ( kind = 8 ) X(N).
!
!    Input/output, real ( kind = 8 ) A(M,N), the matrix.
!
!    Input/output, real ( kind = 8 ) W(N).
!
!    Output, logical ( kind = 4 ) FIND.
!
!    Output, real ( kind = 8 ) Z(M).
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  real ( kind = 8 ) asave
  real ( kind = 8 ) b(m)
  real ( kind = 8 ), parameter :: eps = 2.220446049250313D-016
  logical ( kind = 4 ) find
  logical ( kind = 4 ) free
  integer ( kind = 4 ) j
  real ( kind = 8 ) norm
  integer ( kind = 4 ) npp1
  real ( kind = 8 ) nrm2
  integer ( kind = 4 ) nsetp
  real ( kind = 8 ) sm
  real ( kind = 8 ) unorm
  real ( kind = 8 ) up
  real ( kind = 8 ) w(n)
  real ( kind = 8 ) x(n)
  real ( kind = 8 ) z(m)
  real ( kind = 8 ) ztest

  asave = a(npp1,j)

  call htc ( npp1, m, a(1:m,j), up )

  unorm = nrm2 ( nsetp, a(1:nsetp,j) )

  if ( eps * unorm < abs ( a(npp1,j) ) ) then
!
!  Column J is sufficiently independent.  Copy B into Z, update Z.
!
    z(1:m) = b(1:m)
!
!  Compute product of transformation and updated right-hand side.
!
    norm = a(npp1,j)
    a(npp1,j) = up

    if ( 0.0D+00 < abs ( norm ) ) then
      sm = dot_product ( a(npp1:m,j) / norm, z(npp1:m) ) / up
      z(npp1:m) = z(npp1:m) + sm * a(npp1:m,j)
      a(npp1,j) = norm
    end if

    if ( 0.0D+00 < abs ( x(j) ) ) then
      z(1:npp1) = z(1:npp1) + a(1:npp1,j) * x(j)
    end if
!
!  Adjust Z as though X(J) had been reset to zero.
!
    if ( free ) then

      find = .true.

    else
!
!  Solve for ZTEST, the proposed new value for X(J).
!  FIND indicates if ZTEST has moved away from X(J) in
!  the expected direction indicated by the sign of W(J).
!
      ztest = z(npp1) / a(npp1,j)
      find = ( w(j) < 0.0D+00 .and. ztest < x(j) ) .or. &
        ( 0.0D+00 < w(j) .and. x(j) < ztest )

    end if

  end if
!
!  If J was not accepted to be moved from set Z to set P,
!  restore A(NNP1,J).  Failing these tests may mean the computed
!  sign of W(J) is suspect, so here we set W(J) = 0.  This will
!  not affect subsequent computation, but cleans up the W() array.
!
  if ( .not. find ) then
    a(npp1,j) = asave
    w(j) = 0.0D+00
  end if

  return
end
subroutine test_set_p_against_constraints ( m, n, a, b, bnd, index, iter, &
  itmax, iz1, npp1, nsetp, x, z, ierr )

!*****************************************************************************80
!
!! TEST_SET_P_AGAINST_CONSTRAINTS
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    13 August 2014
!
!  Author:
!
!    Original FORTRAN90 version by Charles Lawson, Richard Hanson.
!    This FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Charles Lawson, Richard Hanson,
!    Solving Least Squares Problems,
!    SIAM, 1995,
!    ISBN: 0898713560,
!    LC: QA275.L38.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N.
!
!    Input, real ( kind = 8 ) A(M,N), the matrix.
!
!    Input, real ( kind = 8 ) B(M).
!
!    Input, real ( kind = 8 ) BND(2,N).
!
!    Input/output, integer ( kind = 4 ) INDEX(N), defines the sets P, Z, and F.
!
!    Input/output, integer ( kind = 4 ) ITER.
!
!    Input, integer ( kind = 4 ) ITMAX.
!
!    Input/output, integer ( kind = 4 ) IZ1.
!
!    Input/output, integer ( kind = 4 ) NPP1.
!
!    Input/output, integer ( kind = 4 ) NSETP.
!
!    Input/output, real ( kind = 8 ) X(N).
!
!    Input/output, real ( kind = 8 ) Z(M).
!
!    Output, integer IERR.
!
!  Local Parameters:
!
!    ALPHA
!    HITBND
!    I
!    IBOUND
!    II
!    IP
!    JJ
!    L
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  real ( kind = 8 ) alpha
  real ( kind = 8 ) b(m)
  real ( kind = 8 ) bnd(2,n)
  logical ( kind = 4 ) hitbnd
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ibound
  integer ( kind = 4 ) ierr
  integer ( kind = 4 ) ii
  integer ( kind = 4 ) index(n)
  integer ( kind = 4 ) ip
  integer ( kind = 4 ) iter
  integer ( kind = 4 ) itmax
  integer ( kind = 4 ) iz1
  integer ( kind = 4 ) jj
  integer ( kind = 4 ) jjj
  integer ( kind = 4 ) l
  integer ( kind = 4 ) npp1
  integer ( kind = 4 ) nsetp
  real ( kind = 8 ) x(n)
  real ( kind = 8 ) z(m)

  loopb: do
!
!  The solution obtained by solving the current set P is in the array Z().
!
    iter = iter + 1
    if ( itmax < iter ) then
      ierr = 4
      exit loopb
    end if
!
!  Set HITBND.
!  If HITBND is true, also set ALPHA, JJ, and IBOUND.
!
    call constrained_feasible ( nsetp, index, bnd, x, z, hitbnd, alpha, &
      jj, ibound )

    if ( .not. hitbnd ) then
      exit loopb
    end if
!
!  ALPHA will be between 0 and 1 for interpolation
!  between the old X and the new Z.
!
    do ip = 1, nsetp
      l = index(ip)
      x(l) = x(l) + alpha * ( z(ip) - x(l) )
    end do

    i = index(jj)
!
!  The exit test is done at the end of the loop, so the loop
!  will always be executed at least once.
!
    do
!
!  Modify A, B, and the index arrays to move coefficient I
!  from set P to set Z.
!
      call move_coef_i ( m, n, i, ibound, bnd, jj, b, a, x, nsetp, index, &
        npp1, iz1 )

      if ( nsetp <= 0 ) then
        exit loopb
      end if
!
!  See if the remaining coefficients in set P are feasible.  They should
!  be because of the way ALPHA was determined.  If any are infeasible
!  it is due to round-off error.  Any that are infeasible or on a boundary
!  will be set to the boundary value and moved from set P to set Z.
!
      ibound = 0
      jj = nsetp

      do jjj = 1, nsetp

        i = index(jjj)

        if ( x(i) <= bnd(1,i) ) then
          ibound = 1
          jj = jjj
          exit
        else if ( bnd(2,i) <= x(i) ) then
          ibound = 2
          jj = jjj
          exit
        end if

      end do

      if ( ibound <= 0 ) then
        exit
      end if

    end do
!
!  Copy B into Z.
!
    z(1:m) = b(1:m)
!
!  Solve and loop back again.
!
    do i = nsetp, 1, -1
      if ( i /= nsetp ) then
        z(1:i) = z(1:i) - a(1:i,ii) * z(i+1)
      end if
      ii = index(i)
      z(i) = z(i) / a(i,ii)
    end do

  end do loopb

  do ip = 1, nsetp
    i = index(ip)
    x(i) = z(ip)
  end do

  return
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2.2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end


module example1

use phaml
implicit none

private
public setup_example1

contains

subroutine setup_example1()
use pde_pointers
call set_pde_pointers(pdecoefs, bconds, iconds, trues, truexs, trueys)
end subroutine

subroutine pdecoefs(x,y,cxx,cxy,cyy,cx,cy,c,rs)
real(my_real), intent(in) :: x,y
real(my_real), intent(out) :: cxx(:,:),cxy(:,:),cyy(:,:),cx(:,:),cy(:,:), &
                              c(:,:),rs(:)
cxx(1,1) = 1.0_my_real
cyy(1,1) = 1.0_my_real
c(1,1) = 0.0_my_real
rs(1) = -90*x**8 - 90*y**8

cxy=0; cx=0; cy=0
end subroutine pdecoefs

subroutine bconds(x,y,bmark,itype,c,rs)
real(my_real), intent(in) :: x,y
integer, intent(in) :: bmark
integer, intent(out) :: itype(:)
real(my_real), intent(out) :: c(:,:),rs(:)
itype = DIRICHLET
c = 0.0_my_real
rs(1) = trues(x,y,1,1)
end subroutine bconds

function iconds(x,y,comp,eigen)
real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real(my_real) :: iconds
iconds = 0.0_my_real
end function iconds

function trues(x,y,comp,eigen) ! real (my_real)
real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: trues
trues = x**10 + y**10
end function trues

function truexs(x,y,comp,eigen) ! real (my_real)
real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: truexs
truexs = 10*x
end function truexs

function trueys(x,y,comp,eigen) ! real (my_real)
real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: trueys
trueys = 10*y
end function trueys

end module


      SUBROUTINE SB10HD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC,
     $                   D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK,
     $                   RCOND, TOL, IWORK, DWORK, LDWORK, BWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrices of the H2 optimal n-state controller
C
C              | AK | BK |
C          K = |----|----|
C              | CK | DK |
C
C     for the system
C
C                   | A  | B1  B2  |   | A | B |
C               P = |----|---------| = |---|---| ,
C                   | C1 |  0  D12 |   | C | D |
C                   | C2 | D21 D22 |
C
C     where B2 has as column size the number of control inputs (NCON)
C     and C2 has as row size the number of measurements (NMEAS) being
C     provided to the controller.
c
C     It is assumed that
C
C     (A1) (A,B2) is stabilizable and (C2,A) is detectable,
C
C     (A2) The block D11 of D is zero,
C
C     (A3) D12 is full column rank and D21 is full row rank.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the system.  N >= 0.
C
C     M       (input) INTEGER
C             The column size of the matrix B.  M >= 0.
C
C     NP      (input) INTEGER
C             The row size of the matrix C.  NP >= 0.
C
C     NCON    (input) INTEGER
C             The number of control inputs (M2).  M >= NCON >= 0,
C             NP-NMEAS >= NCON.
C
C     NMEAS   (input) INTEGER
C             The number of measurements (NP2).  NP >= NMEAS >= 0,
C             M-NCON >= NMEAS.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             system state matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             system input matrix B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading NP-by-N part of this array must contain the
C             system output matrix C.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= max(1,NP).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading NP-by-M part of this array must contain the
C             system input/output matrix D.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= max(1,NP).
C
C     AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
C             The leading N-by-N part of this array contains the
C             controller state matrix AK.
C
C     LDAK    INTEGER
C             The leading dimension of the array AK.  LDAK >= max(1,N).
C
C     BK      (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS)
C             The leading N-by-NMEAS part of this array contains the
C             controller input matrix BK.
C
C     LDBK    INTEGER
C             The leading dimension of the array BK.  LDBK >= max(1,N).
C
C     CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
C             The leading NCON-by-N part of this array contains the
C             controller output matrix CK.
C
C     LDCK    INTEGER
C             The leading dimension of the array CK.
C             LDCK >= max(1,NCON).
C
C     DK      (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS)
C             The leading NCON-by-NMEAS part of this array contains the
C             controller input/output matrix DK.
C
C     LDDK    INTEGER
C             The leading dimension of the array DK.
C             LDDK >= max(1,NCON).
C
C     RCOND   (output) DOUBLE PRECISION array, dimension (4)
C             RCOND(1) contains the reciprocal condition number of the
C                      control transformation matrix;
C             RCOND(2) contains the reciprocal condition number of the
C                      measurement transformation matrix;
C             RCOND(3) contains an estimate of the reciprocal condition
C                      number of the X-Riccati equation;
C             RCOND(4) contains an estimate of the reciprocal condition
C                      number of the Y-Riccati equation.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             Tolerance used for controlling the accuracy of the applied
C             transformations for computing the normalized form in
C             SLICOT Library routine SB10UD. Transformation matrices
C             whose reciprocal condition numbers are less than TOL are
C             not allowed. If TOL <= 0, then a default value equal to
C             sqrt(EPS) is used, where EPS is the relative machine
C             precision.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (max(2*N,N*N))
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) contains the optimal
C             LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 +
C                       max(max(M2 + NP1*NP1 +
C                               max(NP1*N,3*M2+NP1,5*M2),
C                               NP2 + M1*M1 +
C                               max(M1*N,3*NP2+M1,5*NP2),
C                               N*M2,NP2*N,NP2*M2,1),
C                               N*(14*N+12+M2+NP2)+5),
C             where M1 = M - M2 and NP1 = NP - NP2.
C             For good performance, LDWORK must generally be larger.
C             Denoting Q = max(M1,M2,NP1,NP2), an upper bound is
C             2*Q*(3*Q+2*N)+max(1,Q*(Q+max(N,5)+1),N*(14*N+12+2*Q)+5).
C
C     BWORK   LOGICAL array, dimension (2*N)
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             = 1:  if the matrix D12 had not full column rank in
C                   respect to the tolerance TOL;
C             = 2:  if the matrix D21 had not full row rank in respect
C                   to the tolerance TOL;
C             = 3:  if the singular value decomposition (SVD) algorithm
C                   did not converge (when computing the SVD of one of
C                   the matrices D12 or D21).
C             = 4:  if the X-Riccati equation was not solved
C                   successfully;
C             = 5:  if the Y-Riccati equation was not solved
C                   successfully.
C
C     METHOD
C
C     The routine implements the formulas given in [1], [2].
C
C     REFERENCES
C
C     [1] Zhou, K., Doyle, J.C., and Glover, K.
C         Robust and Optimal Control.
C         Prentice-Hall, Upper Saddle River, NJ, 1996.
C
C     [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
C         Smith, R.
C         mu-Analysis and Synthesis Toolbox.
C         The MathWorks Inc., Natick, Mass., 1995.
C
C     NUMERICAL ASPECTS
C
C     The accuracy of the result depends on the condition numbers of the
C     input and output transformations and on the condition numbers of
C     the two Riccati equations, as given by the values of RCOND(1),
C     RCOND(2), RCOND(3) and RCOND(4), respectively.
C
C     CONTRIBUTORS
C
C     P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, Oct. 1998.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, May 1999,
C     Sept. 1999, Jan. 2000, Feb. 2000.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, H2 optimal control, optimal regulator,
C     robust control.
C
C  *********************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD,
     $                   LDDK, LDWORK, M, N, NCON, NMEAS, NP
      DOUBLE PRECISION   TOL
C     ..
C     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), AK( LDAK, * ), B( LDB, * ),
     $                   BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ),
     $                   D( LDD, * ), DK( LDDK, * ), DWORK( * ),
     $                   RCOND( 4 )
C     ..
C     .. Local Scalars ..
      INTEGER            INFO2, IWC, IWD, IWF, IWH, IWRK, IWTU, IWTY,
     $                   IWY, LWAMAX, M1, M2, MINWRK, NP1, NP2
      DOUBLE PRECISION   TOLL
C     ..
C     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLACPY, SB10UD, SB10VD, SB10WD, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX, SQRT
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      M1  = M - NCON
      M2  = NCON
      NP1 = NP - NMEAS
      NP2 = NMEAS
C
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( NP.LT.0 ) THEN
         INFO = -3
      ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN
         INFO = -4
      ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN
         INFO = -11
      ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN
         INFO = -13
      ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN
         INFO = -19
      ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN
         INFO = -21
      ELSE
C
C        Compute workspace.
C
         MINWRK = N*M + NP*(N+M) + M2*M2 + NP2*NP2 +
     $            MAX( MAX( M2 + NP1*NP1 +
     $                      MAX( NP1*N, 3*M2 + NP1, 5*M2 ),
     $                      NP2 + M1*M1 +
     $                      MAX( M1*N, 3*NP2 + M1, 5*NP2 ),
     $                      N*M2, NP2*N, NP2*M2, 1 ),
     $                 N*( 14*N + 12 + M2 + NP2 ) + 5 )
         IF( LDWORK.LT.MINWRK )
     $      INFO = -26
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB10HD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0
     $    .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN
         RCOND( 1 ) = ONE
         RCOND( 2 ) = ONE
         RCOND( 3 ) = ONE
         RCOND( 4 ) = ONE
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
      TOLL = TOL
      IF( TOLL.LE.ZERO ) THEN
C
C        Set the default value of the tolerance for rank tests.
C
         TOLL = SQRT( DLAMCH( 'Epsilon' ) )
      END IF
C
C     Workspace usage.
C
      IWC  = N*M + 1
      IWD  = IWC + NP*N
      IWTU = IWD + NP*M
      IWTY = IWTU + M2*M2
      IWRK = IWTY + NP2*NP2
C
      CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N )
      CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP )
      CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP )
C
C     Transform the system so that D12 and D21 satisfy the formulas
C     in the computation of the H2 optimal controller.
C
      CALL SB10UD( N, M, NP, NCON, NMEAS, DWORK, N, DWORK( IWC ), NP,
     $             DWORK( IWD ), NP, DWORK( IWTU ), M2, DWORK( IWTY ),
     $             NP2, RCOND, TOLL, DWORK( IWRK ), LDWORK-IWRK+1,
     $             INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = INFO2
         RETURN
      END IF
      LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1
C
      IWY  = IWRK
      IWF  = IWY + N*N
      IWH  = IWF + M2*N
      IWRK = IWH + N*NP2
C
C     Compute the optimal state feedback and output injection matrices.
C     AK is used to store X.
C
      CALL SB10VD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N,
     $             DWORK( IWC ), NP, DWORK( IWF ), M2, DWORK( IWH ), N,
     $             AK, LDAK, DWORK( IWY ), N, RCOND( 3 ), IWORK,
     $             DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = INFO2 + 3
         RETURN
      END IF
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
C     Compute the H2 optimal controller.
C
      CALL SB10WD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N,
     $             DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), M2,
     $             DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ),
     $             NP2, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, INFO2 )
C
      DWORK( 1 ) = DBLE( LWAMAX )
      RETURN
C *** Last line of SB10HD ***
      END


      SUBROUTINE QROMB(FUNC,A,B,SS)
      PARAMETER(EPS=1.E-6,JMAX=20,JMAXP=JMAX+1,K=5,KM=4)
      DIMENSION S(JMAXP),H(JMAXP)
      H(1)=1.
      DO 11 J=1,JMAX
        CALL TRAPZD(FUNC,A,B,S(J),J)
        IF (J.GE.K) THEN
          L=J-KM
          CALL POLINT(H(L),S(L),K,0.,SS,DSS)
          IF (ABS(DSS).LT.EPS*ABS(SS)) RETURN
        ENDIF
        S(J+1)=S(J)
        H(J+1)=0.25*H(J)
11    CONTINUE
      PAUSE 'Too many steps.'
      END


       function ddot_22(T1, T2)
        implicit none

        type(Tensor2), intent(in) :: T1
        type(Tensor2), intent(in) :: T2
        real(kind=8) :: ddot_22
        integer :: i,j

        ddot_22 = 0.d0
        do i = 1,3
         do j = 1,3
          ddot_22 = ddot_22 + T1%ab(i,j)*T2%ab(i,j)
         enddo
        enddo

       end function ddot_22

       function ddot_2s2s(T1, T2)
        implicit none

        type(Tensor2s), intent(in) :: T1
        type(Tensor2s), intent(in) :: T2
        real(kind=8) :: ddot_2s2s
        integer :: i

        ddot_2s2s = 0.d0
        do i=1,3
         ddot_2s2s = ddot_2s2s + T1%a6(i)*T2%a6(i)
        enddo
        do i=4,6
         ddot_2s2s = ddot_2s2s + T1%a6(i)*T2%a6(i)*2.d0
        enddo

       end function ddot_2s2s

       function ddot_24(T1, T2)
        implicit none

        type(Tensor2), intent(in) :: T1
        type(Tensor4), intent(in) :: T2
        type(Tensor2) :: ddot_24
        integer :: i,j,k,l

        ddot_24%ab = 0.d0
        do i = 1,3
         do j = 1,3
          do k = 1,3
           do l = 1,3
            ddot_24%ab(k,l) = ddot_24%ab(k,l)
     *          + T1%ab(i,j)*T2%abcd(i,j,k,l)
           enddo
          enddo
         enddo
        enddo

       end function ddot_24

       function ddot_2s4s(T1, T2)
        implicit none

        type(Tensor2s), intent(in) :: T1
        type(Tensor4s), intent(in) :: T2
        type(Tensor2s) :: ddot_2s4s
        real(kind=8) :: w
        integer :: i,j

        ddot_2s4s%a6 = 0.d0
        do i = 1,6
         do j = 1,6
          if (i > 3) then
           w = 2.d0
          else
           w = 1.d0
          endif
          ddot_2s4s%a6(j) = ddot_2s4s%a6(j)
     *              + T1%a6(i)*T2%a6b6(i,j)*w
         enddo
        enddo

       end function ddot_2s4s

       function ddot_42(T1, T2)
        implicit none

        type(Tensor4), intent(in) :: T1
        type(Tensor2), intent(in) :: T2
        type(Tensor2) :: ddot_42
        integer :: i,j,k,l

        ddot_42%ab = 0.d0
        do i = 1,3
         do j = 1,3
          do k = 1,3
           do l = 1,3
            ddot_42%ab(i,j) = ddot_42%ab(i,j)
     *          + T1%abcd(i,j,k,l)*T2%ab(k,l)
           enddo
          enddo
         enddo
        enddo

       end function ddot_42

       function ddot_4s2s(T1, T2)
        implicit none

        type(Tensor4s), intent(in) :: T1
        type(Tensor2s), intent(in) :: T2
        type(Tensor2s) :: ddot_4s2s
        real(kind=8) :: w
        integer :: i,j

        ddot_4s2s%a6 = 0.d0
        do i = 1,6
         do j = 1,6
          if (j > 3) then
           w = 2.d0
          else
           w = 1.d0
          endif
          ddot_4s2s%a6(i) = ddot_4s2s%a6(i)
     *          + T1%a6b6(i,j)*T2%a6(j)*w
         enddo
        enddo

       end function ddot_4s2s

       function ddot_44(T1, T2)
        implicit none

        type(Tensor4), intent(in) :: T1
        type(Tensor4), intent(in) :: T2
        type(Tensor4) :: ddot_44
        integer :: i,j,k,l,m,n

        ddot_44%abcd = 0.d0
        do i = 1,3
         do j = 1,3
          do m = 1,3
           do n = 1,3
            do k = 1,3
             do l = 1,3
              ddot_44%abcd(i,j,k,l) = ddot_44%abcd(i,j,k,l)
     *           + T1%abcd(i,j,m,n)*T2%abcd(m,n,k,l)
             enddo
            enddo
           enddo
          enddo
         enddo
        enddo
       end function ddot_44

       function ddot_4s4s(T1, T2)
        implicit none

        type(Tensor4s), intent(in) :: T1
        type(Tensor4s), intent(in) :: T2
        type(Tensor4s) :: ddot_4s4s
        real(kind=8) :: w
        integer :: i,j,k,l

        ddot_4s4s%a6b6 = 0.d0
        do i = 1,6
         do k = 1,6
          do j = 1,6
           if (k > 3) then
            w = 2.d0
           else
            w = 1.d0
           endif
           ddot_4s4s%a6b6(i,j) = ddot_4s4s%a6b6(i,j)
     *           + T1%a6b6(i,k)*T2%a6b6(k,j)*w
          enddo
         enddo
        enddo

       end function ddot_4s4s


!-----------------------------------------------------------------------
!     Function:      dflux_simpson
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          03/02/2012
!     Description:   This subroutine calculates the flux due to a line
!                    segment using simpson formula.
!-----------------------------------------------------------------------
      REAL FUNCTION dflux_simpson(x0,y0,z0,x1,y1,z1,cg)
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
      USE virtual_casing_mod
      USE biotsavart
      USE bsc_T
!-----------------------------------------------------------------------
!     Local Variables
!          ier            Error Flag
!          iunit          File ID Number
!-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER, intent(in) :: cg
      REAL(rprec)   , intent(in) :: x0,y0,z0,x1,y1,z1
      REAL(rprec) :: delf,delt,dx,dy,dz,xp,yp,zp,ax,ay,az
      REAL(rprec) :: xvec(3),avec(3)
      INTEGER     :: i,ier
      integer, parameter :: nop=3
      real(rprec), dimension(nop), parameter :: ci=(/1./6.,2./3.,1./6./)
!-----------------------------------------------------------------------
!     Begin Function
!-----------------------------------------------------------------------

      delf = 0
      delt = REAL(1)/REAL(nop-1)
      dx = x1-x0
      dy = y1-y0
      dz = z1-z0
      IF (cg > 0) THEN
         DO i = 1, nop
            xvec(1) = x0+(i-1)*dx*delt
            xvec(2) = y0+(i-1)*dy*delt
            xvec(3) = z0+(i-1)*dz*delt
            CALL bsc_a(coil_group(cg),xvec,avec)
            delf = delf+ ci(i)*(avec(1)*dx+avec(2)*dy+avec(3)*dz)
         END DO
      ELSE
         DO i = 1, nop
            ier = 1; ax = 0; ay = 0; az = 0
            xp = x0+(i-1)*dx*delt
            yp = y0+(i-1)*dy*delt
            zp = z0+(i-1)*dz*delt
            CALL vecpot_vc(xp,yp,zp,ax,ay,az,ier)
            delf = delf+ ci(i)*(ax*dx+ay*dy+az*dz)
         END DO
      END IF
      dflux_simpson = delf
      RETURN
!-----------------------------------------------------------------------
!     End Function
!-----------------------------------------------------------------------
      END FUNCTION dflux_simpson


module pde

! This module contains all information that appears inside the PDEs.
! It specifies how many equations shall be solved, the numerical data,
! the routines to compute the fluxes from the solution, routines for
! computing primitive variables from the conserved solution U, etc.
!
! ----- EULER EQUATIONS -------

  use global_module

  implicit none

  real(kind=8), parameter :: gam = 1.66667d0 ! Adiabatic constant (ratio of specific heats)

  integer, parameter :: Neq = 4 ! Number of equations

  ! Initial conditions in the domain
  real(kind=8), parameter :: rho0 = 1.0d0     !
  real(kind=8), parameter :: ux0  = 0.0d0     !
  real(kind=8), parameter :: uy0  = 0.0d0     !
  real(kind=8), parameter :: P0   = 1.0d0     !

  ! Name of primitive variables, used ONLY for exporting the solution to VTK file
  ! NOTE: To initialize it here, all entries need to have the same length!!!
  !       I'm using three letters for simplicity.
  character(len=20), dimension(Neq) :: prim_names = (/'rho','UUx','UUy','PPP'/)

  contains

  ! ============================================================

  subroutine initialize_solution(U)

    implicit none

    real(kind=8), dimension(:,:,:), intent(inout) :: U

    integer      :: i, j

    real(kind=8) :: rhoJET, uJET, PJET, TJET

    ! Initialize all cells (i = "1,2" and "Nx-1, Nx" are ghost cells. Same thing for j)
    U(1, :, :) = rho0     ! Density
    U(2, :, :) = rho0*ux0 ! Momentum along x
    U(3, :, :) = rho0*uy0 ! Momentum along y
    U(4, :, :) = rho0*(ux0*ux0 + uy0*uy0)/2.0d0 + P0/(gam-1.0d0) ! total energy

    ! Introduce a jet at the bottom-left of the domain
    uJET   = 0.25d0
    rhoJET = 0.5d0
    PJET   = P0

    U(1, 1:floor(Nx/10.0), 1:floor(Ny/5.0)) = rhoJET      ! Density
    U(2, 1:floor(Nx/10.0), 1:floor(Ny/5.0)) = rhoJET*uJET ! Momentum along x
    U(3, 1:floor(Nx/10.0), 1:floor(Ny/5.0)) = 0.0d0       ! Momentum along y
    U(4, 1:floor(Nx/10.0), 1:floor(Ny/5.0)) = rhoJET*(uJET**2)/2.0 + PJET/(gam-1.0) ! total energy

  end subroutine

  ! ============================================================

  subroutine assign_BCs(U)

  ! This subroutine assigns boundary values to the ghost cells.
  ! In this form, we impose two jets, one at the left boundary and one at the bottom boundary.

    implicit none

    real(kind=8), dimension(:,:,:), intent(inout) :: U

    integer :: i, j

    ! Variables for imposing incoming jets as BCs
    integer      :: j_jet_start, j_jet_end, i_jet_start, i_jet_end
    real(kind=8) :: uJET, uOUTLET
    real(kind=8) :: x_jet_start, x_jet_end
    real(kind=8) :: y_jet_start, y_jet_end

!!    ! Bottom BC
!!    U(1,:,1) =  U(1,:,3)
!!    U(2,:,1) =  U(2,:,3)
!!    U(3,:,1) = -U(3,:,3) ! Opposite uy velocity
!!    U(4,:,1) =  U(4,:,3) ! Same energy
!!
!!    U(1,:,2) =  U(1,:,3)
!!    U(2,:,2) =  U(2,:,3)
!!    U(3,:,2) = -U(3,:,3) ! Opposite uy velocity
!!    U(4,:,2) =  U(4,:,3) ! Same energy

!!!     n0   = rho0/M   ! [particles/m^3] number density
!!!     P0   = n0*kB*T0 ! [Pa] gas pressure
!!!
!!!     ! Put jets at half of the domain +/- 1/6 of the domain
!!!     x_jet_start = x_min + (x_max - x_min)/2.0 - (x_max - x_min)/6.0
!!!     x_jet_end   = x_min + (x_max - x_min)/2.0 + (x_max - x_min)/6.0
!!!
!!!     y_jet_start = y_min + (y_max - y_min)/2.0 - (y_max - y_min)/6.0
!!!     y_jet_end   = y_min + (y_max - y_min)/2.0 + (y_max - y_min)/6.0
!!!
!!!     i_jet_start = ceiling((x_jet_start - x_min)/(x_max - x_min)*Nx)
!!!     i_jet_end   = ceiling((x_jet_end   - x_min)/(x_max - x_min)*Nx)
!!!
!!!     j_jet_start = ceiling((y_jet_start - y_min)/(y_max - y_min)*Ny)
!!!     j_jet_end   = ceiling((y_jet_end   - y_min)/(y_max - y_min)*Ny)
!!!
!!!     uJET    = 600.0d0; ! [m/s]
!!!     uOUTLET = 1000.0d0 ! [m/s] Let stuff outflow easily (for supersonic flows)
!!!
!!!     ! ----- LEFT BC (x_min, whatever y) --------
!!!
!!!     U(1, 1:2, :) = rho0     ! Density
!!!     U(2, 1:2, :) = rho0*ux0 ! Momentum along x
!!!     U(3, 1:2, :) = rho0*uy0 ! Momentum along y
!!!     U(4, 1:2, :) = rho0*(ux0**2 + uy0**2)/2.0 + P0/(gam-1.0) ! total energy
!!!
!!!     U(1, 1:2, j_jet_start:j_jet_end) = rho0     ! Density
!!!     U(2, 1:2, j_jet_start:j_jet_end) = rho0*uJET ! Momentum along x
!!!     U(3, 1:2, j_jet_start:j_jet_end) = rho0*0.0 ! Momentum along y
!!!     U(4, 1:2, j_jet_start:j_jet_end) = rho0*(uJET**2 + 0.0**2)/2.0 + P0/(gam-1.0) ! total energy
!!!
!!!     ! ----- RIGHT BC (x_max, whatever y) --------
!!!
!!!     U(1, Nx-1:Nx, :) = rho0     ! Density
!!!     U(2, Nx-1:Nx, :) = rho0*uOUTLET ! Momentum along x
!!!     U(3, Nx-1:Nx, :) = rho0*0.0 ! Momentum along y
!!!     U(4, Nx-1:Nx, :) = rho0*(uOUTLET**2 + 0.0**2)/2.0 + P0/(gam-1.0) ! total energy
!!!
!!!     ! ----- BOTTOM BC (y_min, whatever x) --------
!!!
!!!     U(1, :, 1:2) = rho0      ! Density
!!!     U(2, :, 1:2) = rho0*ux0  ! Momentum along x
!!!     U(3, :, 1:2) = rho0*uy0 ! Momentum along y
!!!     U(4, :, 1:2) = rho0*(ux0**2 + uy0**2)/2.0 + P0/(gam-1.0) ! total energy
!!!
!!!     U(1, i_jet_start:i_jet_end, 1:2) = rho0      ! Density
!!!     U(2, i_jet_start:i_jet_end, 1:2) = rho0*0.0  ! Momentum along x
!!!     U(3, i_jet_start:i_jet_end, 1:2) = rho0*uJET ! Momentum along y
!!!     U(4, i_jet_start:i_jet_end, 1:2) = rho0*(0.0**2 + uJET**2)/2.0 + P0/(gam-1.0) ! total energy
!!!
!!!     ! ----- TOP BC (y_max, whatever x) --------
!!!
!!!     U(1, :, Ny-1:Ny) = rho0         ! Density
!!!     U(2, :, Ny-1:Ny) = rho0*0.0     ! Momentum along x
!!!     U(3, :, Ny-1:Ny) = rho0*uOUTLET ! Momentum along y
!!!     U(4, :, Ny-1:Ny) = rho0*(0.0**2 + uOUTLET**2)/2.0 + P0/(gam-1.0) ! total energy

  end subroutine

  ! ============================================================

  subroutine compute_conserved_from_primitive(prim, U)

    ! Computes vector of conserved variables "U" from the primitive variables "P"

    implicit none

    real(kind=8), dimension(Neq), intent(in)  :: prim
    real(kind=8), dimension(Neq), intent(out) :: U

    ! Working variables
    real(kind=8) :: rho, ux, uy, P

    ! Extract primitive variables
    rho = prim(1)
    ux  = prim(2)
    uy  = prim(3)
    P   = prim(4)

    ! Compose array of conserved variables
    U(1) = rho
    U(2) = rho*ux
    U(3) = rho*uy
    U(4) = rho*(ux*ux + uy*uy)/2.0d0 + P/(gam-1.0d0)

  end subroutine

  ! ============================================================

  subroutine compute_primitive_from_conserved(U, prim)

    ! Computes vector of primitive variables "prim" from the conserved variables "U"

    implicit none

    real(kind=8), dimension(Neq), intent(in)  :: U
    real(kind=8), dimension(Neq), intent(out) :: prim

    ! Working variables
    real(kind=8) :: rho, ux, uy, P

    ! Extract primitive variables
    rho = U(1)
    ux  = U(2)/(rho + 1.0d-25) ! Use a small tolerance, since rho may be zero
    uy  = U(3)/(rho + 1.0d-25) ! Use a small tolerance, since rho may be zero
    P   = (gam - 1.0d0)*( U(4) - rho*(ux*ux + uy*uy)/2.0d0 )

    ! Compose array of primitive variables
    prim(1) = rho
    prim(2) = ux
    prim(3) = uy
    prim(4) = P

  end subroutine

  ! ============================================================

  subroutine compute_flux_ws_x(U, Fx, ws_max, ws_min)

    ! Computes the convective flux along x,
    ! and also the maximum and minimum wave speeds (required by some numerical flux schemes)

    implicit none

    real(kind=8), dimension(Neq), intent(in)  :: U
    real(kind=8), dimension(Neq), intent(out) :: Fx
    real(kind=8), intent(out) :: ws_max, ws_min

    real(kind=8), dimension(Neq) :: prim
    real(kind=8) :: rho, ux, uy, P, rhoE

    ! Compute primitive variables
    call compute_primitive_from_conserved(U, prim)
    rho = prim(1)
    ux  = prim(2)
    uy  = prim(3)
    P   = prim(4)

    rhoE = rho*(ux*ux + uy*uy)/2.0d0 + P/(gam-1.0d0)

    ! Assemble fluxes Fx
    Fx(1) = rho*ux
    Fx(2) = rho*ux*ux + P
    Fx(3) = rho*ux*uy
    Fx(4) = rhoE*ux + P*ux

    ! Maximum and minimum wave speeds (eigenvalues of the Euler system)
    ws_max = ux + sqrt(gam*P/rho)
    ws_min = ux - sqrt(gam*P/rho)

  end subroutine

  ! ============================================================

  subroutine compute_flux_ws_y(U, Fy, ws_max, ws_min)

    ! Computes the convective flux along y,
    ! and also the maximum and minimum wave speeds (required by some numerical flux schemes)

    implicit none

    real(kind=8), dimension(Neq), intent(in)  :: U
    real(kind=8), dimension(Neq), intent(out) :: Fy
    real(kind=8), intent(out) :: ws_max, ws_min

    real(kind=8), dimension(Neq) :: prim
    real(kind=8) :: rho, ux, uy, P, rhoE

    ! Compute primitive variables
    call compute_primitive_from_conserved(U, prim)
    rho = prim(1)
    ux  = prim(2)
    uy  = prim(3)
    P   = prim(4)

    rhoE = rho*(ux*ux + uy*uy)/2.0d0 + P/(gam-1.0d0)

    ! Assemble fluxes Fy
    Fy(1) = rho*uy
    Fy(2) = rho*ux*uy
    Fy(3) = rho*uy*uy + P
    Fy(4) = rhoE*uy + P*uy

    ! Maximum and minimum wave speeds (eigenvalues of the Euler system)
    ws_max = uy + sqrt(gam*P/rho)
    ws_min = uy - sqrt(gam*P/rho)

  end subroutine

  ! ==============================================================

  subroutine compute_flux_y_sym(U, Fy)

    ! Computes the convective flux along y at the symmetry boundary

    implicit none

    real(kind=8), dimension(Neq), intent(in)  :: U
    real(kind=8), dimension(Neq), intent(out) :: Fy

    real(kind=8), dimension(Neq) :: prim
    real(kind=8) :: rho, ux, uy, P, rhoE

    ! Compute primitive variables
    call compute_primitive_from_conserved(U, prim)
    rho = prim(1)
    ux  = prim(2)
    uy  = prim(3)
    P   = prim(4)

    ! Impose that uy = 0.0
    uy = 0.0d0

    ! ! Compose fluxes
    ! rhoE = rho*(ux*ux + uy*uy)/2.0d0 + P/(gam-1.0d0)
    !
    ! ! Assemble fluxes Fy
    ! Fy(1) = rho*uy
    ! Fy(2) = rho*ux*uy
    ! Fy(3) = rho*uy*uy + P
    ! Fy(4) = rhoE*uy + P*uy

    Fy(1) = 0.0d0
    Fy(2) = 0.0d0
    Fy(3) = - P
    Fy(4) = 0.0d0

  end subroutine

  ! ==============================================================

  subroutine compute_source_term(U, i, j, Src)

    ! The source term for the axisymmetric equation is equal to

    implicit none

    real(kind=8), dimension(Neq,Nx,Ny), intent(in)  :: U
    integer,                            intent(in)  :: i, j
    real(kind=8), dimension(Neq),       intent(out) :: Src

    real(kind=8), dimension(Neq) :: prim
    real(kind=8) :: rho, ux, uy, P, rhoE
    real(kind=8) :: y_j

    ! Compute primitive variables
    call compute_primitive_from_conserved(U(:,i,j), prim)
    rho = prim(1)
    ux  = prim(2)
    uy  = prim(3)
    P   = prim(4)

    ! Compose fluxes
    rhoE = rho*(ux*ux + uy*uy)/2.0 + P/(gam-1)

    ! Assemble source term Src = Fy/y
    ! Src(1) = rho*uy
    ! Src(2) = rho*ux*uy
    ! Src(3) = rho*uy*uy + P
    ! Src(4) = rhoE*uy + P*uy

    y_j = y_min + dy/2.0d0 + real(j-3)*dy
    ! Src = Src/y_j

    Src = 0.0d0
    Src(3) = P/y_j

  end subroutine

end module