c
c   Example 6
c
c   Interface:    Semi-Structured interface (SStruct).  Fortran - Babel version.
c
c   Compile with: make ex6
c
c   Sample run:   mpirun -np 2 ex6
c
c   Description:  This is a two processor example and is the same problem
c                 as is solved with the structured interface in Example 2.
c                 (The grid boxes are exactly those in the example
c                 diagram in the struct interface chapter of the User's Manual.
c                 Processor 0 owns two boxes and processor 1 owns one box.)
c
c                 This is the simplest sstruct example, and it demonstrates how
c                 the semi-structured interface can be used for structured problems.
c                 There is one part and one variable.  The solver is PCG with SMG
c                 preconditioner. We use a structured solver for this example.

      program ex6b77

      implicit none

      include 'mpif.h'

      include "HYPREf.h"
c     ...If HYPREf.h doesn't exist in your version of HYPRE, just use
c     these two lines from it:
c      integer HYPRE_STRUCT
c      parameter( HYPRE_STRUCT =  1111 )

      include 'bHYPRE_SStructVariable.inc'
c     ... This file is generated into babel/bHYPREClient-F.  A future version
c     of the makefiles will copy it to hypre/include.

      integer    MAX_LOCAL_SIZE
      parameter  (MAX_LOCAL_SIZE=123000)
      integer    MAXBLKS
      parameter  (MAXBLKS=32)
      integer    MAX_STENCIL_SIZE
      parameter  (MAX_STENCIL_SIZE=27)
      integer    MAXDIM
      parameter  (MAXDIM=3)

      integer myid, num_procs

      integer*8 grid
      integer*8 graph
      integer*8 stencil
      integer*8 A
      integer*8 b
      integer*8 x
      integer*8  bHYPRE_mpicomm
      integer*8 except
      integer*8 mpi_comm
      integer*8 sA
      integer*8 vb
      integer*8 vx
      integer*8 dummy
      integer*8 opA

c     We are using struct solvers for this example
      integer*8 PCGsolver
      integer*8 SMGprecond
      integer*8 precond

      integer object_type, ndim, ierr, ierrtmp
      integer ilower(MAXDIM)
      integer iupper(MAXDIM)
      integer i, j, nparts, part, nvars, var
      integer vartypes(1)
      integer entry, nentries, nvalues, maxnvalues
      double precision tol
      double precision values(MAX_STENCIL_SIZE*MAX_LOCAL_SIZE)
      integer stencil_indices(MAX_STENCIL_SIZE)
      integer offsets(2,5)

      ndim = 2
      ierr = 0
      ierrtmp = 0

c     Initialize MPI
      call MPI_INIT(ierr)
      call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
      call MPI_COMM_SIZE(MPI_COMM_WORLD, num_procs, ierr)
      mpi_comm = MPI_COMM_WORLD
      call bHYPRE_MPICommunicator_CreateF_f( mpi_comm, bHYPRE_mpicomm,
     1      except )

      if ( num_procs .ne. 2 ) then
         print *, 'Must run with 2 processors!'
         call MPI_Finalize(ierrtmp)
         stop
      endif

c    1. Set up the 2D grid.  This gives the index space in each part.
c       Here we only use one part and one variable. (So the part id is 0
c       and the variable id is 0)

      nparts = 1
      part = 0

c     Create an empty 2D grid object
      call bHYPRE_SStructGrid_Create_f( bHYPRE_mpicomm, ndim, nparts,
     1     grid, except );

c     Set the extents of the grid - each processor sets its grid
c       boxes.  Each part has its own relative index space numbering,
c       but in this example all boxes belong to the same part.

c     Processor 0 owns two boxes in the grid.
      if ( myid .eq. 0 ) then
c        Add a new box to the grid
         ilower(1) = -3
         ilower(2) = 1
         iupper(1) = -1
         iupper(2) = 2
         call bHYPRE_SStructGrid_SetExtents_f( grid, part,
     1        ilower, iupper, ndim, ierr, except )

c        Add a new box to the grid */
         ilower(1) = 0
         ilower(2) = 1
         iupper(1) = 2
         iupper(2) = 4
         call bHYPRE_SStructGrid_SetExtents_f( grid, part,
     1        ilower, iupper, ndim, ierr, except )

c     Processor 1 owns one box in the grid.
      elseif ( myid .eq. 1 ) then
c        Add a new box to the grid */
         ilower(1) = 3
         ilower(2) = 1
         iupper(1) = 6
         iupper(2) = 4
         call bHYPRE_SStructGrid_SetExtents_f( grid, part,
     1        ilower, iupper, ndim, ierr, except )
      endif

c     Set the variable type and number of variables on each part.
      nvars = 1
      var = 0
      vartypes(1) = CELL

      do i = 0, nparts-1
         call bHYPRE_SStructGrid_SetVariable_f( grid, i, var, nvars,
     1        vartypes(1), ierr, except )
      enddo
c     ... if nvars>1 we would need a number of AddVariable calls

c     Now the grid is ready to use
      call bHYPRE_SStructGrid_Assemble_f( grid, ierr, except )

c   2. Define the discretization stencil(s)
c      Create an empty 2D, 5-pt stencil object */
      call bHYPRE_SStructStencil_Create_f( 2, 5, stencil, except )

c     Define the geometry of the stencil. Each represents a
c     relative offset (in the index space).
      offsets(1,1) = 0
      offsets(2,1) = 0
      offsets(1,2) = -1
      offsets(2,2) = 0
      offsets(1,3) = 1
      offsets(2,3) = 0
      offsets(1,4) = 0
      offsets(2,4) = -1
      offsets(1,5) = 0
      offsets(2,5) = 1
      var = 0

c     Assign numerical values to the offsets so that we can
c     easily refer to them  - the last argument indicates the
c     variable for which we are assigning this stencil - we are
c     just using one variable in this example so it is the first one (0)
      do entry = 1, 5
         call bHYPRE_SStructStencil_SetEntry_f( stencil, entry-1,
     1        offsets(1,entry), ndim, var, ierr, except )
      enddo

c     3. Set up the Graph  - this determines the non-zero structure
c     of the matrix and allows non-stencil relationships between the parts
      var = 0
      part = 0

c     Create the graph object
      call bHYPRE_SStructGraph_Create_f( bHYPRE_mpicomm, grid, graph,
     1     except )

c     Now we need to tell the graph which stencil to use for each
c     variable on each part (we only have one variable and one part)
      call bHYPRE_SStructGraph_SetStencil_f( graph, part, var, stencil,
     1     ierr, except )

c     Here we could establish connections between parts if we
c     had more than one part using the graph. For example, we could
c     use HYPRE_GraphAddEntries() routine or HYPRE_GridSetNeighborBox()

c     Assemble the graph
      call bHYPRE_SStructGraph_Assemble_f( graph, ierr, except )

c     4. Set up a SStruct Matrix
      part = 0
      var = 0

c     Create the empty matrix object
      call bHYPRE_SStructMatrix_Create_f( bHYPRE_mpicomm, graph, A,
     1     except )

c     Set the object type (by default HYPRE_SSTRUCT). This determines the
c     data structure used to store the matrix.  If you want to use unstructured
c     solvers, e.g. BoomerAMG, the object type should be HYPRE_PARCSR.
c     If the problem is purely structured (with one part), you may want to use
c     HYPRE_STRUCT to access the structured solvers. Here we have a purely
c     structured example.
      object_type = HYPRE_STRUCT
      call bHYPRE_SStructMatrix_SetObjectType_f( A, object_type,
     1     ierr, except )

c     Get ready to set values
      call bHYPRE_SStructMatrix_Initialize_f( A, ierr, except )

c     Each processor must set the stencil values for their boxes on each part.
c     In this example, we only set stencil entries and therefore use
c     HYPRE_SStructMatrixSetBoxValues.  If we need to set non-stencil entries,
c     we have to use HYPRE_SStructMatrixSetValues (shown in a later example).

      if ( myid .eq. 0 ) then
c     Set the matrix coefficients for some set of stencil entries
c     over all the gridpoints in my first box (account for boundary
c     grid points later)
         ilower(1) = -3
         ilower(2) = 1
         iupper(1) = -1
         iupper(2) = 2
         nentries = 5
         nvalues  = 30
c        ... nvalues=30 from 6 grid points, each with 5 stencil entries

         do j = 1, nentries
c           label the stencil indices - these correspond to the offsets
c           defined above ...
            stencil_indices(j) = j-1
         enddo

         do i = 1, nvalues, nentries
            values(i) = 4.0
            do j = 1, nentries-1
               values(i+j) = -1.0
               enddo
            enddo

            call bHYPRE_SStructMatrix_SetBoxValues_f( A, part,
     1           ilower, iupper, ndim, var, nentries, stencil_indices,
     2           values, nvalues, ierr, except )

c     Set the matrix coefficients for some set of stencil entries
c     over the gridpoints in my second box
            ilower(1) = 0
            ilower(2) = 1
            iupper(1) = 2
            iupper(2) = 4
            nentries = 5
            nvalues  = 60
c           ... nvalues=60 from 12 grid points, each with 5 stencil entries

            do j = 1, nentries
               stencil_indices(j) = j-1
            enddo

            do i = 1, nvalues, nentries
               values(i) = 4.0
               do j = 1, nentries-1
                  values(i+j) = -1.0;
               enddo
            enddo

            call bHYPRE_SStructMatrix_SetBoxValues_f( A, part,
     1           ilower, iupper, ndim, var, nentries, stencil_indices,
     2           values, nvalues, ierr, except )

      elseif ( myid .eq. 1 ) then
c     Set the matrix coefficients for some set of stencil entries
c     over the gridpoints in my box
         ilower(1) = 3
         ilower(2) = 1
         iupper(1) = 6
         iupper(2) = 4
         nentries = 5
         nvalues  = 80
c        ... nentries=80 from 16 grid points, each with 5 stencil entries

         do j = 1, nentries
            stencil_indices(j) = j-1
         enddo

         do i = 1, nvalues, nentries
            values(i) = 4.0
            do j = 1, nentries-1
               values(i+j) = -1.0
            enddo
         enddo

         call bHYPRE_SStructMatrix_SetBoxValues_f( A, part,
     1        ilower, iupper, ndim, var, nentries, stencil_indices,
     2        values, nvalues, ierr, except )

      endif

c     For each box, set any coefficients that reach ouside of the
c     boundary to 0
      if ( myid .eq. 0 )then
         maxnvalues = 6;

         do i = 1, maxnvalues
            values(i) = 0.0
         enddo

c     Values below our first AND second box
         ilower(1) = -3
         ilower(2) = 1
         iupper(1) = 2
         iupper(2) = 1
         nvalues = 6
         stencil_indices(1) = 3

         call bHYPRE_SStructMatrix_SetBoxValues_f( A, part,
     1        ilower, iupper, ndim, var, 1, stencil_indices,
     2        values, nvalues, ierr, except )

c     Values to the left of our first box
         ilower(1) = -3
         ilower(2) = 1
         iupper(1) = -3
         iupper(2) = 2
         nvalues = 2
         stencil_indices(1) = 1

         call bHYPRE_SStructMatrix_SetBoxValues_f( A, part,
     1        ilower, iupper, ndim, var, 1, stencil_indices,
     2        values, nvalues, ierr, except )

c     Values above our first box
         ilower(1) = -3
         ilower(2) = 2
         iupper(1) = -1
         iupper(2) = 2
         nvalues = 3
         stencil_indices(1) = 4

         call bHYPRE_SStructMatrix_SetBoxValues_f( A, part,
     1        ilower, iupper, ndim, var, 1, stencil_indices,
     2        values, nvalues, ierr, except )

c     Values to the left of our second box (that do not border the
c     first box).
         ilower(1) = 0
         ilower(2) = 3
         iupper(1) = 0
         iupper(2) = 4
         nvalues = 2
         stencil_indices(1) = 1

         call bHYPRE_SStructMatrix_SetBoxValues_f( A, part,
     1        ilower, iupper, ndim, var, 1, stencil_indices,
     2        values, nvalues, ierr, except )

c     Values above our second box
         ilower(1) = 0
         ilower(2) = 4
         iupper(1) = 2
         iupper(2) = 4
         nvalues = 3
         stencil_indices(1) = 4

         call bHYPRE_SStructMatrix_SetBoxValues_f( A, part,
     1        ilower, iupper, ndim, var, 1, stencil_indices,
     2        values, nvalues, ierr, except )

      elseif ( myid .eq. 1 ) then
         maxnvalues = 4;

         do i = 1, maxnvalues
            values(i) = 0.0
         enddo

c     Values below our box
         ilower(1) = 3
         ilower(2) = 1
         iupper(1) = 6
         iupper(2) = 1
         nvalues = 4
         stencil_indices(1) = 3

         call bHYPRE_SStructMatrix_SetBoxValues_f( A, part,
     1        ilower, iupper, ndim, var, 1, stencil_indices,
     2        values, nvalues, ierr, except )

c     Values to the right of our box
         ilower(1) = 6
         ilower(2) = 1
         iupper(1) = 6
         iupper(2) = 4
         nvalues = 4
         stencil_indices(1) = 2

         call bHYPRE_SStructMatrix_SetBoxValues_f( A, part,
     1        ilower, iupper, ndim, var, 1, stencil_indices,
     2        values, nvalues, ierr, except )

c     Values above our box
         ilower(1) = 3
         ilower(2) = 4
         iupper(1) = 6
         iupper(2) = 4
         nvalues = 4
         stencil_indices(1) = 4

         call bHYPRE_SStructMatrix_SetBoxValues_f( A, part,
     1        ilower, iupper, ndim, var, 1, stencil_indices,
     2        values, nvalues, ierr, except )

         endif

c     This is a collective call finalizing the matrix assembly.
c     The matrix is now ``ready to be used''
         call bHYPRE_SStructMatrix_Assemble_f( A, ierr, except )

c     5. Set up SStruct Vectors for b and x

c     We have one part and one variable.
         part = 0
         var = 0

c     Create an empty vector object
         call bHYPRE_SStructVector_Create_f( bHYPRE_mpicomm, grid, b,
     1        except )
         call bHYPRE_SStructVector_Create_f( bHYPRE_mpicomm, grid, x,
     1        except )

c     As with the matrix,  set the object type for the vectors
c     to be the struct type
      object_type = HYPRE_STRUCT;
      call bHYPRE_SStructVector_SetObjectType_f( b, object_type,
     1     ierr, except)
      call bHYPRE_SStructVector_SetObjectType_f( x, object_type,
     1     ierr, except)

c     Indicate that the vector coefficients are ready to be set
      call bHYPRE_SStructVector_Initialize_f( b, ierr, except )
      call bHYPRE_SStructVector_Initialize_f( x, ierr, except )

      if ( myid .eq. 0 ) then
c           Set the vector coefficients over the gridpoints in my first box
         ilower(1) = -3
         ilower(2) = 1
         iupper(1) = -1
         iupper(2) = 2
         nvalues = 6
c        ...  6 grid points

         do i = 1, nvalues
            values(i) = 1.0
         enddo
         call bHYPRE_SStructVector_SetBoxValues_f( b, part,
     1        ilower, iupper, ndim, var, values, nvalues, ierr, except )

         do i = 1, nvalues
            values(i) = 0.0
         enddo
         call bHYPRE_SStructVector_SetBoxValues_f( x, part,
     1        ilower, iupper, ndim, var, values, nvalues, ierr, except )

c     Set the vector coefficients over the gridpoints in my second box
         ilower(1) = 0
         ilower(2) = 1
         iupper(1) = 2
         iupper(2) = 4
         nvalues = 12
c        ... 12 grid points

         do i = 1, nvalues
            values(i) = 1.0
         enddo
         call bHYPRE_SStructVector_SetBoxValues_f( b, part,
     1        ilower, iupper, ndim, var, values, nvalues, ierr, except )

         do i = 1, nvalues
            values(i) = 0.0
         enddo
         call bHYPRE_SStructVector_SetBoxValues_f( x, part,
     1        ilower, iupper, ndim, var, values, nvalues, ierr, except )

      elseif ( myid .eq. 1 ) then
c     Set the vector coefficients over the gridpoints in my box
         ilower(1) = 3
         ilower(2) = 1
         iupper(1) = 6
         iupper(2) = 4
         nvalues = 16
c        ... 16 grid points

         do i = 1, nvalues
            values(i) = 1.0
         enddo
         call bHYPRE_SStructVector_SetBoxValues_f( b, part,
     1        ilower, iupper, ndim, var, values, nvalues, ierr, except )

         do i = 1, nvalues
            values(i) = 0.0
         enddo
         call bHYPRE_SStructVector_SetBoxValues_f( x, part,
     1        ilower, iupper, ndim, var, values, nvalues, ierr, except )

      endif

c     This is a collective call finalizing the vector assembly.
c     The vectors are now ``ready to be used''
      call bHYPRE_SStructVector_Assemble_f( b, ierr, except )
      call bHYPRE_SStructVector_Assemble_f( x, ierr, except )

c     6. Set up and use a solver (See the Reference Manual for descriptions
c     of all of the options.)

c        Because we are using a struct solver, we need to get the
c     object of the matrix and vectors to pass in to the struct solvers
      call bHYPRE_SStructMatrix_GetObject_f( A, dummy, ierr, except )
      call bHYPRE_StructMatrix__cast_f( dummy, sA,except )
      call sidl_BaseInterface_deleteRef_f( dummy, except )
      call bHYPRE_SStructVector_GetObject_f( b, dummy, ierr, except )
      call bHYPRE_Vector__cast_f( dummy, vb, except )
      call sidl_BaseInterface_deleteRef_f( dummy, except )
      call bHYPRE_SStructVector_GetObject_f( x, dummy, ierr, except )
      call bHYPRE_Vector__cast_f( dummy, vx, except )
      call sidl_BaseInterface_deleteRef_f( dummy, except )

c     Create an empty PCG Struct solver
      call bHYPRE_Operator__cast_f( sA, opA, except )
      call bHYPRE_PCG_Create_f( bHYPRE_mpicomm, opA, PCGsolver,
     1     except )

c     Set PCG parameters
c       Note that tol must be passed as a variable - putting 1.0e-6 directly
c       in the argument list won't work.
      tol = 1.0e-6
      call bHYPRE_PCG_SetDoubleParameter_f( PCGsolver, "Tolerance",
     1        tol, ierr, except )
      call bHYPRE_PCG_SetIntParameter_f( PCGsolver, "PrintLevel",
     1     2, ierr, except )
      call bHYPRE_PCG_SetIntParameter_f( PCGsolver, "MaxIter",
     1     50, ierr, except )

c     Create the Struct SMG solver for use as a preconditioner
      call bHYPRE_StructSMG_Create_f( bHYPRE_mpicomm, sA, SMGprecond,
     1     except )

c     Set SMG parameters
      call bHYPRE_StructSMG_SetIntParameter_f( SMGprecond,
     1     "MaxIter", 1, ierr, except )
      tol = 0.0
      call bHYPRE_StructSMG_SetDoubleParameter_f( SMGprecond,
     1     "Tolerance", tol, ierr, except )
      call bHYPRE_StructSMG_SetIntParameter_f( SMGprecond,
     1     "ZeroGuess", 1, ierr, except )
      call bHYPRE_StructSMG_SetIntParameter_f( SMGprecond,
     1     "NumPreRelax", 1, ierr, except )
      call bHYPRE_StructSMG_SetIntParameter_f( SMGprecond,
     1     "NumPostRelax", 1, ierr, except )

c     Set preconditioner and solve
      call bHYPRE_Solver__cast_f( SMGprecond, precond, except )
      call bHYPRE_PCG_SetPreconditioner_f( PCGsolver, precond,
     1     ierr, except )

      call bHYPRE_PCG_Setup_f( PCGsolver, vb, vx, ierr, except )
      call bHYPRE_PCG_Apply_f( PCGsolver, vb, vx, ierr, except )

      call bHYPRE_Operator_deleteRef_f( opA, except )
      call bHYPRE_Vector_deleteRef_f( vx, except )
      call bHYPRE_Vector_deleteRef_f( vb, except )
      call bHYPRE_StructMatrix_deleteRef_f( sA, except )

c     Free memory
      call bHYPRE_Solver_deleteRef_f( precond, except )
      call bHYPRE_StructSMG_deleteRef_f( SMGprecond, except )
      call bHYPRE_PCG_deleteRef_f( PCGsolver, except )
      call bHYPRE_SStructVector_deleteRef_f( x, except )
      call bHYPRE_SStructVector_deleteRef_f( b, except )
      call bHYPRE_SStructMatrix_deleteRef_f( A, except )
      call bHYPRE_SStructGraph_deleteRef_f( graph, except )
      call bHYPRE_SStructStencil_deleteRef_f( stencil, except )
      call bHYPRE_SStructGrid_deleteRef_f( grid, except )
      call bHYPRE_MPICommunicator_deleteRef_f( bHYPRE_mpicomm, except )

c     Finalize MPI
      call MPI_Finalize(ierrtmp)

      return
      end


! GitHub FortranTip print_stats.f90
module m
use iso_c_binding, only: c_float, c_int
implicit none
contains
subroutine print_stats(n,x) bind(c)
integer(kind=c_int)  , intent(in)  :: n
real(kind=c_float)   , intent(in)  :: x(n)
if (n < 1) return
print "(a,*(1x,f0.1))","min, max, mean =",minval(x),maxval(x),sum(x)/n
end subroutine print_stats
end module m


!##############################################################################
!# ****************************************************************************
!# <name> random </name>
!# ****************************************************************************
!# <purpose>
!# This module implements a pseudo-random number generator (rng).
!# The intention of this module is to provide a rng which generates a
!# (warning: paradoxon ahead) reproducible random number stream independent of
!# the platform and compiler in use.
!#
!# The algorithm used in this implementation is a 128-bit Xor-Shift agorithm,
!# as described in: George Marsaglia: Xorshift RNGs,
!# http://www.jstatsoft.org/v08/i14/paper
!#
!# The following routines can be found here:
!#
!# 1.) rng_init
!#     -> Initialises the rng data structure with a user-defined seed value.
!#
!# 2.) rng_initByClock
!#     -> Initialises the rng data structure using the current clock count
!#        as seed and returns the seed if desired.
!#
!# 3.) rng_get
!#     -> Returns the next random number in the stream.
!#
!# </purpose>
!##############################################################################

module random

!$ use omp_lib
use fsystem

implicit none

private

public :: t_random
public :: rng_init
public :: rng_initByClock
public :: rng_advance
public :: rng_get
public :: rng_get_int32
public :: rng_get_int32_range
public :: rng_get_double
public :: rng_get_double_range
public :: rng_get_single
public :: rng_get_single_range

!<constants>

!<constantblock description="Default values for the random number generator">

  integer(I32), parameter, public :: RNG_DEFAULT_S = 428147976_I32
  integer(I32), parameter, public :: RNG_DEFAULT_X = 362436069_I32
  integer(I32), parameter, public :: RNG_DEFAULT_Y = 521288629_I32
  integer(I32), parameter, public :: RNG_DEFAULT_Z =  88675123_I32

!</constantblock>

!</constants>

!<types>

!<typeblock description="Random number generator data structure">

  type t_random

    integer(I32) :: s = RNG_DEFAULT_S
    integer(I32) :: x = RNG_DEFAULT_X
    integer(I32) :: y = RNG_DEFAULT_Y
    integer(I32) :: z = RNG_DEFAULT_Z

  end type

!</typeblock>

!</types>

interface rng_get
  module procedure rng_get_int32
  module procedure rng_get_int32_range
  module procedure rng_get_double
  module procedure rng_get_double_range
  module procedure rng_get_single
  module procedure rng_get_single_range
end interface

contains

  ! ***************************************************************************

!<subroutine>

  pure subroutine rng_init(rrng, iseed)

!<description>
  ! Initialises the random number generator data structure.
!</description>

!<output>
  ! The random number generator data structure to be initialised.
  type(t_random), intent(out) :: rrng
!</output>

!<input>
  ! OPTIONAL: The seed for the rng. If not given, the default seed is used.
  integer(I32), optional, intent(in) :: iseed
!</input>

!</subroutine>

    ! rrng is automatically initialised with default values, since it is
    ! intent(out), so we only need to set the seed - if it is given.
    if(present(iseed)) &
      rrng%s = iseed

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine rng_initByClock(rrng, iseed)

!<description>
  ! Initialises the random number generator data structure using the current
  ! processor clock count as a seed. The seed that was used can optionally be
  ! returned by this routine to assure reproducibility of the random number
  ! stream.
!</description>

!<output>
  ! The random number generator data structure to be initialised.
  type(t_random), intent(out) :: rrng
!</output>

!<output>
  ! OPTIONAL: Recieves the seed which was used for the random number generator.
  integer(I32), optional, intent(out) :: iseed
!</output>

!</subroutine>

  integer(I32) :: t

    ! get current processor clock
    call system_clock(t)

    ! return seed if desired
    if(present(iseed)) &
      iseed = t

    ! initialise the rng
    call rng_init(rrng, t)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  pure subroutine rng_advance(rrng)

!<description>
  ! Advances the rng by one step. This routines does not need to be called by
  ! the user, as it is internally called by the rng_get_* routines.
!</description>

!<inputoutput>
  ! The rng data structure to be advanced.
  type(t_random), intent(inout) :: rrng
!</inputoutput>

!</subroutine>

  integer(I32) :: t

    t = ieor(rrng%s, ishft(rrng%s, 11))
    rrng%s = rrng%x
    rrng%x = rrng%y
    rrng%y = rrng%z
    rrng%z = ieor(ieor(rrng%z, ishft(rrng%z,-19)), ieor(t, ishft(t,-8)))

  end subroutine

  ! ***************************************************************************

!<subroutine>

  pure subroutine rng_get_int32(rrng, ix)

!<description>
  ! Returns the next non-negative 32-bit integer from the random number stream.
  ! The returned number is within the range {0,...,2^31-1}.
!</description>

!<inputoutput>
  ! The rng data structure.
  type(t_random), intent(inout) :: rrng
!</inputoutput>

!<output>
  ! Receives the next random number within the range {0,...,2^31-1}.
  integer(I32), intent(out) :: ix
!</output>

!</subroutine>

  ! Sign bit mask: This mask has all bits set to 1 except for the sign bit.
  integer(I32), parameter :: cmask = huge(0_I32)

    ! advance the rng
    call rng_advance(rrng)

    ! mask out the sign bit to obtain a value in the range {0, ..., 2^31-1}
    ix = iand(rrng%z, cmask)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  pure subroutine rng_get_int32_range(rrng, ix, imin, imax)

!<description>
  ! Returns the next 32-bit integer within a user-defined range from the
  ! random number stream.
  ! Notes:
  ! 1. For technical reasons, the range |imin-imax| must not exceed 2^31.
  ! 2. If imax < imin, then imin and imax are swapped.
  ! 3. If imin = imax, then the result ix is always set to imin.
!</description>

!<inputoutput>
  ! The rng data structure.
  type(t_random), intent(inout) :: rrng
!</inputoutput>

!<output>
  ! Recieves the next random number within the range {imin,...,imax}.
  integer(I32), intent(out) :: ix
!</output>

!<input>
  ! The range in which the random number ix should be contained. See notes in
  ! this routines description for more details.
  integer(I32), intent(in) :: imin, imax
!</input>

!</subroutine>

  integer(I32) :: t

    ! Note: It is intentional that we first get an int from the rng - and thus
    !       advance the rng - and check for imin = imax later.

    ! get a non-negative integer
    call rng_get_int32(rrng, t)

    ! transform into desired range
    if(imin .lt. imax) then
      ix = imin + mod(t, imax-imin+1)
    else if(imax .lt. imin) then
      ix = imax + mod(t, imin-imax+1)
    else
      ix = imin
    end if

  end subroutine

  ! ***************************************************************************

!<subroutine>

  pure subroutine rng_get_double(rrng, dx)

!<description>
  ! Returns the next double precision value in interval [0,1] (boundaries
  ! included) from the random number stream.
!</description>

!<inputoutput>
  ! The rng data structure.
  type(t_random), intent(inout) :: rrng
!</inputoutput>

!<output>
  ! Recieves the next random number within the interval [0,1].
  real(DP), intent(out) :: dx
!</output>

!</subroutine>

  integer(I32) :: t

    ! get a 32bit int
    call rng_get_int32(rrng, t)

    ! and scale it
    dx = real(t,DP) / real(huge(0_I32),DP)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  pure subroutine rng_get_double_range(rrng, dx, dmin, dmax)

!<description>
  ! Returns the next double precision value in a user-defined range from the
  ! random number stream.
!</description>

!<inputoutput>
  ! The rng data structure.
  type(t_random), intent(inout) :: rrng
!</inputoutput>

!<output>
  ! Recieves the next random number within the interval [dmin,dmax].
  real(DP), intent(out) :: dx
!</output>

!<input>
  ! The range in which the random number dx should be contained.
  real(DP), intent(in) :: dmin, dmax
!</input>

!</subroutine>

    call rng_get_double(rrng, dx)

    ! transform to range: [0,1] -> [dmin,dmax]
    dx = dmin + dx*(dmax-dmin)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  pure subroutine rng_get_single(rrng, fx)

!<description>
  ! Returns the next single precision value in interval [0,1] (boundaries
  ! included) from the random number stream.
!</description>

!<inputoutput>
  ! The rng data structure.
  type(t_random), intent(inout) :: rrng
!</inputoutput>

!<output>
  ! Recieves the next random number within the interval [0,1].
  real(SP), intent(out) :: fx
!</output>

!</subroutine>

  real(DP) :: dx

    ! call double-precision version
    call rng_get_double(rrng, dx)

    ! and transform to single-precision
    fx = real(dx, SP)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  pure subroutine rng_get_single_range(rrng, fx, fmin, fmax)

!<description>
  ! Returns the next single precision value in a user-defined range from the
  ! random number stream.
!</description>

!<inputoutput>
  ! The rng data structure.
  type(t_random), intent(inout) :: rrng
!</inputoutput>

!<output>
  ! Recieves the next random number within the interval [fmin,fmax].
  real(SP), intent(out) :: fx
!</output>

!<input>
  ! The range in which the random number dx should be contained.
  real(SP), intent(in) :: fmin, fmax
!</input>

!</subroutine>

  real(DP) :: dx

    ! call double-precision version
    call rng_get_double_range(rrng, dx, real(fmin,DP), real(fmax,DP))

    ! and transform to single-precision
    fx = real(dx, SP)

  end subroutine

end module


program hip_dgemm

  use iso_c_binding
  use hipfort
  use hipfort_check
  use hipfort_hipblas

  implicit none

  integer(kind(HIPBLAS_OP_N)), parameter :: transa = HIPBLAS_OP_N, transb = HIPBLAS_OP_N;
  double precision, parameter ::  alpha = 1.1d0, beta = 0.9d0;

  integer, parameter ::  m = 1024, n = 1024, k = 1024;
  integer :: lda, ldb, ldc, size_a, size_b, size_c;

  double precision, allocatable, target, dimension(:) :: ha, hb, hc
  double precision, allocatable, dimension(:) :: hc_exact

  type(c_ptr) :: da = c_null_ptr, db = c_null_ptr, dc = c_null_ptr
  type(c_ptr) :: handle = c_null_ptr

  integer, parameter :: bytes_per_element = 8 !double precision
  integer(c_size_t) :: Nabytes, Nbbytes, Ncbytes

  integer :: i
  double precision :: error
  double precision, parameter :: error_max = 10*epsilon(error)

  write(*,*) "Starting DGEMM test"

  call hipblasCheck(hipblasCreate(handle))

  lda        = m;
  size_a     = k * lda;
  Nabytes = size_a*bytes_per_element

  ldb        = k;
  size_b     = n * ldb;
  Nbbytes = size_b*bytes_per_element

  ldc    = m;
  size_c = n * ldc;
  Ncbytes = size_c*bytes_per_element

  allocate(ha(size_a))
  allocate(hb(size_b))
  allocate(hc(size_c))
  allocate(hc_exact(size_c))

  ! Use these constant matrices so the exact answer is also a
  ! constant matrix and therefore easy to check
  ha(:) = 1.d0
  hb(:) = 2.d0
  hc(:) = 3.d0
  hc_exact = alpha*k*2.d0 + beta*3.d0

  ! Allocate device memory
  call hipCheck(hipMalloc(da,Nabytes))
  call hipCheck(hipMalloc(db,Nbbytes))
  call hipCheck(hipMalloc(dc,Ncbytes))

  !Transfer from host to device
  call hipCheck(hipMemcpy(da, c_loc(ha), Nabytes, hipMemcpyHostToDevice))
  call hipCheck(hipMemcpy(db, c_loc(hb), Nbbytes, hipMemcpyHostToDevice))
  call hipCheck(hipMemcpy(dc, c_loc(hc), Ncbytes, hipMemcpyHostToDevice))

  call hipblasCheck(hipblasDgemm(handle,transa,transb,m,n,k,alpha,da,lda,db,ldb,beta,dc,ldc))

  call hipCheck(hipDeviceSynchronize())

  ! Transfer data back to host memory
  call hipCheck(hipMemcpy(c_loc(hc), dc, Ncbytes, hipMemcpyDeviceToHost))

  do i = 1,size_c
     error = abs((hc_exact(i) - hc(i))/hc_exact(i))
     if( error > error_max )then
        write(*,*) "DGEMM FAILED! Error bigger than max! Error = ", error
        call exit(1)
     end if
  end do

  call hipCheck(hipFree(da))
  call hipCheck(hipFree(db))
  call hipCheck(hipFree(dc))

  call hipblasCheck(hipblasDestroy(handle))

  deallocate(ha)
  deallocate(hb)
  deallocate(hc)
  deallocate(hc_exact)

  write(*,*) "DGEMM PASSED!"

end program hip_dgemm


      SUBROUTINE banmul(a,n,m1,m2,np,mp,x,b)
      INTEGER m1,m2,mp,n,np
      REAL a(np,mp),b(n),x(n)
      INTEGER i,j,k
      do 12 i=1,n
        b(i)=0.
        k=i-m1-1
        do 11 j=max(1,1-k),min(m1+m2+1,n-k)
          b(i)=b(i)+a(i,j)*x(j+k)
11      continue
12    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/banmul.for


    subroutine rtbis2(x1,x2,xacc,out)
!   ---------------------------------
    implicit none
    integer, parameter :: jmax=800
    double precision f2,xnothing,fmid,f1,dx,xmid,fxmid
    include 'combine_foam.inc'

    call phfunc2(x2,f2,xnothing)
    fmid=f2
    call phfunc2(x1,f1,xnothing)
    fph=f1
    if(fph*fmid.ge.0.) then
        write(6,*)x1,fph,x2,fmid
        write(6,*)'root must be bracketed:rtbis'
        stop
    endif
    if(fph.lt.0.) then
        out=x1
        dx=x2-x1
    else
        out=x2
        dx=x1-x2
    endif

    do j=1,jmax
        dx=dx*0.5
        xmid=out+dx
        call phfunc2(xmid,fxmid,xnothing)
        fmid=fxmid
        if(fmid.le.0.)out=xmid
        if(abs(dx).lt.xacc.or.fmid.eq.0.) return
    end do

!    pause 'too many bisection in rtbis2'
    end


C++*******************************************************************
C
C MEDIAN1
C
C To compute the median filtered version of the input image
C Uses NAG routine M01ANF
C
C Input parameters:
C  INPUT: input image
C  OUTPUT: output image
C  IBOX: Size of the box for which the median is comuted,
C        This should be an odd, positive integer greater than 3
C
C Syntax :   MEDIAN1 IN_FMT,OUT_FMT INPUT OUTPUT IBOX
C Example:   MEDIAN1 5,5 TEST TEST_MEDIAN 5
C
C JLP
C  Version of 25/03/90
C--**************************************************************************
	PROGRAM MEDIAN1
	INTEGER*4 PNTR_IN,PNTR_OUT
	CHARACTER NAMEIN*40,NAMEOUT*40,COMMENTS*80
	INTEGER*4 MADRID(1)
	COMMON /VMR/MADRID

10	FORMAT(A)

C Possibility of direct input of the parameters in the command line:
	CALL JLP_BEGIN

C Inquire the format of the files :
	CALL JLP_INQUIFMT

C Read the input image :
	NAMEIN=' '
	CALL JLP_VM_READIMAG(PNTR_IN,NX,NY,NAMEIN,COMMENTS)

C Obtain a name for the output :
	PRINT *,' OUTPUT IMAGE ?'
	READ(5,10) NAMEOUT

C Get dynamical memory for the output:
	I=NX*NY*4
	CALL JLP_GETVM(PNTR_OUT,I)
C
C NOW PICK UP THE BOX SIZE
C
	PRINT *,' Box size? (odd number > 3)'
	READ(5,*) IBOX
	IBOX=2*(IBOX/2)+1
	IF(IBOX.LT.3) THEN
	 PRINT *,' Box too small, I take Box size = 3'
	 IBOX=3
	ENDIF
	NB=NX/IBOX
	MB=NY/IBOX
	IF (NB.LE.3.OR.MB.LE.3) THEN
	 PRINT *,' FATAL ERROR : Box too large'
	 GOTO 999
	ENDIF
C
C HAVING GOT THE PARAMETERS , DO THE WORK
C
	CALL MEDIAN(MADRID(PNTR_IN),MADRID(PNTR_OUT),NX,NY,NX,IBOX)

C Ouput the results :
	LEN=INDEX(NAMEIN,'  ')-1
	WRITE(COMMENTS,11) NAMEIN(1:LEN),IBOX
11	FORMAT(' Median of: ',A,' Box:',I5)
	CALL JLP_WRITEIMAG(MADRID(PNTR_OUT),NX,NY,NX,NAMEOUT,COMMENTS)

999	CALL JLP_END
	STOP
	END
C**************************************************************************
      SUBROUTINE MEDIAN(IN,OUT,N,M,IDIM,IBOX)
C
C      IN IS THE INPUT ARRAY ; OUT THE OUTPUT ARRAY BOTH OF SIZE N BY M
C
C      THE ROUTINE APPLIES A MEDIAN FILTER TO THE INPUT ARRAY , YIELDING
C      THE OUTPUT ARRAY.
C      IBOX DEFINES THE SIZE OF THE BOX OVER WHICH THE MEDIAN IS COMPUTED
C
	REAL*4 IN(IDIM,*),OUT(IDIM,*),MEDN
C
C      SORT IS USED TO SORT THE PIXELS IN EACH BOX FOR THE MEDIAN
C
      DOUBLE PRECISION SORT(2500)
C
C      BOXSQ IS THE NUMBER OF PIXELS IN THE BOX (REAL) IBOXSC IS THE
C      INTEGER VERSION.
C
      IBOXSQ=IBOX*IBOX
      BOXSQ=IBOXSQ
C
C      FIRST ZEROIZE THE OUTPUT ARRAY
C
      DO 20 J=1,M
         DO 10 I=1,N
           OUT(I,J)=0
   10    CONTINUE
   20 CONTINUE
C
C      NOW FIGURE WHICH PIXELS CAN HAVE A BOX OF THIS SIZE ROUND THEM
C
      ISIDE=(IBOX-1)/2
      IS=1+ISIDE
      IE=N-ISIDE
      JS=1+ISIDE
      JE=M-ISIDE
      LOOP=0
C
C      NOW LOOP THROUGH ALL POSSIBLE PIXELS
C
      DO 500 J=JS,JE
         JHS=J-ISIDE
         JHE=J+ISIDE
         DO 400 I=IS,IE
            IHS=I-ISIDE
            IHE=I+ISIDE
C
C      SET THE PIXEL VALUES INTO A 1D ARRAY FOR SORTING
C
            K=1
            DO 200 JH=JHS,JHE
               DO 180 IH=IHS,IHE
                  SORT(K)=IN(IH,JH)
                  K=K+1
  180          CONTINUE
  200       CONTINUE
C
C Now call NAG M01ANF routine to do the sort
C
            IFAIL=0
            CALL M01ANF(SORT,1,IBOXSQ,IFAIL)
C
C and test that it is ok
C
            IF (IFAIL.NE.0) GO TO 400
C
C Now pick central value
C
            MEDN=SORT((IBOXSQ+1)/2)
C
C and store it in the output array
C
            OUT(I,J)=MEDN
  400    CONTINUE
  500 CONTINUE
C
C and return to calling segment
C
      RETURN
      END


!
!   rtsec.f90
!
!
!   Created by Kurt Mitman on 19/03/15.
!   Copyright 2015 __MyCompanyName__. All rights reserved.
!

SUBROUTINE rtsec(func,lx1,lx2,facc)

IMPLICIT NONE

REAL(8), INTENT(IN) :: lx1,lx2,facc
REAL(8) :: lrtsec,x1,x2
INTEGER, PARAMETER :: MAXIT=30
INTEGER :: j
REAL(8) :: dx,f,fl,xl,ltemp
REAL(8), EXTERNAL       :: func

x1 = lx1
x2 = lx2

fl=func(x1)
if (abs(fl)<facc) return

f=func(x2)
if (abs(f)<facc) return

if (abs(fl) < abs(f)) then
lrtsec=x1
xl=x2
ltemp = fl
fl = f
f = ltemp
else
xl=x1
lrtsec=x2
end if

do j=1,MAXIT
dx=(xl-lrtsec)*f/(f-fl)
xl=lrtsec
fl=f
lrtsec=lrtsec+dx
f=func(lrtsec)
if (abs(f)<facc) return
end do

write(*,*)('rtsec: exceed maximum iterations')

END SUBROUTINE rtsec


      SUBROUTINE SB16AY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NC, NCS,
     $                   A, LDA, B, LDB, C, LDC, D, LDD,
     $                   AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC,
     $                   SCALEC, SCALEO, S, LDS, R, LDR,
     $                   IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute for given state-space representations (A,B,C,D) and
C     (Ac,Bc,Cc,Dc) of the transfer-function matrices of the
C     open-loop system G and feedback controller K, respectively,
C     the Cholesky factors of the frequency-weighted
C     controllability and observability Grammians corresponding
C     to a frequency-weighted model reduction problem.
C     The controller must stabilize the closed-loop system.
C     The state matrix Ac must be in a block-diagonal real Schur form
C     Ac = diag(Ac1,Ac2), where Ac1 contains the unstable eigenvalues
C     of Ac and Ac2 contains the stable eigenvalues of Ac.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the systems as follows:
C             = 'C':  G and K are continuous-time systems;
C             = 'D':  G and K are discrete-time systems.
C
C     JOBC    CHARACTER*1
C             Specifies the choice of frequency-weighted controllability
C             Grammian as follows:
C             = 'S': choice corresponding to standard Enns' method [1];
C             = 'E': choice corresponding to the stability enhanced
C                    modified Enns' method of [2].
C
C     JOBO    CHARACTER*1
C             Specifies the choice of frequency-weighted observability
C             Grammian as follows:
C             = 'S': choice corresponding to standard Enns' method [1];
C             = 'E': choice corresponding to the stability enhanced
C                    modified combination method of [2].
C
C     WEIGHT  CHARACTER*1
C             Specifies the type of frequency-weighting, as follows:
C             = 'N':  no weightings are used (V = I, W = I);
C             = 'O':  stability enforcing left (output) weighting
C                               -1
C                     V = (I-G*K) *G is used (W = I);
C             = 'I':  stability enforcing right (input) weighting
C                               -1
C                     W = (I-G*K) *G is used (V = I);
C             = 'P':  stability and performance enforcing weightings
C                               -1                -1
C                     V = (I-G*K) *G ,  W = (I-G*K)  are used.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the open-loop system state-space
C             representation, i.e., the order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     NC      (input) INTEGER
C             The order of the controller state-space representation,
C             i.e., the order of the matrix AC.  NC >= 0.
C
C     NCS     (input) INTEGER
C             The dimension of the stable part of the controller, i.e.,
C             the order of matrix Ac2.  NC >= NCS >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             state matrix A of the system with the transfer-function
C             matrix G.
C
C     LDA     INTEGER
C             The leading dimension of 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             input/state matrix B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array must contain the
C             state/output matrix C.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading P-by-M part of this array must contain the
C             input/output matrix D of the open-loop system.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
C
C     AC      (input) DOUBLE PRECISION array, dimension (LDAC,NC)
C             The leading NC-by-NC part of this array must contain
C             the state dynamics matrix Ac of the controller in a
C             block diagonal real Schur form Ac = diag(Ac1,Ac2), where
C             Ac1 is (NC-NCS)-by-(NC-NCS) and contains the unstable
C             eigenvalues of Ac, and Ac2 is NCS-by-NCS and contains
C             the stable eigenvalues of Ac.
C
C     LDAC    INTEGER
C             The leading dimension of array AC.  LDAC >= MAX(1,NC).
C
C     BC      (input) DOUBLE PRECISION array, dimension (LDBC,P)
C             The leading NC-by-P part of this array must contain
C             the input/state matrix Bc of the controller.
C
C     LDBC    INTEGER
C             The leading dimension of array BC.  LDBC >= MAX(1,NC).
C
C     CC      (input) DOUBLE PRECISION array, dimension (LDCC,NC)
C             The leading M-by-NC part of this array must contain
C             the state/output matrix Cc of the controller.
C
C     LDCC    INTEGER
C             The leading dimension of array CC.  LDCC >= MAX(1,M).
C
C     DC      (input) DOUBLE PRECISION array, dimension (LDDC,P)
C             The leading M-by-P part of this array must contain
C             the input/output matrix Dc of the controller.
C
C     LDDC    INTEGER
C             The leading dimension of array DC.  LDDC >= MAX(1,M).
C
C     SCALEC  (output) DOUBLE PRECISION
C             Scaling factor for the controllability Grammian.
C             See METHOD.
C
C     SCALEO  (output) DOUBLE PRECISION
C             Scaling factor for the observability Grammian. See METHOD.
C
C     S       (output) DOUBLE PRECISION array, dimension (LDS,NCS)
C             The leading NCS-by-NCS upper triangular part of this array
C             contains the Cholesky factor S of the frequency-weighted
C             controllability Grammian P = S*S'. See METHOD.
C
C     LDS     INTEGER
C             The leading dimension of array S.  LDS >= MAX(1,NCS).
C
C     R       (output) DOUBLE PRECISION array, dimension (LDR,NCS)
C             The leading NCS-by-NCS upper triangular part of this array
C             contains the Cholesky factor R of the frequency-weighted
C             observability Grammian Q = R'*R. See METHOD.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,NCS).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWRK)
C             LIWRK = 0,       if WEIGHT = 'N';
C             LIWRK = 2(M+P),  if WEIGHT = 'O', 'I', or 'P'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX( 1, LFREQ ),
C             where
C             LFREQ = (N+NC)*(N+NC+2*M+2*P)+
C                     MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), (M+P)*(M+P+4))
C                                      if WEIGHT = 'I' or 'O' or 'P';
C             LFREQ  = NCS*(MAX(M,P)+5) if WEIGHT = 'N'.
C             For optimum performance LDWORK should be larger.
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:  the closed-loop system is not well-posed;
C                   its feedthrough matrix is (numerically) singular;
C             = 2:  the computation of the real Schur form of the
C                   closed-loop state matrix failed;
C             = 3:  the closed-loop state matrix is not stable;
C             = 4:  the solution of a symmetric eigenproblem failed;
C             = 5:  the NCS-by-NCS trailing part Ac2 of the state
C                   matrix Ac is not stable or not in a real Schur form.
C
C     METHOD
C
C     If JOBC = 'S', the controllability Grammian P is determined as
C     follows:
C
C     - if WEIGHT = 'O' or 'N', P satisfies for a continuous-time
C       controller the Lyapunov equation
C
C            Ac2*P + P*Ac2' +  scalec^2*Bc*Bc' = 0
C
C       and for a discrete-time controller
C
C            Ac2*P*Ac2' - P +  scalec^2*Bc*Bc' = 0;
C
C     - if WEIGHT = 'I' or 'P', let Pi be the solution of the
C       continuous-time Lyapunov equation
C
C            Ai*Pi + Pi*Ai' +  scalec^2*Bi*Bi' = 0
C
C       or of the discrete-time Lyapunov equation
C
C            Ai*Pi*Ai' - Pi +  scalec^2*Bi*Bi' = 0,
C
C       where Ai and Bi are the state and input matrices of a special
C       state-space realization of the input frequency weight (see [2]);
C       P results as the trailing NCS-by-NCS part of Pi partitioned as
C
C           Pi = ( *  * ).
C                ( *  P )
C
C     If JOBC = 'E', a modified controllability Grammian P1 >= P is
C     determined to guarantee stability for a modified Enns' method [2].
C
C     If JOBO = 'S', the observability Grammian Q is determined as
C     follows:
C
C     - if WEIGHT = 'I' or 'N', Q satisfies for a continuous-time
C       controller the Lyapunov equation
C
C            Ac2'*Q + Q*Ac2 +  scaleo^2*Cc'*Cc = 0
C
C       and for a discrete-time controller
C
C            Ac2'*Q*Ac2 - Q +  scaleo^2*Cc'*Cc = 0;
C
C     - if WEIGHT = 'O' or 'P', let Qo be the solution of the
C       continuous-time Lyapunov equation
C
C            Ao'*Qo + Qo*Ao +  scaleo^2*Co'*Co = 0
C
C       or of the discrete-time Lyapunov equation
C
C            Ao'*Qo*Ao - Qo +  scaleo^2*Co'*Co = 0,
C
C       where Ao and Co are the state and output matrices of a
C       special state-space realization of the output frequency weight
C       (see [2]); if WEIGHT = 'O', Q results as the leading NCS-by-NCS
C       part of Qo partitioned as
C
C           Qo = ( Q  * )
C                ( *  * )
C
C       while if WEIGHT = 'P', Q results as the trailing NCS-by-NCS
C       part of Qo partitioned as
C
C           Qo = ( *  * ).
C                ( *  Q )
C
C     If JOBO = 'E', a modified observability Grammian Q1 >= Q is
C     determined to guarantee stability for a modified Enns' method [2].
C
C     The routine computes directly the Cholesky factors S and R
C     such that P = S*S' and Q = R'*R according to formulas
C     developed in [2].
C
C     REFERENCES
C
C     [1] Enns, D.
C         Model reduction with balanced realizations: An error bound
C         and a frequency weighted generalization.
C         Proc. CDC, Las Vegas, pp. 127-132, 1984.
C
C     [2] Varga, A. and Anderson, B.D.O.
C         Frequency-weighted balancing related controller reduction.
C         Proceedings of the 15th IFAC World Congress, July 21-26, 2002,
C         Barcelona, Spain, Vol.15, Part 1, 2002-07-21.
C
C     CONTRIBUTORS
C
C     A. Varga, Australian National University, Canberra, November 2000.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000,
C     May 2009.
C     A. Varga, DLR Oberpfafenhofen, June 2001.
C
C
C     KEYWORDS
C
C     Controller reduction, frequency weighting, multivariable system,
C     state-space model, state-space representation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER        DICO, JOBC, JOBO, WEIGHT
      INTEGER          INFO, LDA, LDAC, LDB, LDBC, LDC, LDCC, LDD, LDDC,
     $                 LDR, LDS, LDWORK, M, N, NC, NCS, P
      DOUBLE PRECISION SCALEC, SCALEO
C     .. Array Arguments ..
      INTEGER          IWORK(*)
      DOUBLE PRECISION A(LDA,*), AC(LDAC,*), B(LDB,*), BC(LDBC,*),
     $                 C(LDC,*), CC(LDCC,*), D(LDD,*), DC(LDDC,*),
     $                 DWORK(*), R(LDR,*),   S(LDS,*)
C     .. Local Scalars ..
      CHARACTER        JOBFAC
      LOGICAL          DISCR, FRWGHT, LEFTW, PERF, RIGHTW
      INTEGER          I, IERR, J, JJ, KI, KL, KQ, KR, KTAU, KU, KW,
     $                 KWA, KWB, KWC, KWD, LDU, LW, MBBAR, ME, MP,
     $                 NCU, NCU1, NE, NNC, NNCU, PCBAR, PE, WRKOPT
      DOUBLE PRECISION RCOND, T, TOL
C     .. Local Arrays ..
      DOUBLE PRECISION DUM(1)
C     .. External Functions ..
      LOGICAL          LSAME
      DOUBLE PRECISION DLAMCH
      EXTERNAL         DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL         AB05PD, AB05QD, AB07ND, DCOPY, DLACPY, DLASET,
     $                 DSCAL, DSYEV, MB01WD, MB04OD, SB03OD, SB03OU,
     $                 XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        ABS, INT, MAX, MIN, SQRT
C     .. Executable Statements ..
C
      DISCR  = LSAME( DICO,   'D' )
      LEFTW  = LSAME( WEIGHT, 'O' )
      RIGHTW = LSAME( WEIGHT, 'I' )
      PERF   = LSAME( WEIGHT, 'P' )
      FRWGHT = LEFTW .OR. RIGHTW .OR. PERF
C
      INFO = 0
      NNC  = N + NC
      MP   = M + P
      IF( FRWGHT ) THEN
         LW = NNC*( NNC + 2*MP ) +
     $        MAX( NNC*( NNC + MAX( NNC, M, P ) + 7 ), MP*( MP + 4 ) )
      ELSE
         LW = NCS*( MAX( M, P ) + 5 )
      END IF
      LW = MAX( 1, LW )
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) )
     $     THEN
         INFO = -2
      ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) )
     $     THEN
         INFO = -3
      ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( M.LT.0 ) THEN
         INFO = -6
      ELSE IF( P.LT.0 ) THEN
         INFO = -7
      ELSE IF( NC.LT.0 ) THEN
         INFO = -8
      ELSE IF( NCS.LT.0 .OR. NCS.GT.NC ) THEN
         INFO = -9
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -15
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -17
      ELSE IF( LDAC.LT.MAX( 1, NC ) ) THEN
         INFO = -19
      ELSE IF( LDBC.LT.MAX( 1, NC ) ) THEN
         INFO = -21
      ELSE IF( LDCC.LT.MAX( 1, M ) ) THEN
         INFO = -23
      ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN
         INFO = -25
      ELSE IF( LDS.LT.MAX( 1, NCS ) ) THEN
         INFO = -29
      ELSE IF( LDR.LT.MAX( 1, NCS ) ) THEN
         INFO = -31
      ELSE IF( LDWORK.LT.LW ) THEN
         INFO = -34
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB16AY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      SCALEC = ONE
      SCALEO = ONE
      IF( MIN( NCS, M, P ).EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      WRKOPT = 1
      NCU  = NC - NCS
      NCU1 = NCU + 1
C
      IF( .NOT.PERF ) THEN
C
C        Compute the Grammians in the case of no weighting or
C        one-sided weighting.
C
         IF( LEFTW .OR. LSAME( WEIGHT, 'N' ) ) THEN
C
C           Compute the standard controllability Grammian.
C
C           Solve for the Cholesky factor S of P, P = S*S',
C           the continuous-time Lyapunov equation (if DICO = 'C')
C
C               Ac2*P + P*Ac2' +  scalec^2*Bc2*Bc2' = 0,
C
C           or the discrete-time Lyapunov equation (if DICO = 'D')
C
C               Ac2*P*Ac2' - P +  scalec^2*Bc2*Bc2' = 0,
C
C           where Bc2 is the matrix formed from the last NCS rows of Bc.
C
C           Workspace:  need   NCS*(P+5);
C                              prefer larger.
            KU   = 1
            KTAU = KU + NCS*P
            KW   = KTAU + NCS
C
            CALL DLACPY( 'Full', NCS, P, BC(NCU1,1), LDBC,
     $                   DWORK(KU), NCS )
            CALL SB03OU( DISCR, .TRUE., NCS, P, AC(NCU1,NCU1), LDAC,
     $                   DWORK(KU), NCS, DWORK(KTAU), S, LDS, SCALEC,
     $                   DWORK(KW), LDWORK-KW+1, IERR )
            IF( IERR.NE.0 ) THEN
               INFO = 5
               RETURN
            END IF
            WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
         END IF
C
         IF( RIGHTW .OR. LSAME( WEIGHT, 'N' ) ) THEN
C
C           Compute the standard observability Grammian.
C
C           Solve for the Cholesky factor R of Q, Q = R'*R,
C           the continuous-time Lyapunov equation (if DICO = 'C')
C
C               Ac2'*Q + Q*Ac2  +  scaleo^2*Cc2'*Cc2 = 0,
C
C           or the discrete-time Lyapunov equation (if DICO = 'D')
C
C               Ac2'*Q*Ac2 - Q +  scaleo^2*Cc2'*Cc2 = 0,
C
C           where Cc2 is the matrix formed from the last NCS columns
C           of Cc.
C
C           Workspace:  need   NCS*(M + 5);
C                              prefer larger.
            KU   = 1
            KTAU = KU + M*NCS
            KW   = KTAU + NCS
C
            CALL DLACPY( 'Full', M, NCS, CC(1,NCU1), LDCC,
     $                   DWORK(KU), M )
            CALL SB03OU( DISCR, .FALSE., NCS, M, AC(NCU1,NCU1), LDAC,
     $                   DWORK(KU), M, DWORK(KTAU), R, LDR, SCALEO,
     $                   DWORK(KW), LDWORK-KW+1, IERR )
            IF( IERR.NE.0 ) THEN
               INFO = 5
               RETURN
            END IF
            WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
         END IF
C
C        Finish if there are no weights.
C
         IF( LSAME( WEIGHT, 'N' ) ) THEN
            DWORK(1) = WRKOPT
            RETURN
         END IF
      END IF
C
      IF( FRWGHT ) THEN
C
C        Allocate working storage for computing the weights.
C
C        Real workspace:    need MAX(1,NNC*NNC+2*NNC*MP+MP*(MP+4));
C        Integer workspace: need 2*MP.
C
         KWA = 1
         KWB = KWA + NNC*NNC
         KWC = KWB + NNC*MP
         KWD = KWC + NNC*MP
         KW  = KWD + MP*MP
         KL  = KWD
C
         IF( LEFTW ) THEN
C
C           Build the extended matrices
C
C           Ao = ( Ac+Bc*inv(R)*D*Cc   Bc*inv(R)*C   ),
C                (     B*inv(Rt)*Cc  A+B*Dc*inv(R)*C )
C
C           Co = ( -inv(R)*D*Cc  -inv(R)*C ) ,
C
C           where  R = I-D*Dc and Rt = I-Dc*D.
C                             -1
C           Method: Compute Ge  = ( Ge11 Ge12 ), where Ge = ( K   -Im ).
C                                 ( Ge21 Ge22 )             ( -Ip  G  )
C
C                               -1
C           Then  Ge11 = -(I-G*K) *G .
C
C           Construct first Ge = (  K  -Im ) such that the stable part
C                                ( -Ip  G  )
C           of K is in the leading position (to avoid updating of
C           QR factorization).
C
            CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KWD), MP )
            CALL AB05PD( 'N', NCS, P, M, NCU, ONE,
     $                   AC(NCU1,NCU1), LDAC, BC(NCU1,1), LDBC,
     $                   CC(1,NCU1), LDCC, DWORK(KWD), MP,
     $                   AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC,
     $                   NE, DWORK(KWA), NNC, DWORK(KWB), NNC,
     $                   DWORK(KWC), MP, DWORK(KWD), MP, IERR )
            CALL AB05QD( 'Over', NC, P, M, N, M, P, DWORK(KWA), NNC,
     $                   DWORK(KWB), NNC, DWORK(KWC), MP, DWORK(KWD),
     $                   MP, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   NE, ME, PE, DWORK(KWA), NNC, DWORK(KWB), NNC,
     $                   DWORK(KWC), MP, DWORK(KWD), MP, IERR )
            CALL DLASET( 'Full', M, M, ZERO, -ONE, DWORK(KWD+MP*P), MP )
            CALL DLASET( 'Full', P, P, ZERO, -ONE, DWORK(KWD+M), MP )
C
         ELSE
C
C           Build the extended matrices
C
C           Ai = ( A+B*Dc*inv(R)*C   B*inv(Rt)*Cc   ) ,
C                (   Bc*inv(R)*C  Ac+Bc*inv(R)*D*Cc )
C
C           Bi = ( B*Dc*inv(R)    B*inv(Rt)  ) ,
C                ( Bc*inv(R)    Bc*D*inv(Rt) )
C
C           Ci = (  -inv(R)*C   -inv(R)*D*Cc ) , where
C
C           R = I-D*Dc and Rt = I-Dc*D.
C
C                             -1
C           Method: Compute Ge  = ( Ge11 Ge12 ), where Ge = ( G   -Ip ).
C                                 ( Ge21 Ge22 )             ( -Im  K  )
C
C                              -1                     -1
C           Then Ge22 = -(I-G*K) *G and Ge21 = -(I-G*K) .
C
C           Construct first Ge = (  G  -Ip ).
C                                ( -Im  K  )
C
            CALL AB05QD( 'N', N, M, P, NC, P, M, A, LDA, B, LDB, C, LDC,
     $                   D, LDD, AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC,
     $                   NE, ME, PE, DWORK(KWA), NNC, DWORK(KWB), NNC,
     $                   DWORK(KWC), MP, DWORK(KWD), MP, IERR )
            CALL DLASET( 'Full', P, P, ZERO, -ONE, DWORK(KWD+MP*M), MP )
            CALL DLASET( 'Full', M, M, ZERO, -ONE, DWORK(KWD+P), MP )
         END IF
C                  -1
C        Compute Ge   = ( Ge11 Ge12 ).
C                       ( Ge21 Ge22 )
C
C        Additional real workspace: need 4*MP;
C        Integer workspace:         need 2*MP.
C
         CALL AB07ND( NNC, MP, DWORK(KWA), NNC, DWORK(KWB), NNC,
     $                DWORK(KWC), MP, DWORK(KWD), MP, RCOND,
     $                IWORK, DWORK(KW), LDWORK-KW+1, IERR )
         IF( IERR.NE.0 ) THEN
            INFO = 1
            RETURN
         END IF
         WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C                     -1   ( A1 | B1  B2  )
C        Partition  Ge   = (--------------) and select appropriate
C                          ( C1 | D11 D12 )
C                          ( C2 | D21 D22 )
C
C        pointers to matrices and column dimensions to define weights.
C
         IF( RIGHTW ) THEN
C
C           Define B2 for Ge22.
C
            ME  = M
            KWB = KWB + NNC*P
         ELSE IF( PERF ) THEN
C
C           Define B1 and C2 for Ge21.
C
            ME  = P
            KWC = KWC + M
         END IF
      END IF
C
      IF( LEFTW .OR. PERF ) THEN
C
C        Compute the frequency-weighted observability Grammian.
C
C        Solve for the Cholesky factor Ro of Qo, Qo = Ro'*Ro,
C        the continuous-time Lyapunov equation (if DICO = 'C')
C
C            Ao'*Qo + Qo*Ao  +  scaleo^2*Co'*Co = 0,
C
C        or the discrete-time Lyapunov equation (if DICO = 'D')
C
C            Ao'*Qo*Ao - Qo +  scaleo^2*Co'*Co = 0.
C
C        Additional workspace:  need   NNC*(NNC+MAX(NNC,P)+7);
C                               prefer larger.
C
         LDU = MAX( NNC, P )
         KU  = KL
         KQ  = KU + NNC*LDU
         KR  = KQ + NNC*NNC
         KI  = KR + NNC
         KW  = KI + NNC
C
         JOBFAC = 'N'
         CALL DLACPY( 'Full', P, NNC, DWORK(KWC), MP, DWORK(KU), LDU )
         CALL SB03OD( DICO, JOBFAC, 'No-transpose', NNC, P,
     $                DWORK(KWA), NNC, DWORK(KQ), NNC, DWORK(KU), LDU,
     $                SCALEO, DWORK(KR), DWORK(KI), DWORK(KW),
     $                LDWORK-KW+1, IERR )
         IF( IERR.NE.0 ) THEN
            IF( IERR.EQ.6 ) THEN
               INFO = 2
            ELSE
               INFO = 3
            END IF
            RETURN
         END IF
         WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C        Partition Ro as Ro = ( R11 R12 ).
C                             (  0  R22 )
C
         IF( LEFTW ) THEN
C
C           R = R11 (NCS-by-NCS).
C
            CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU), LDU, R, LDR )
         ELSE
C
C           Compute R such that R'*R = R22'*R22 + R12'*R12, where
C           R22 is NCS-by-NCS and R12 is (N+NCU)-by-NCS.
C           R22 corresponds to the stable part of the controller.
C
            NNCU = N + NCU
            CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU+(LDU+1)*NNCU), LDU,
     $                   R, LDR )
            KTAU = KU
            CALL MB04OD( 'Full', NCS, 0, NNCU, R, LDR,
     $                   DWORK(KU+LDU*NNCU), LDU, DUM, 1, DUM, 1,
     $                   DWORK(KTAU), DWORK(KW) )
C
            DO 10 J = 1, NCS
               IF( R(J,J).LT.ZERO )
     $            CALL DSCAL( NCS-J+1, -ONE, R(J,J), LDR )
   10       CONTINUE
         END IF
      END IF
C
      IF( RIGHTW .OR. PERF ) THEN
C
C        Compute the frequency-weighted controllability Grammian.
C
C        Solve for the Cholesky factor Si of Pi, Pi = Si*Si',
C        the continuous-time Lyapunov equation (if DICO = 'C')
C
C            Ai*Pi + Pi*Ai' +  scalec^2*Bi*Bi' = 0,
C
C        or the discrete-time Lyapunov equation (if DICO = 'D')
C
C            Ai*Pi*Ai' - Pi +  scalec^2*Bi*Bi' = 0.
C
C        Additional workspace:  need   NNC*(NNC+MAX(NNC,P,M)+7);
C                               prefer larger.
C
         KU = KL
         KQ = KU + NNC*MAX( NNC, ME )
         KR = KQ + NNC*NNC
         KI = KR + NNC
         KW = KI + NNC
C
         CALL DLACPY( 'Full', NNC, ME, DWORK(KWB), NNC, DWORK(KU), NNC )
         JOBFAC = 'F'
         IF( RIGHTW ) JOBFAC = 'N'
         CALL SB03OD( DICO, JOBFAC, 'Transpose', NNC, ME,
     $                DWORK(KWA), NNC, DWORK(KQ), NNC, DWORK(KU), NNC,
     $                SCALEC, DWORK(KR), DWORK(KI), DWORK(KW),
     $                LDWORK-KW+1, IERR )
         IF( IERR.NE.0 ) THEN
            IF( IERR.EQ.6 ) THEN
               INFO = 2
            ELSE
               INFO = 3
            END IF
            RETURN
         END IF
         WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C        Partition Si as Si = ( S11 S12 ) with S22 NCS-by-NCS and
C                             (  0  S22 )
C        set S = S22.
C
         NNCU = N + NCU
         CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU+(NNC+1)*NNCU), NNC,
     $                S, LDS )
      END IF
C
      KU = 1
      IF( LEFTW .OR. PERF ) THEN
         IF( LSAME( JOBO, 'E' ) ) THEN
C
C           Form Y = -Ac2'*(R'*R)-(R'*R)*Ac2 if DICO = 'C', or
C                Y = -Ac2'*(R'*R)*Ac2+(R'*R) if DICO = 'D'.
C
C           Workspace:  need   2*NCS*NCS.
C
            CALL DLACPY( 'Upper', NCS, NCS, R, LDR, DWORK(KU), NCS )
            CALL DLACPY( 'Full', NCS, NCS, AC(NCU1,NCU1), LDAC,
     $                   DWORK(KU+NCS*NCS), NCS )
            CALL MB01WD( DICO, 'Upper', 'No-transpose', 'Hessenberg',
     $                   NCS, -ONE, ZERO, R, LDR, DWORK(KU+NCS*NCS),
     $                   NCS, DWORK(KU), NCS, IERR )
C
C           Compute the eigendecomposition of Y as Y = Z*Sigma*Z'.
C
            KW = KU + NCS
            CALL DSYEV( 'Vectors', 'Upper', NCS, R, LDR, DWORK(KU),
     $                  DWORK(KW), LDWORK-KW+1, IERR )
            IF( IERR.GT.0 ) THEN
               INFO = 4
               RETURN
            END IF
            WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C           Partition Sigma = (Sigma1,Sigma2), such that
C           Sigma1 <= 0, Sigma2 > 0.
C           Partition correspondingly Z = [Z1 Z2].
C
            TOL = MAX( ABS( DWORK(KU) ), ABS( DWORK(KU+NCS-1) ) )
     $            * DLAMCH( 'Epsilon')
C                _
C           Form Cc = [ sqrt(Sigma2)*Z2' ]
C
            PCBAR = 0
            JJ = KU
            DO 20 J = 1, NCS
               IF( DWORK(JJ).GT.TOL ) THEN
                  CALL DSCAL( NCS, SQRT( DWORK(JJ) ), R(1,J), 1 )
                  CALL DCOPY( NCS, R(1,J), 1, DWORK(KW+PCBAR), NCS )
                  PCBAR = PCBAR + 1
               END IF
               JJ = JJ + 1
   20       CONTINUE
C
C           Solve for the Cholesky factor R of Q, Q = R'*R,
C           the continuous-time Lyapunov equation (if DICO = 'C')
C                                               _   _
C                   Ac2'*Q + Q*Ac2  +  scaleo^2*Cc'*Cc = 0,
C
C           or the discrete-time Lyapunov equation (if DICO = 'D')
C                                              _   _
C                   Ac2'*Q*Ac2 - Q +  scaleo^2*Cc'*Cc = 0.
C
C           Workspace:  need   NCS*(NCS + 6);
C                              prefer larger.
C
            KU   = KW
            KTAU = KU + NCS*NCS
            KW   = KTAU + NCS
C
            CALL SB03OU( DISCR, .FALSE., NCS, PCBAR, AC(NCU1,NCU1),
     $                   LDAC, DWORK(KU), NCS, DWORK(KTAU), R, LDR, T,
     $                   DWORK(KW), LDWORK-KW+1, IERR )
            IF( IERR.NE.0 ) THEN
               INFO = 5
               RETURN
            END IF
            SCALEO = SCALEO*T
            WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
         END IF
C
      END IF
C
      IF( RIGHTW .OR. PERF ) THEN
         IF( LSAME( JOBC, 'E' ) ) THEN
C
C           Form X = -A2c*(S*S')-(S*S')*Ac2' if DICO = 'C', or
C                X = -Ac2*(S*S')*Ac2'+(S*S') if DICO = 'D'.
C
C           Workspace:  need   2*NCS*NCS.
C
            CALL DLACPY( 'Upper', NCS, NCS, S, LDS, DWORK(KU), NCS )
            CALL DLACPY( 'Full', NCS, NCS, AC(NCU1,NCU1), LDAC,
     $                   DWORK(KU+NCS*NCS), NCS )
            CALL MB01WD( DICO, 'Upper', 'Transpose', 'Hessenberg', NCS,
     $                   -ONE, ZERO, S, LDS, DWORK(KU+NCS*NCS), NCS,
     $                   DWORK(KU), NCS, IERR )
C
C           Compute the eigendecomposition of X as X = Z*Sigma*Z'.
C
            KW = KU + NCS
            CALL DSYEV( 'Vectors', 'Upper', NCS, S, LDS, DWORK(KU),
     $                  DWORK(KW), LDWORK-KW+1, IERR )
            IF( IERR.GT.0 ) THEN
               INFO = 4
               RETURN
            END IF
            WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C           Partition Sigma = (Sigma1,Sigma2), such that
C           Sigma1 =< 0, Sigma2 > 0.
C           Partition correspondingly Z = [Z1 Z2].
C
            TOL = MAX( ABS( DWORK(KU) ), ABS( DWORK(KU+NCS-1) ) )
     $            * DLAMCH( 'Epsilon')
C                _
C           Form Bc = [ Z2*sqrt(Sigma2) ]
C
            MBBAR = 0
            I  = KW
            JJ = KU
            DO 30 J = 1, NCS
               IF( DWORK(JJ).GT.TOL ) THEN
                  MBBAR = MBBAR + 1
                  CALL DSCAL( NCS, SQRT( DWORK(JJ) ), S(1,J), 1 )
                  CALL DCOPY( NCS, S(1,J), 1, DWORK(I), 1 )
                  I = I + NCS
               END IF
               JJ = JJ + 1
   30       CONTINUE
C
C           Solve for the Cholesky factor S of P, P = S*S',
C           the continuous-time Lyapunov equation (if DICO = 'C')
C                                               _  _
C                   Ac2*P + P*Ac2'  +  scalec^2*Bc*Bc' = 0,
C
C           or the discrete-time Lyapunov equation (if DICO = 'D')
C                                              _  _
C                   Ac2*P*Ac2' - P +  scalec^2*Bc*Bc' = 0.
C
C           Workspace:  need   maximum NCS*(NCS + 6);
C                       prefer larger.
C
            KU   = KW
            KTAU = KU + MBBAR*NCS
            KW   = KTAU + NCS
C
            CALL SB03OU( DISCR, .TRUE., NCS, MBBAR, AC(NCU1,NCU1), LDAC,
     $                   DWORK(KU), NCS, DWORK(KTAU), S, LDS, T,
     $                   DWORK(KW), LDWORK-KW+1, IERR )
            IF( IERR.NE.0 ) THEN
               INFO = 5
               RETURN
            END IF
            SCALEC = SCALEC*T
            WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
         END IF
C
      END IF
C
C     Save optimal workspace.
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of SB16AY ***
      END


      subroutine dpbfa(abd,lda,n,m,info)

      integer lda,n,m,info
      double precision abd(lda,n)
c
c     dpbfa factors a double precision symmetric positive definite
c     matrix stored in band form.
c
c     dpbfa is usually called by dpbco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c
c     on entry
c
c        abd     double precision(lda, n)
c                the matrix to be factored.  the columns of the upper
c                triangle are stored in the columns of abd and the
c                diagonals of the upper triangle are stored in the
c                rows of abd .  see the comments below for details.
c
c        lda     integer
c                the leading dimension of the array  abd .
c                lda must be .ge. m + 1 .
c
c        n       integer
c                the order of the matrix  a .
c
c        m       integer
c                the number of diagonals above the main diagonal.
c                0 .le. m .lt. n .
c
c     on return
c
c        abd     an upper triangular matrix  r , stored in band
c                form, so that  a = trans(r)*r .
c
c        info    integer
c                = 0  for normal return.
c                = k  if the leading minor of order  k  is not
c                     positive definite.
c
c     band storage
c
c           if  a  is a symmetric positive definite band matrix,
c           the following program segment will set up the input.
c
c                   m = (band width above diagonal)
c                   do 20 j = 1, n
c                      i1 = max0(1, j-m)
c                      do 10 i = i1, j
c                         k = i-j+m+1
c                         abd(k,j) = a(i,j)
c                10    continue
c                20 continue
c
c     linpack.  this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas ddot
c     fortran max0,sqrt
c
c     internal variables
c
      double precision ddot,t
      double precision s
      integer ik,j,jk,k,mu
c     begin block with ...exits to 40
c
c
         do 30 j = 1, n
            info = j
            s = 0.0d0
            ik = m + 1
            jk = max0(j-m,1)
            mu = max0(m+2-j,1)
            if (m .lt. mu) go to 20
            do 10 k = mu, m

               t = abd(k,j) - ddot(k-mu,abd(ik,jk),1,abd(mu,j),1)
               t = t/abd(m+1,jk)
               abd(k,j) = t
               s = s + t*t
               ik = ik - 1
               jk = jk + 1
   10       continue
   20       continue

            s = abd(m+1,j) - s
c     ......exit
            if (s .le. 0.0d0) go to 40

            abd(m+1,j) = sqrt(s)

   30    continue
         info = 0
   40 continue
      return
      end


*DECK DBESK0
      DOUBLE PRECISION FUNCTION DBESK0 (X)
C***BEGIN PROLOGUE  DBESK0
C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
C            third kind of order zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      DOUBLE PRECISION (BESK0-S, DBESK0-D)
C***KEYWORDS  FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS,
C             THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DBESK0(X) calculates the double precision modified (hyperbolic)
C Bessel function of the third kind of order zero for double
C precision argument X.  The argument must be greater than zero
C but not so large that the result underflows.
C
C Series for BK0        on the interval  0.          to  4.00000E+00
C                                        with weighted error   3.08E-33
C                                         log weighted error  32.51
C                               significant figures required  32.05
C                                    decimal places required  33.11
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DBESI0, DBSK0E, DCSEVL, INITDS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DBESK0
      DOUBLE PRECISION X, BK0CS(16), XMAX, XMAXT, XSML, Y,
     1  D1MACH, DCSEVL, DBESI0, DBSK0E
      LOGICAL FIRST
      SAVE BK0CS, NTK0, XSML, XMAX, FIRST
      DATA BK0CS(  1) / -.3532739323 3902768720 1140060063 153 D-1    /
      DATA BK0CS(  2) / +.3442898999 2462848688 6344927529 213 D+0    /
      DATA BK0CS(  3) / +.3597993651 5361501626 5721303687 231 D-1    /
      DATA BK0CS(  4) / +.1264615411 4469259233 8479508673 447 D-2    /
      DATA BK0CS(  5) / +.2286212103 1194517860 8269830297 585 D-4    /
      DATA BK0CS(  6) / +.2534791079 0261494573 0790013428 354 D-6    /
      DATA BK0CS(  7) / +.1904516377 2202088589 7214059381 366 D-8    /
      DATA BK0CS(  8) / +.1034969525 7633624585 1008317853 089 D-10   /
      DATA BK0CS(  9) / +.4259816142 7910825765 2445327170 133 D-13   /
      DATA BK0CS( 10) / +.1374465435 8807508969 4238325440 000 D-15   /
      DATA BK0CS( 11) / +.3570896528 5083735909 9688597333 333 D-18   /
      DATA BK0CS( 12) / +.7631643660 1164373766 7498666666 666 D-21   /
      DATA BK0CS( 13) / +.1365424988 4407818590 8053333333 333 D-23   /
      DATA BK0CS( 14) / +.2075275266 9066680831 9999999999 999 D-26   /
      DATA BK0CS( 15) / +.2712814218 0729856000 0000000000 000 D-29   /
      DATA BK0CS( 16) / +.3082593887 9146666666 6666666666 666 D-32   /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DBESK0
      IF (FIRST) THEN
         NTK0 = INITDS (BK0CS, 16, 0.1*REAL(D1MACH(3)))
         XSML = SQRT(4.0D0*D1MACH(3))
         XMAXT = -LOG(D1MACH(1))
         XMAX = XMAXT - 0.5D0*XMAXT*LOG(XMAXT)/(XMAXT+0.5D0)
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBESK0',
     +   'X IS ZERO OR NEGATIVE', 2, 2)
      IF (X.GT.2.0D0) GO TO 20
C
      Y = 0.D0
      IF (X.GT.XSML) Y = X*X
      DBESK0 = -LOG(0.5D0*X)*DBESI0(X) - 0.25D0 + DCSEVL (.5D0*Y-1.D0,
     1  BK0CS, NTK0)
      RETURN
C
 20   DBESK0 = 0.D0
      IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESK0',
     +   'X SO BIG K0 UNDERFLOWS', 1, 1)
      IF (X.GT.XMAX) RETURN
C
      DBESK0 = EXP(-X) * DBSK0E(X)
C
      RETURN
      END


      subroutine coher21(ne,kspec,evalu,mxfreq,mxspec,yk,spec,
     $                   mxwt,wt,eigcr,eigsp,delc2,c2,phase,
     $                   c2lo,c2hi,pherr)
      double precision evalu,spec1,spec2,sumdelc2,delsp1,delsp2
      double complex cross,sumdelph,delcr
      complex yk,eigcr
      dimension evalu(kspec),yk(mxfreq,mxspec,2),
     $          spec(mxfreq,2),wt(mxwt,mxspec,2),
     $          c2(ne),phase(ne),c2lo(ne),
     $          c2hi(ne),pherr(ne),eigcr(kspec),
     $          eigsp(kspec,2),delc2(kspec)
      parameter (pi=3.141592653589793d0,tpi=2.*pi)
      arctanh(x)=log((1+x)/(1-x))/2.
      xkspec=kspec
      do 60 i=1,ne
c  compute individual cross- and auto-eigenspectra
        do 15 j=1,kspec
   15     eigcr(j)=evalu(j)*wt(i,j,1)*wt(i,j,2)*conjg(yk(i,j,1))*
     $             yk(i,j,2)
        do 20 n=1,2
          do 20 j=1,kspec
   20       eigsp(j,n)=evalu(j)*(wt(i,j,n)*abs(yk(i,j,n)))**2
c  compute mw coherence and phase
        cross=0.
        spec1=0.
        spec2=0.
        do 30 j=1,kspec
          cross=cross+eigcr(j)
          spec1=spec1+eigsp(j,1)
   30     spec2=spec2+eigsp(j,2)
        c2(i)=abs(cross)**2/(spec1*spec2)
        phase(i)=atan2(dimag(cross),dreal(cross))
c  compute jackknife estimates of variance
        sumdelc2=0.
        sumdelph=0.
        do 40 j=1,kspec
          delcr=cross-eigcr(j)
          delsp1=spec1-eigsp(j,1)
          delsp2=spec2-eigsp(j,2)
          if ((sngl(abs(delcr)/sqrt(delsp1*delsp2))).lt.(.999999)) then
            delc2(j)=arctanh(sngl(abs(delcr)/sqrt(delsp1*delsp2)))
          else
            delc2(j)=arctanh(.999999)
          end if
          sumdelc2=sumdelc2+delc2(j)
   40     sumdelph=sumdelph+delcr/abs(delcr)
        sumdelc2=sumdelc2/xkspec
        sumdelph=sumdelph/xkspec
        var=0.
        do 50 j=1,kspec
   50     var=var+(sumdelc2-delc2(j))**2
        var=sqrt((xkspec-1.)*var/xkspec)
c
c  correct for zero divide problem in arctanh
c
        if ((sqrt(c2(i))).lt.(.999999)) then
          g=arctanh(sqrt(c2(i)))
        else
          g=arctanh(.999999)
        end if
c
c  correct for lower error bar being higher than the mean
c
        gtanhl = tanh(g-1.96*var)
        if (gtanhl.lt.0) then
          c2lo(i) = 0
        else
          c2lo(i)=gtanhl**2
        end if
c
        c2hi(i)=tanh(g+1.96*var)**2
        if(abs(sumdelph).le.1.)then
          pherr(i)=sqrt(2.*(xkspec-1.)*(1.-abs(sumdelph)))
        else
          pherr(i)=tpi
        endif
   60   continue
      return
      end

c $Id$


8 CONSTANT WORD_SIZE

VARIABLE CURRENT_VALUE
VARIABLE LAST_VALUE
VARIABLE STATUS
VARIABLE OPERATION

: ADDITION  + ;
: SUBTRACTION  - ;
: MULTIPLICATION  * ;
: DIVISION 			\ There's an additional check for division by zero and negative
						\ values as the FORTH implementation does not behave
						\ appropriately for the intended use
	DUP 0 <>
	IF
		OVER OVER	\ Makes a copy of the two operands
		XOR 0 >=		\ Checks if the two operands have a different sign
						\ If they differ the MSB of their XOR will be 1 and the
						\ resulting value will be interpreted as a negative number
		IF
			1
		ELSE
			-1
		THEN
			ROT ABS ROT ABS /			 	\ Performs division on the absolute values
			*									\ Adjusts for sign
	ELSE
		DROP DROP [ 31 MASK 1 - ] LITERAL \ Highest positive 32 bit number
	THEN ;

: EQUALS ;	\ Does nothing, this operation is intended to never be executed and
				\ only stands as a flag for wich another module has to take
				\ action appropriately

CREATE OP_SET ' ADDITION , ' SUBTRACTION , ' MULTIPLICATION , ' DIVISION , ' EQUALS ,

: CHECK_OVERFLOW ( n -- )
	STATUS @ SWAP
	DUP
	[ WORD_SIZE 1 - MASK 1 - ] LITERAL >		\ Upper bound of interval
	SWAP
	[ WORD_SIZE 1 - MASK NEGATE ] LITERAL <	\ Lower bound of interval
	OR
	IF
		1 OR
	ELSE
		[ 1 INVERT ] LITERAL AND
	THEN
	STATUS ! ;

: CHECK_NEGATIVE  ( n -- )
	STATUS @ SWAP
	0 <
	IF
		2 OR
	ELSE
		[ 2 INVERT ] LITERAL AND
	THEN
	STATUS ! ;

: TRUNCATE 				\ Sets to zero the bits outside the representable range
	[ WORD_SIZE MASK 1 - ] LITERAL AND ;

: EXTEND_SIGN
	TRUNCATE
	[ WORD_SIZE 1 - MASK ] LITERAL
	DUP ROT
	XOR SWAP 									\ Complements the (WORD_SIZE)th bit
													\ of the input value
	- 												\ If the input value was positive it resets
													\ the (WORD_SIZE)th bit to zero, else
													\ the subtraction sets it back to 1 and
													\ also the following bits by borrowing
	DUP CHECK_NEGATIVE ;

: STORE_VALUE EXTEND_SIGN CURRENT_VALUE ! ;

: COMPUTE_RESULT
	LAST_VALUE @ CURRENT_VALUE @ OPERATION @ EXECUTE
	DUP CHECK_OVERFLOW STORE_VALUE ;

: RESULT
	STATUS @
	CURRENT_VALUE @ ;

: PREPARE_NEXT
	CURRENT_VALUE @ LAST_VALUE ! ;

: CLEAR_OPERATION
	0 OPERATION ! ;

: LOGIC_SETUP
	0 CURRENT_VALUE !
	0 LAST_VALUE !
	0 STATUS !
	['] ADDITION OPERATION ! ;


*     TB01ZD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, PMAX
      PARAMETER        ( NMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDC, LDZ
      PARAMETER        ( LDA = NMAX, LDC = PMAX, LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX, PMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, N, NCONT, P
      CHARACTER*1      JOBZ
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(NMAX), C(LDC,NMAX), DWORK(LDWORK),
     $                 TAU(NMAX), Z(LDZ,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TB01ZD, DORGQR
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, P, TOL, JOBZ
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( B(I), I = 1,N )
         IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) P
         ELSE
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*           Find a controllable realization for the given system.
            CALL TB01ZD( JOBZ, N, P, A, LDA, B, C, LDC, NCONT, Z, LDZ,
     $                   TAU, TOL, DWORK, LDWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 ) NCONT
               DO 20 I = 1, NCONT
                  WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,NCONT )
   20          CONTINUE
               WRITE ( NOUT, FMT = 99996 ) ( B(I), I = 1,NCONT )
               WRITE ( NOUT, FMT = 99991 )
               DO 30 I = 1, P
                  WRITE ( NOUT, FMT = 99994 ) ( C(I,J), J = 1,NCONT )
   30          CONTINUE
               IF ( LSAME( JOBZ, 'F' ) )
     $            CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK,
     $                         INFO )
               IF ( LSAME( JOBZ, 'F' ).OR.LSAME( JOBZ, 'I' ) ) THEN
                  WRITE ( NOUT, FMT = 99995 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99994 ) ( Z(I,J), J = 1,N )
   40             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01ZD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01ZD = ',I2)
99997 FORMAT (' The order of the controllable state-space representati',
     $       'on = ',I2,//' The state dynamics matrix A of a controlla',
     $       'ble realization is ')
99996 FORMAT (/' The input/state vector B of a controllable realizatio',
     $       'n is ',/(1X,F8.4))
99995 FORMAT (/' The similarity transformation matrix Z is ')
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' P is out of range.',/' P = ',I5)
99991 FORMAT (/' The output/state matrix C of a controllable realizati',
     $       'on is ')
      END


c
c
c =========================================================
      subroutine limiter(maxmx,meqn,mwaves,mbc,mx,wave,s,
     &                   dtdx,phi,mthlim)
c =========================================================
c
c     # this routine limits the high-order correction term phi
c
c
      implicit double precision (a-h,o-z)
c     # extern variables
      dimension   wave(1-mbc:maxmx+mbc, meqn, mwaves)
      dimension      s(1-mbc:maxmx+mbc, mwaves)
      dimension    phi(1-mbc:maxmx+mbc, meqn, mwaves)
      dimension   dtdx(1-mbc:maxmx+mbc)
      dimension mthlim(mwaves)
c     # intern variables
      dimension      d(1-mbc:maxmx+mbc, meqn, mwaves)
      dimension    snu(1-mbc:maxmx+mbc, mwaves)
c
c     ===============================================================
c     # wave limiter
c     ===============================================================
c
      do 50 mw=1,mwaves
         if (mthlim(mw) .ge. 1) go to 50
         dotr = 0.d0
         do 40 i = 2-mbc, mx+mbc-1
            wnorm2 = 0.d0
            dotl = dotr
            dotr = 0.d0
            do 20 m=1,meqn
               wnorm2 = wnorm2 + wave(i,m,mw)**2
               dotr = dotr + wave(i,m,mw)*wave(i+1,m,mw)
   20          continue
            if (i.eq.0) go to 40
            if (wnorm2.eq.0.d0) go to 40
c
            if (s(i,mw) .gt. 0.d0) then
                wlimitr = philim(wnorm2, dotl, mthlim(mw))
              else
                wlimitr = philim(wnorm2, dotr, mthlim(mw))
              endif
c
            do 30 m=1,meqn
               phi(i,m,mw) = wlimitr * phi(i,m,mw)
   30          continue
   40       continue
   50    continue
c
c     # computing courant-number
      do 5 i=3-mbc,mx+mbc-2
         do 6 mw=1,mwaves
            if(s(i,mw) .ge. 0d0) then
                dtdxave=dtdx(i)
            else
                dtdxave=dtdx(i-1)
            endif
            snu(i,mw)=dtdxave*dabs(s(i,mw))
    6       continue
    5    continue
c
c     ===============================================================
c     # TVD limiter
c     ===============================================================
c
      do 12 i=1,mx
         do 22 m=1,meqn
            do 32 mw=1,mwaves
              if(mthlim(mw) .eq. 1) then
               if(s(i,mw) .ge. 0d0) then
               phi(i,m,mw)=dmax1(0d0,dmin1(2d0/(1d0-snu(i,mw)),
     &            phi(i,m,mw),
     &                 (2d0 * wave(i-1,m,mw))
     &                   /(snu(i,mw) * wave(i,m,mw)+1.d-15)
     &            * (1d0-snu(i-1,mw))/(1d0-snu(i,mw))
     &            ))
               else
               phi(i,m,mw)=dmax1(0d0,dmin1(2d0/(1d0-snu(i,mw)),
     &            phi(i,m,mw),
     &                 (2d0 * wave(i+1,m,mw))
     &                   /(snu(i,mw) * wave(i,m,mw)+1.d-15)
     &            * (1d0-snu(i+1,mw))/(1d0-snu(i,mw))
     &            ))
               endif
              endif
   32          continue
   22       continue
   12    continue
c
c
c     ===============================================================
c     # MP limiter
c     ===============================================================
c
c     # computing curvature
      do 13 i=1,mx
         do 23 m=1,meqn
            do 33 mw=1,mwaves
               d1=wave(i+1,m,mw)-wave(i,m,mw)
               d2=wave(i,m,mw)-wave(i-1,m,mw)
               d(i,m,mw)=dmax1(0d0, dmin1(d1,d2))
   33          continue
   23       continue
   13    continue
c
c     # computing MP-limiter
      do 14 i=1,mx
         do 24 m=1,meqn
            do 34 mw=1,mwaves
              if(mthlim(mw) .eq. 2) then
               if(s(i,mw) .ge. 0d0) then
                  r=wave(i-1,m,mw)/(wave(i,m,mw)+1.d-15)
               else
                  r=wave(i+1,m,mw)/(wave(i,m,mw)+1.d-15)
               endif
               phimd=0.5d0*(wave(i,m,mw)-d(i,m,mw))
               philc=1d0/snu(i,mw) * (r
     &           +  d(i-1,m,mw)/(wave(i,m,mw)+1.d-15))
               phimin=dmax1(dmin1(0d0,phimd),
     &                dmin1(0d0,2d0*r/snu(i,mw),
     &                      philc))
               phimax=dmin1(dmax1(2d0/(1d0-snu(i,mw)),phimd),
     &                dmax1(0d0,2d0*r/snu(i,mw),
     &                      philc))
               phi(i,m,mw)=dmax1(phimin,dmin1(phi(i,m,mw),phimax))
              endif
   34          continue
   24       continue
   14    continue
c
      return
      end


	SUBROUTINE lubksb(a,indx,b)
	USE nrtype; USE nrutil, ONLY : assert_eq
	IMPLICIT NONE
	REAL(SP), DIMENSION(:,:), INTENT(IN) :: a
	INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx
	REAL(SP), DIMENSION(:), INTENT(INOUT) :: b
	INTEGER(I4B) :: i,n,ii,ll
	REAL(SP) :: summ
	n=assert_eq(size(a,1),size(a,2),size(indx),'lubksb')
	ii=0
	do i=1,n
		ll=indx(i)
		summ=b(ll)
		b(ll)=b(i)
		if (ii /= 0) then
			summ=summ-dot_product(a(i,ii:i-1),b(ii:i-1))
		else if (summ /= 0.0) then
			ii=i
		end if
		b(i)=summ
	end do
	do i=n,1,-1
		b(i) = (b(i)-dot_product(a(i,i+1:n),b(i+1:n)))/a(i,i)
	end do
	END SUBROUTINE lubksb


! { dg-do run }
! PR 21875 : Test formatted input/output to/from character arrays.
! Contributed by Jerry DeLisle <jvdelisle@verizon.net>.
      program arrayio_1
      implicit none
      integer         :: i(6),j,k
      character(12)  :: r(12,2) = '0123456789AB'

! Write to and read from a whole character array

      i = (/(j,j=1,6)/)
      write(r,'(3(2x,i4/)/3(3x,i6/))') i
      i = 0
      read(r,'(3(2x,i4/)/3(3x,i6/))') i
      if (any(i.ne.(/(j,j=1,6)/))) call abort()
      do j=1,12
         do k=1,2
            if ((j.gt.8.and.k.eq.1).or.(k.eq.2)) then
              if (r(j,k).ne.'0123456789AB') call abort()
            end if
         end do
      end do

 ! Write to a portion of a character array
      r = '0123456789AB'
      write(r(3:9,1),'(6(i12/))') i
      if (r(2,1).ne.'0123456789AB') call abort()
      do j=3,8
        if (iachar(trim(adjustl(r(j,1))))-46.ne.j) call abort()
      end do
      if (r(9,1).ne.'            ') call abort()
      end program arrayio_1


c
c
c=========================================================
      subroutine qinit(meqn,mbc,mx,xlower,dx,q,maux,aux)
c=========================================================
c
c     # Set initial conditions for q.
c     # Pulse in pressure, zero velocity
c
c
      implicit none

      integer, intent(in) :: meqn, mbc, mx, maux
      double precision, intent(in) :: xlower, dx, aux
      double precision, intent(out) :: q
      dimension q(meqn, 1-mbc:mx+mbc)
      dimension aux(maux, 1-mbc:mx+mbc)

      common /cqinit/ beta,ic
      double precision beta
      integer ic

      integer i
      double precision xcell
c
c
      do 150 i=1,mx
         xcell = xlower + (i-0.5d0)*dx

         go to (10,20,30) ic

 10      continue
c     # half ellipse:
         if (xcell.gt.-4d0 .and. xcell.lt.-2d0) then
            q(1,i) = dsqrt(1.d0 - (xcell+3.d0)**2)
         else
            q(1,i) = 0.d0
         endif
         q(2,i) = q(1,i)
         go to 150

 20      continue
c     # single discontinuity:
         if (xcell .lt. -2.d0) then
            q(1,i) = 1.d0
         else
            q(1,i) = 0.d0
         endif
         q(2,i) = q(1,i)
         go to 150

 30      continue
c     # Gaussian and square pulse:
         q(1,i) = dexp(-beta*(xcell+2.0d0)**2)
         if (dabs(q(1,i)) .lt. 1d-30) q(1,i) = 0.d0
         if (xcell.gt.-4.d0 .and. xcell.lt.-3.d0) then
            q(1,i) = q(1,i) + 0.5d0
         endif
         q(2,i) = q(1,i)
         go to 150

 150  continue
c
      return
      end


program main
  use mpi
  implicit none

  ! Handles for Elemental's C++ objects
  integer :: grid, A, B, w, X

  ! Process grid information
  integer :: r, c, p, row, col, rank

  ! Our process's local matrix size (for A and B)
  integer :: localHeight, localWidth

  ! Local buffers for distributed A and B matrices
  real*8, allocatable, dimension(:,:) :: ALocal, BLocal

  ! Indices
  integer :: i, j, iLocal, jLocal

  ! Useful constants
  integer :: zeroInt = 0
  integer :: n = 10                ! problem size
  integer :: nb = 96               ! algorithmic blocksize
  integer :: comm = MPI_COMM_WORLD ! global communicator

  ! Initialize Elemental and MPI
  call elem_initialize()

  ! Create a process grid and extract the relevant information
  call elem_create_grid( comm, grid )
  call elem_grid_height( grid, r )
  call elem_grid_width( grid, c )
  call elem_grid_size( grid, p )
  call elem_grid_row( grid, row )
  call elem_grid_col( grid, col )
  call elem_grid_rank( grid, rank )

  ! Create buffers for passing into data for distributed matrices
  call elem_length( n, row, r, localHeight )
  call elem_length( n, col, c, localWidth )
  allocate(ALocal(localHeight,localWidth))
  allocate(BLocal(localHeight,localWidth))

  ! Set entry (i,j) of the A matrix to i+j, which is symmetric
  do jLocal=1,localWidth
    j = col + (jLocal-1)*c + 1
    do iLocal=1,localHeight
      i = row + (iLocal-1)*r + 1
      ALocal(iLocal,jLocal) = i+j
    end do
  end do

  ! Set B to twice the identity since it is a trivial SPD matrix
  do jLocal=1,localWidth
    j = col + (jLocal-1)*c + 1
    do iLocal=1,localHeight
      i = row + (iLocal-1)*r + 1
      if( i == j ) then
        BLocal(iLocal,jLocal) = 2.0;
      else
        BLocal(iLocal,jLocal) = 0.0;
      end if
    end do
  end do

  ! Register the distributed matrices, A and B, with Elemental
  call elem_register_dist_mat( &
    n, n, zeroInt, zeroInt, ALocal, localHeight, grid, a )
  call elem_register_dist_mat( &
    n, n, zeroInt, zeroInt, BLocal, localHeight, grid, b )

  ! I do not know of a good way to flush the output from F90, as the flush
  ! command is not standard. Thus, I chose not to write to stdout from F90.

  ! Print the input matrices
  call elem_print_dist_mat( A )
  call elem_print_dist_mat( B )

  ! Set the algorithmic blocksize to 'nb'
  call elem_set_blocksize( nb )

  ! For tuning purposes choose one of the following
  ! (see http://elemental.googlecode.com/hg/doc/build/html/advanced/tuning.html
  !  for more details)
  !
  !call elem_set_normal_tridiag_approach
  call elem_set_square_tridiag_approach
  !call elem_set_default_tridiag_approach
  !
  ! and then choose one of the following
  !
  call elem_set_row_major_tridiag_subgrid
  !call elem_set_col_major_tridiag_subgrid
  !
  ! For sufficiently large numbers of processes,
  ! 'elem_set_square_tridiag_approach'
  ! will be the fastest, but whether a row-major or column-major ordering of
  ! the subgrid is best depends upon your network (hence the second choice).

  ! Given the pencil (A,B), solve for (w,X) such that AX=BX diag(w)
  call elem_symmetric_axbx( A, B, w, X )

  ! Print the eigenvalues and eigenvectors
  call elem_print_dist_mat( X )
  call elem_print_dist_mat_vr_star( w )

  ! Shut down Elemental and MPI
  call elem_finalize()

 end